diff --git a/thys/Cook_Levin/Arithmetic.thy b/thys/Cook_Levin/Arithmetic.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Arithmetic.thy
@@ -0,0 +1,6500 @@
+section \<open>Arithmetic\label{s:tm-arithmetic}\<close>
+
+theory Arithmetic
+  imports Memorizing
+begin
+
+text \<open>
+In this section we define a representation of natural numbers and some reusable
+Turing machines for elementary arithmetical operations.  All Turing machines
+implementing the operations assume that the tape heads on the tapes containing
+the operands and the result(s) contain one natural number each.  In programming
+language terms we could say that such a tape corresponds to a variable of type
+@{typ nat}. Furthermore, initially the tape heads are on cell number~1, that is,
+one to the right of the start symbol. The Turing machines will halt with the
+tape heads in that position as well. In that way operations can be concatenated
+seamlessly.
+\<close>
+
+subsection \<open>Binary numbers\label{s:tm-arithmetic-binary}\<close>
+
+text \<open>
+We represent binary numbers as sequences of the symbols \textbf{0} and
+\textbf{1}.  Slightly unusually the least significant bit will be on the left.
+While every sequence over these symbols represents a natural number, the
+representation is not unique due to leading (or rather, trailing) zeros.  The
+\emph{canonical} representation is unique and has no trailing zeros, not even for
+the number zero, which is thus represented by the empty symbol sequence.  As a
+side effect empty tapes can be thought of as being initialized with zero.
+
+Naturally the binary digits 0 and 1 are represented by the symbols \textbf{0}
+and \textbf{1}, respectively. For example, the decimal number $14$,
+conventionally written $1100_2$ in binary, is represented by the symbol sequence
+\textbf{0011}. The next two functions map between symbols and binary digits:
+\<close>
+
+abbreviation (input) tosym :: "nat \<Rightarrow> symbol" where
+  "tosym z \<equiv> z + 2"
+
+abbreviation todigit :: "symbol \<Rightarrow> nat" where
+  "todigit z \<equiv> if z = \<one> then 1 else 0"
+
+text \<open>
+The numerical value of a symbol sequence:
+\<close>
+
+definition num :: "symbol list \<Rightarrow> nat" where
+  "num xs \<equiv> \<Sum>i\<leftarrow>[0..<length xs]. todigit (xs ! i) * 2 ^ i"
+
+text \<open>
+The $i$-th digit of a symbol sequence, where digits out of bounds are considered
+trailing zeros:
+\<close>
+
+definition digit :: "symbol list \<Rightarrow> nat \<Rightarrow> nat" where
+  "digit xs i \<equiv> if i < length xs then xs ! i else 0"
+
+text \<open>
+Some properties of $num$:
+\<close>
+
+lemma num_ge_pow:
+  assumes "i < length xs" and "xs ! i = \<one>"
+  shows "num xs \<ge> 2 ^ i"
+proof -
+  let ?ys = "map (\<lambda>i. todigit (xs ! i) * 2 ^ i) [0..<length xs]"
+  have "?ys ! i = 2 ^ i"
+    using assms by simp
+  moreover have "i < length ?ys"
+    using assms(1) by simp
+  ultimately show "num xs \<ge> 2 ^ i"
+    unfolding num_def using elem_le_sum_list by (metis (no_types, lifting))
+qed
+
+lemma num_trailing_zero:
+  assumes "todigit z = 0"
+  shows "num xs = num (xs @ [z])"
+proof -
+  let ?xs = "xs @ [z]"
+  let ?ys = "map (\<lambda>i. todigit (?xs ! i) * 2 ^ i) [0..<length ?xs]"
+  have *: "?ys = map (\<lambda>i. todigit (xs ! i) * 2 ^ i) [0..<length xs] @ [0]"
+    using assms by (simp add: nth_append)
+  have "num ?xs = sum_list ?ys"
+    using num_def by simp
+  then have "num ?xs = sum_list (map (\<lambda>i. todigit (xs ! i) * 2 ^ i) [0..<length xs] @ [0])"
+    using * by metis
+  then have "num ?xs = sum_list (map (\<lambda>i. todigit (xs ! i) * 2 ^ i) [0..<length xs])"
+    by simp
+  then show ?thesis
+    using num_def by simp
+qed
+
+lemma num_Cons: "num (x # xs) = todigit x + 2 * num xs"
+proof -
+  have "[0..<length (x # xs)] = [0..<1] @ [1..<length (x # xs)]"
+    by (metis length_Cons less_imp_le_nat plus_1_eq_Suc upt_add_eq_append zero_less_one)
+  then have 1: "(map (\<lambda>i. todigit ((x # xs) ! i) * 2 ^ i) [0..<length (x # xs)]) =
+    (map (\<lambda>i. todigit ((x # xs) ! i) * 2 ^ i) [0..<1]) @
+    (map (\<lambda>i. todigit ((x # xs) ! i) * 2 ^ i) [1..<length (x # xs)])"
+    by simp
+
+  have "map (\<lambda>i. f i) [1..<Suc m] = map (\<lambda>i. f (Suc i)) [0..<m]" for f :: "nat \<Rightarrow> nat" and m
+  proof (rule nth_equalityI)
+    show "length (map f [1..<Suc m]) = length (map (\<lambda>i. f (Suc i)) [0..<m])"
+      by simp
+    then show "\<And>i. i < length (map f [1..<Suc m]) \<Longrightarrow>
+        map f [1..<Suc m] ! i = map (\<lambda>i. f (Suc i)) [0..<m] ! i"
+      by (metis add.left_neutral length_map length_upt nth_map_upt plus_1_eq_Suc)
+  qed
+  then have 2: "(\<Sum>i\<leftarrow>[1..<Suc m]. f i) = (\<Sum>i\<leftarrow>[0..<m]. f (Suc i))"
+      for f :: "nat \<Rightarrow> nat" and m
+    by simp
+
+  have "num (x # xs) = (\<Sum>i\<leftarrow>[0..<length (x # xs)]. todigit ((x # xs) ! i) * 2 ^ i)"
+    using num_def by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<1]. (todigit ((x # xs) ! i) * 2 ^ i)) +
+      (\<Sum>i\<leftarrow>[1..<length (x # xs)]. todigit ((x # xs) ! i) * 2 ^ i)"
+    using 1 by simp
+  also have "... = todigit x + (\<Sum>i\<leftarrow>[1..<length (x # xs)]. todigit ((x # xs) ! i) * 2 ^ i)"
+    by simp
+  also have "... = todigit x + (\<Sum>i\<leftarrow>[0..<length (x # xs) - 1]. todigit ((x # xs) ! (Suc i)) * 2 ^ (Suc i))"
+    using 2 by simp
+  also have "... = todigit x + (\<Sum>i\<leftarrow>[0..<length xs]. todigit (xs ! i) * 2 ^ (Suc i))"
+    by simp
+  also have "... = todigit x + (\<Sum>i\<leftarrow>[0..<length xs]. todigit (xs ! i) * (2 * 2 ^ i))"
+    by simp
+  also have "... = todigit x + (\<Sum>i\<leftarrow>[0..<length xs]. (todigit (xs ! i) * 2 * 2 ^ i))"
+    by (simp add: mult.assoc)
+  also have "... = todigit x + (\<Sum>i\<leftarrow>[0..<length xs]. (2 * (todigit (xs ! i) * 2 ^ i)))"
+    by (metis (mono_tags, opaque_lifting) ab_semigroup_mult_class.mult_ac(1) mult.commute)
+  also have "... = todigit x + 2 * (\<Sum>i\<leftarrow>[0..<length xs]. (todigit (xs ! i) * 2 ^ i))"
+    using sum_list_const_mult by fastforce
+  also have "... = todigit x + 2 * num xs"
+    using num_def by simp
+  finally show ?thesis .
+qed
+
+lemma num_append: "num (xs @ ys) = num xs + 2 ^ length xs * num ys"
+proof (induction "length xs" arbitrary: xs)
+  case 0
+  then show ?case
+    using num_def by simp
+next
+  case (Suc n)
+  then have xs: "xs = hd xs # tl xs"
+    by (metis hd_Cons_tl list.size(3) nat.simps(3))
+  then have "xs @ ys = hd xs # (tl xs @ ys)"
+    by simp
+  then have "num (xs @ ys) = todigit (hd xs) + 2 * num (tl xs @ ys)"
+    using num_Cons by presburger
+  also have "... = todigit (hd xs) + 2 * (num (tl xs) + 2 ^ length (tl xs) * num ys)"
+    using Suc by simp
+  also have "... = todigit (hd xs) + 2 * num (tl xs) + 2 ^ Suc (length (tl xs)) * num ys"
+    by simp
+  also have "... = num xs + 2 ^ Suc (length (tl xs)) * num ys"
+    using num_Cons xs by metis
+  also have "... = num xs + 2 ^ length xs * num ys"
+    using xs by (metis length_Cons)
+  finally show ?case .
+qed
+
+lemma num_drop: "num (drop t zs) = todigit (digit zs t) + 2 * num (drop (Suc t) zs)"
+proof (cases "t < length zs")
+  case True
+  then have "drop t zs = zs ! t # drop (Suc t) zs"
+    by (simp add: Cons_nth_drop_Suc)
+  then have "num (drop t zs) = todigit (zs ! t) + 2 * num (drop (Suc t) zs)"
+    using num_Cons by simp
+  then show ?thesis
+    using digit_def True by simp
+next
+  case False
+  then show ?thesis
+    using digit_def num_def by simp
+qed
+
+lemma num_take_Suc: "num (take (Suc t) zs) = num (take t zs) + 2 ^ t * todigit (digit zs t)"
+proof (cases "t < length zs")
+  case True
+  let ?zs = "take (Suc t) zs"
+  have 1: "?zs ! i = zs ! i" if "i < Suc t" for i
+    using that by simp
+  have 2: "take t zs ! i = zs ! i" if "i < t" for i
+    using that by simp
+  have "num ?zs = (\<Sum>i\<leftarrow>[0..<length ?zs]. todigit (?zs ! i) * 2 ^ i)"
+    using num_def by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<Suc t]. todigit (?zs ! i) * 2 ^ i)"
+    by (simp add: Suc_leI True min_absorb2)
+  also have "... = (\<Sum>i\<leftarrow>[0..<Suc t]. todigit (zs ! i) * 2 ^ i)"
+    using 1 by (smt (verit, best) atLeastLessThan_iff map_eq_conv set_upt)
+  also have "... = (\<Sum>i\<leftarrow>[0..<t]. todigit (zs ! i) * 2 ^ i) + todigit (zs ! t) * 2 ^ t"
+    by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<t]. todigit (take t zs ! i) * 2 ^ i) + todigit (zs ! t) * 2 ^ t"
+    using 2 by (metis (no_types, lifting) atLeastLessThan_iff map_eq_conv set_upt)
+  also have "... = num (take t zs) + todigit (zs ! t) * 2 ^ t"
+    using num_def True by simp
+  also have "... = num (take t zs) + todigit (digit zs t) * 2 ^ t"
+    using digit_def True by simp
+  finally show ?thesis
+    by simp
+next
+  case False
+  then show ?thesis
+    using digit_def by simp
+qed
+
+text \<open>
+A symbol sequence is a canonical representation of a natural number if the
+sequence contains only the symbols \textbf{0} and \textbf{1} and is either empty
+or ends in \textbf{1}.
+\<close>
+
+definition canonical :: "symbol list \<Rightarrow> bool" where
+  "canonical xs \<equiv> bit_symbols xs \<and> (xs = [] \<or> last xs = \<one>)"
+
+lemma canonical_Cons:
+  assumes "canonical xs" and "xs \<noteq> []" and "x = \<zero> \<or> x = \<one>"
+  shows "canonical (x # xs)"
+  using assms canonical_def less_Suc_eq_0_disj by auto
+
+lemma canonical_Cons_3: "canonical xs \<Longrightarrow> canonical (\<one> # xs)"
+  using canonical_def less_Suc_eq_0_disj by auto
+
+lemma canonical_tl: "canonical (x # xs) \<Longrightarrow> canonical xs"
+  using canonical_def by fastforce
+
+lemma prepend_2_even: "x = \<zero> \<Longrightarrow> even (num (x # xs))"
+  using num_Cons by simp
+
+lemma prepend_3_odd: "x = \<one> \<Longrightarrow> odd (num (x # xs))"
+  using num_Cons by simp
+
+text \<open>
+Every number has exactly one canonical representation.
+\<close>
+
+lemma canonical_ex1:
+  fixes n :: nat
+  shows "\<exists>!xs. num xs = n \<and> canonical xs"
+proof (induction n rule: nat_less_induct)
+  case IH: (1 n)
+  show ?case
+  proof (cases "n = 0")
+    case True
+    have "num [] = 0"
+      using num_def by simp
+    moreover have "canonical xs \<Longrightarrow> num xs = 0 \<Longrightarrow> xs = []" for xs
+    proof (rule ccontr)
+      fix xs
+      assume "canonical xs" "num xs = 0" "xs \<noteq> []"
+      then have "length xs > 0" "last xs = \<one>"
+        using canonical_def by simp_all
+      then have "xs ! (length xs - 1) = \<one>"
+        by (metis Suc_diff_1 last_length)
+      then have "num xs \<ge> 2 ^ (length xs - 1)"
+        using num_ge_pow by (meson \<open>0 < length xs\<close> diff_less zero_less_one)
+      then have "num xs > 0"
+        by (meson dual_order.strict_trans1 le0 le_less_trans less_exp)
+      then show False
+        using \<open>num xs = 0\<close> by auto
+    qed
+    ultimately show ?thesis
+      using IH True canonical_def by (metis less_nat_zero_code list.size(3))
+  next
+    case False
+    then have gt: "n > 0"
+      by simp
+    define m where "m = n div 2"
+    define r where "r = n mod 2"
+    have n: "n = 2 * m + r"
+      using m_def r_def by simp
+    have "m < n"
+      using gt m_def by simp
+    then obtain xs where "num xs = m" "canonical xs"
+      using IH by auto
+    then have "num (tosym r # xs) = n"
+        (is "num ?xs = n")
+      using num_Cons n add.commute r_def by simp
+    have "canonical ?xs"
+    proof (cases "r = 0")
+      case True
+      then have "m > 0"
+        using gt n by simp
+      then have "xs \<noteq> []"
+        using `num xs = m` num_def by auto
+      then show ?thesis
+        using canonical_Cons[of xs] `canonical xs` r_def True by simp
+    next
+      case False
+      then show ?thesis
+        using `canonical xs` canonical_Cons_3 r_def
+        by (metis One_nat_def not_mod_2_eq_1_eq_0 numeral_3_eq_3 one_add_one plus_1_eq_Suc)
+    qed
+    moreover have "xs1 = xs2" if "canonical xs1" "num xs1 = n" "canonical xs2" "num xs2 = n" for xs1 xs2
+    proof -
+      have "xs1 \<noteq> []"
+        using gt that(2) num_def by auto
+      then obtain x1 ys1 where 1: "xs1 = x1 # ys1"
+        by (meson neq_Nil_conv)
+      then have x1: "x1 = \<zero> \<or> x1 = \<one>"
+        using canonical_def that(1) by auto
+      have "xs2 \<noteq> []"
+        using gt that(4) num_def by auto
+      then obtain x2 ys2 where 2: "xs2 = x2 # ys2"
+        by (meson neq_Nil_conv)
+      then have x2: "x2 = \<zero> \<or> x2 = \<one>"
+        using canonical_def that(3) by auto
+      have "x1 = x2"
+        using prepend_2_even prepend_3_odd that 1 2 x1 x2 by metis
+      moreover have "n = todigit x1 + 2 * num ys1"
+        using that(2) num_Cons 1 by simp
+      moreover have "n = todigit x2 + 2 * num ys2"
+        using that(4) num_Cons 2 by simp
+      ultimately have "num ys1 = num ys2"
+        by simp
+      moreover have "num ys1 < n"
+        using that(2) num_Cons 1 gt by simp
+      moreover have "num ys2 < n"
+        using that(4) num_Cons 2 gt by simp
+      ultimately have "ys1 = ys2"
+        using IH 1 2 that(1,3) by (metis canonical_tl)
+      then show "xs1 = xs2"
+        using `x1 = x2` 1 2 by simp
+    qed
+    ultimately show ?thesis
+      using \<open>num (tosym r # xs) = n\<close> by auto
+  qed
+qed
+
+text \<open>
+The canonical representation of a natural number as symbol sequence:
+\<close>
+
+definition canrepr :: "nat \<Rightarrow> symbol list" where
+  "canrepr n \<equiv> THE xs. num xs = n \<and> canonical xs"
+
+lemma canrepr_inj: "inj canrepr"
+  using canrepr_def canonical_ex1 by (smt (verit, del_insts) inj_def the_equality)
+
+lemma canonical_canrepr: "canonical (canrepr n)"
+  using theI'[OF canonical_ex1] canrepr_def by simp
+
+lemma canrepr: "num (canrepr n) = n"
+  using theI'[OF canonical_ex1] canrepr_def by simp
+
+lemma bit_symbols_canrepr: "bit_symbols (canrepr n)"
+  using canonical_canrepr canonical_def by simp
+
+lemma proper_symbols_canrepr: "proper_symbols (canrepr n)"
+  using bit_symbols_canrepr by fastforce
+
+lemma canreprI: "num xs = n \<Longrightarrow> canonical xs \<Longrightarrow> canrepr n = xs"
+  using canrepr canonical_canrepr canonical_ex1 by blast
+
+lemma canrepr_0: "canrepr 0 = []"
+  using num_def canonical_def by (intro canreprI) simp_all
+
+lemma canrepr_1: "canrepr 1 = [\<one>]"
+  using num_def canonical_def by (intro canreprI) simp_all
+
+text \<open>
+The length of the canonical representation of a number $n$:
+\<close>
+
+abbreviation nlength :: "nat \<Rightarrow> nat" where
+  "nlength n \<equiv> length (canrepr n)"
+
+lemma nlength_0: "nlength n = 0 \<longleftrightarrow> n = 0"
+  by (metis canrepr canrepr_0 length_0_conv)
+
+corollary nlength_0_simp [simp]: "nlength 0 = 0"
+  using nlength_0 by simp
+
+lemma num_replicate2_eq_pow: "num (replicate j \<zero> @ [\<one>]) = 2 ^ j"
+proof (induction j)
+  case 0
+  then show ?case
+    using num_def by simp
+next
+  case (Suc j)
+  then show ?case
+    using num_Cons by simp
+qed
+
+lemma num_replicate3_eq_pow_minus_1: "num (replicate j \<one>) = 2 ^ j - 1"
+proof (induction j)
+  case 0
+  then show ?case
+    using num_def by simp
+next
+  case (Suc j)
+  then have "num (replicate (Suc j) \<one>) = num (\<one> # replicate j \<one>)"
+    by simp
+  also have "... = 1 + 2 * (2 ^ j - 1)"
+    using Suc num_Cons by simp
+  also have "... = 1 + 2 * 2 ^ j - 2"
+    by (metis Nat.add_diff_assoc diff_mult_distrib2 mult_2 mult_le_mono2 nat_1_add_1 one_le_numeral one_le_power)
+  also have "... = 2 ^ Suc j - 1"
+    by simp
+  finally show ?case .
+qed
+
+lemma nlength_pow2: "nlength (2 ^ j) = Suc j"
+proof -
+  define xs :: "nat list" where "xs = replicate j 2 @ [3]"
+  then have "length xs = Suc j"
+    by simp
+  moreover have "num xs = 2 ^ j"
+    using num_replicate2_eq_pow xs_def by simp
+  moreover have "canonical xs"
+    using xs_def bit_symbols_append canonical_def by simp
+  ultimately show ?thesis
+    using canreprI by blast
+qed
+
+corollary nlength_1_simp [simp]: "nlength 1 = 1"
+  using nlength_pow2[of 0] by simp
+
+corollary nlength_2: "nlength 2 = 2"
+  using nlength_pow2[of 1] by simp
+
+lemma nlength_pow_minus_1: "nlength (2 ^ j - 1) = j"
+proof -
+  define xs :: "nat list" where "xs = replicate j \<one>"
+  then have "length xs = j"
+    by simp
+  moreover have "num xs = 2 ^ j - 1"
+    using num_replicate3_eq_pow_minus_1 xs_def by simp
+  moreover have "canonical xs"
+  proof -
+    have "bit_symbols xs"
+      using xs_def by simp
+    moreover have "last xs = 3 \<or> xs = []"
+      by (cases "j = 0") (simp_all add: xs_def)
+    ultimately show ?thesis
+      using canonical_def by auto
+  qed
+  ultimately show ?thesis
+    using canreprI by metis
+qed
+
+corollary nlength_3: "nlength 3 = 2"
+  using nlength_pow_minus_1[of 2] by simp
+
+text \<open>
+When handling natural numbers, Turing machines will usually have tape contents
+of the following form:
+\<close>
+
+abbreviation ncontents :: "nat \<Rightarrow> (nat \<Rightarrow> symbol)" ("\<lfloor>_\<rfloor>\<^sub>N") where
+  "\<lfloor>n\<rfloor>\<^sub>N \<equiv> \<lfloor>canrepr n\<rfloor>"
+
+lemma ncontents_0: "\<lfloor>0\<rfloor>\<^sub>N = \<lfloor>[]\<rfloor>"
+  by (simp add: canrepr_0)
+
+lemma clean_tape_ncontents: "clean_tape (\<lfloor>x\<rfloor>\<^sub>N, i)"
+  using bit_symbols_canrepr clean_contents_proper by fastforce
+
+lemma ncontents_1_blank_iff_zero: "\<lfloor>n\<rfloor>\<^sub>N 1 = \<box> \<longleftrightarrow> n = 0"
+  using bit_symbols_canrepr contents_def nlength_0
+  by (metis contents_outofbounds diff_is_0_eq' leI length_0_conv length_greater_0_conv less_one zero_neq_numeral)
+
+text \<open>
+Every bit symbol sequence can be turned into a canonical representation of some
+number by stripping trailing zeros. The length of the prefix without trailing
+zeros is given by the next function:
+\<close>
+
+definition canlen :: "symbol list \<Rightarrow> nat" where
+  "canlen zs \<equiv> LEAST m. \<forall>i<length zs. i \<ge> m \<longrightarrow> zs ! i = \<zero>"
+
+lemma canlen_at_ge: "\<forall>i<length zs. i \<ge> canlen zs \<longrightarrow> zs ! i = \<zero>"
+proof -
+  let ?P = "\<lambda>m. \<forall>i<length zs. i \<ge> m \<longrightarrow> zs ! i = \<zero>"
+  have "?P (length zs)"
+    by simp
+  then show ?thesis
+    unfolding canlen_def using LeastI[of ?P "length zs"] by fast
+qed
+
+lemma canlen_eqI:
+  assumes "\<forall>i<length zs. i \<ge> m \<longrightarrow> zs ! i = \<zero>"
+    and "\<And>y. \<forall>i<length zs. i \<ge> y \<longrightarrow> zs ! i = \<zero> \<Longrightarrow> m \<le> y"
+  shows "canlen zs = m"
+  unfolding canlen_def using assms Least_equality[of _ m, OF _ assms(2)] by presburger
+
+lemma canlen_le_length: "canlen zs \<le> length zs"
+proof -
+  let ?P = "\<lambda>m. \<forall>i<length zs. i \<ge> m \<longrightarrow> zs ! i = \<zero>"
+  have "?P (length zs)"
+    by simp
+  then show ?thesis
+    unfolding canlen_def using Least_le[of _ "length zs"] by simp
+qed
+
+lemma canlen_le:
+  assumes "\<forall>i<length zs. i \<ge> m \<longrightarrow> zs ! i = \<zero>"
+  shows "m \<ge> canlen zs"
+  unfolding canlen_def using Least_le[of _ m] assms by simp
+
+lemma canlen_one:
+  assumes "bit_symbols zs" and "canlen zs > 0"
+  shows "zs ! (canlen zs - 1) = \<one>"
+proof (rule ccontr)
+  assume "zs ! (canlen zs - 1) \<noteq> \<one>"
+  then have "zs ! (canlen zs - 1) = \<zero>"
+    using assms canlen_le_length
+    by (metis One_nat_def Suc_pred lessI less_le_trans)
+  then have "\<forall>i<length zs. i \<ge> canlen zs - 1 \<longrightarrow> zs ! i = 2"
+    using canlen_at_ge assms(2) by (metis One_nat_def Suc_leI Suc_pred le_eq_less_or_eq)
+  then have "canlen zs - 1 \<ge> canlen zs"
+    using canlen_le by auto
+  then show False
+    using assms(2) by simp
+qed
+
+lemma canonical_take_canlen:
+  assumes "bit_symbols zs"
+  shows "canonical (take (canlen zs) zs)"
+proof (cases "canlen zs = 0")
+  case True
+  then show ?thesis
+    using canonical_def by simp
+next
+  case False
+  then show ?thesis
+    using canonical_def assms canlen_le_length canlen_one
+    by (smt (verit, ccfv_SIG) One_nat_def Suc_pred append_take_drop_id diff_less last_length
+      length_take less_le_trans min_absorb2 neq0_conv nth_append zero_less_one)
+qed
+
+lemma num_take_canlen_eq: "num (take (canlen zs) zs) = num zs"
+proof (induction "length zs - canlen zs" arbitrary: zs)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc x)
+  let ?m = "canlen zs"
+  have *: "\<forall>i<length zs. i \<ge> ?m \<longrightarrow> zs ! i = \<zero>"
+    using canlen_at_ge by auto
+  have "canlen zs < length zs"
+    using Suc by simp
+  then have "zs ! (length zs - 1) = \<zero>"
+    using Suc canlen_at_ge canlen_le_length
+    by (metis One_nat_def Suc_pred diff_less le_Suc_eq less_nat_zero_code nat_neq_iff zero_less_one)
+  then have "todigit (zs ! (length zs - 1)) = 0"
+    by simp
+  moreover have ys: "zs = take (length zs - 1) zs @ [zs ! (length zs - 1)]"
+      (is "zs = ?ys @ _")
+    by (metis Suc_diff_1 \<open>canlen zs < length zs\<close> append_butlast_last_id butlast_conv_take
+      gr_implies_not0 last_length length_0_conv length_greater_0_conv)
+  ultimately have "num ?ys = num zs"
+    using num_trailing_zero by metis
+  have canlen_ys: "canlen ?ys = canlen zs"
+  proof (rule canlen_eqI)
+    show "\<forall>i<length ?ys. canlen zs \<le> i \<longrightarrow> ?ys ! i = \<zero>"
+      by (simp add: canlen_at_ge)
+    show "\<And>y. \<forall>i<length ?ys. y \<le> i \<longrightarrow> ?ys ! i = \<zero> \<Longrightarrow> canlen zs \<le> y"
+      using * Suc.hyps(2) canlen_le
+      by (smt (verit, del_insts) One_nat_def Suc_pred append_take_drop_id diff_le_self length_take
+        length_upt less_Suc_eq less_nat_zero_code list.size(3) min_absorb2 nth_append upt.simps(2) zero_less_Suc)
+  qed
+  then have "length ?ys - canlen ?ys = x"
+    using ys Suc.hyps(2) by (metis butlast_snoc diff_Suc_1 diff_commute length_butlast)
+  then have "num (take (canlen ?ys) ?ys) = num ?ys"
+    using Suc by blast
+  then have "num (take (canlen zs) ?ys) = num ?ys"
+    using canlen_ys by simp
+  then have "num (take (canlen zs) zs) = num ?ys"
+    by (metis \<open>canlen zs < length zs\<close> butlast_snoc take_butlast ys)
+  then show ?case
+    using \<open>num ?ys = num zs\<close> by presburger
+qed
+
+lemma canrepr_take_canlen:
+  assumes "num zs = n" and "bit_symbols zs"
+  shows "canrepr n = take (canlen zs) zs"
+  using assms canrepr canonical_canrepr canonical_ex1 canonical_take_canlen num_take_canlen_eq
+  by blast
+
+lemma length_canrepr_canlen:
+  assumes "num zs = n" and "bit_symbols zs"
+  shows "nlength n = canlen zs"
+  using canrepr_take_canlen assms canlen_le_length by (metis length_take min_absorb2)
+
+lemma nlength_ge_pow:
+  assumes "nlength n = Suc j"
+  shows "n \<ge> 2 ^ j"
+proof -
+  let ?xs = "canrepr n"
+  have "?xs ! (length ?xs - 1) = \<one>"
+    using canonical_def assms canonical_canrepr
+    by (metis Suc_neq_Zero diff_Suc_1 last_length length_0_conv)
+  moreover have "(\<Sum>i\<leftarrow>[0..<length ?xs]. todigit (?xs ! i) * 2 ^ i) \<ge>
+      todigit (?xs ! (length ?xs - 1)) * 2 ^ (length ?xs - 1)"
+    using assms by simp
+  ultimately have "num ?xs \<ge> 2 ^ (length ?xs - 1)"
+    using num_def by simp
+  moreover have "num ?xs = n"
+    using canrepr by simp
+  ultimately show ?thesis
+    using assms by simp
+qed
+
+lemma nlength_less_pow: "n < 2 ^ (nlength n)"
+proof (induction "nlength n" arbitrary: n)
+  case 0
+  then show ?case
+    by (metis canrepr canrepr_0 length_0_conv nat_zero_less_power_iff)
+next
+  case (Suc j)
+  let ?xs = "canrepr n"
+  have lenxs: "length ?xs = Suc j"
+    using Suc by simp
+  have hdtl: "?xs = hd ?xs # tl ?xs"
+    using Suc by (metis hd_Cons_tl list.size(3) nat.simps(3))
+  have len: "length (tl ?xs) = j"
+    using Suc by simp
+  have can: "canonical (tl ?xs)"
+    using hdtl canonical_canrepr canonical_tl by metis
+  define n' where "n' = num (tl ?xs)"
+  then have "nlength n' = j"
+    using len can canreprI by simp
+  then have n'_less: "n' < 2 ^ j"
+    using Suc by auto
+  have "num ?xs = todigit (hd ?xs) + 2 * num (tl ?xs)"
+    by (metis hdtl num_Cons)
+  then have "n = todigit (hd ?xs) + 2 * num (tl ?xs)"
+    using canrepr by simp
+  also have "... \<le> 1 + 2 * num (tl ?xs)"
+    by simp
+  also have "... = 1 + 2 * n'"
+    using n'_def by simp
+  also have "... \<le> 1 + 2 * (2 ^ j - 1)"
+    using n'_less by simp
+  also have "... = 2 ^ (Suc j) - 1"
+    by (metis (no_types, lifting) add_Suc_right le_add_diff_inverse mult_2 one_le_numeral
+      one_le_power plus_1_eq_Suc sum.op_ivl_Suc sum_power2 zero_order(3))
+  also have "... < 2 ^ (Suc j)"
+    by simp
+  also have "... = 2 ^ (nlength n)"
+    using lenxs by simp
+  finally show ?case .
+qed
+
+lemma pow_nlength:
+  assumes "2 ^ j \<le> n" and "n < 2 ^ (Suc j)"
+  shows "nlength n = Suc j"
+proof (rule ccontr)
+  assume "nlength n \<noteq> Suc j"
+  then have "nlength n < Suc j \<or> nlength n > Suc j"
+    by auto
+  then show False
+  proof
+    assume "nlength n < Suc j"
+    then have "nlength n \<le> j"
+      by simp
+    moreover have "n < 2 ^ (nlength n)"
+      using nlength_less_pow by simp
+    ultimately have "n < 2 ^ j"
+      by (metis le_less_trans nat_power_less_imp_less not_less numeral_2_eq_2 zero_less_Suc)
+    then show False
+      using assms(1) by simp
+  next
+    assume *: "nlength n > Suc j"
+    then have "n \<ge> 2 ^ (nlength n - 1)"
+      using nlength_ge_pow by simp
+    moreover have "nlength n - 1 \<ge> Suc j"
+      using * by simp
+    ultimately have "n \<ge> 2 ^ (Suc j)"
+      by (metis One_nat_def le_less_trans less_2_cases_iff linorder_not_less power_less_imp_less_exp)
+    then show False
+      using assms(2) by simp
+  qed
+qed
+
+lemma nlength_le_n: "nlength n \<le> n"
+proof (cases "n = 0")
+  case True
+  then show ?thesis
+    using canrepr_0 by simp
+next
+  case False
+  then have "nlength n > 0"
+    using nlength_0 by simp
+  moreover from this have "n \<ge> 2 ^ (nlength n - 1)"
+    using nlength_0 nlength_ge_pow by auto
+  ultimately show ?thesis
+    using nlength_ge_pow by (metis Suc_diff_1 Suc_leI dual_order.trans less_exp)
+qed
+
+lemma nlength_Suc_le: "nlength n \<le> nlength (Suc n)"
+proof (cases "n = 0")
+  case True
+  then show ?thesis
+    by (simp add: canrepr_0)
+next
+  case False
+  then obtain j where j: "nlength n = Suc j"
+    by (metis canrepr canrepr_0 gr0_implies_Suc length_greater_0_conv)
+  then have "n \<ge> 2 ^ j"
+    using nlength_ge_pow by simp
+  show ?thesis
+  proof (cases "Suc n \<ge> 2 ^ (Suc j)")
+    case True
+    have "n < 2 ^ (Suc j)"
+      using j nlength_less_pow by metis
+    then have "Suc n < 2 ^ (Suc (Suc j))"
+      by simp
+    then have "nlength (Suc n) = Suc (Suc j)"
+      using True pow_nlength by simp
+    then show ?thesis
+      using j by simp
+  next
+    case False
+    then have "Suc n < 2 ^ (Suc j)"
+      by simp
+    then have "nlength (Suc n) = Suc j"
+      using `n \<ge> 2 ^ j` pow_nlength by simp
+    then show ?thesis
+      using j by simp
+  qed
+qed
+
+lemma nlength_mono:
+  assumes "n1 \<le> n2"
+  shows "nlength n1 \<le> nlength n2"
+proof -
+  have "nlength n \<le> nlength (n + d)" for n d
+  proof (induction d)
+    case 0
+    then show ?case
+      by simp
+  next
+    case (Suc d)
+    then show ?case
+      using nlength_Suc_le by (metis nat_arith.suc1 order_trans)
+  qed
+  then show ?thesis
+    using assms by (metis le_add_diff_inverse)
+qed
+
+lemma nlength_even_le: "n > 0 \<Longrightarrow> nlength (2 * n) = Suc (nlength n)"
+proof -
+  assume "n > 0"
+  then have "nlength n > 0"
+    by (metis canrepr canrepr_0 length_greater_0_conv less_numeral_extra(3))
+  then have "n \<ge> 2 ^ (nlength n - 1)"
+    using Suc_diff_1 nlength_ge_pow by simp
+  then have "2 * n \<ge> 2 ^ (nlength n)"
+    by (metis Suc_diff_1 \<open>0 < nlength n\<close> mult_le_mono2 power_Suc)
+  moreover have "2 * n < 2 ^ (Suc (nlength n))"
+    using nlength_less_pow by simp
+  ultimately show ?thesis
+    using pow_nlength by simp
+qed
+
+lemma nlength_prod: "nlength (n1 * n2) \<le> nlength n1 + nlength n2"
+proof -
+  let ?j1 = "nlength n1" and ?j2 = "nlength n2"
+  have "n1 < 2 ^ ?j1" "n2 < 2 ^ ?j2"
+    using nlength_less_pow by simp_all
+  then have "n1 * n2 < 2 ^ ?j1 * 2 ^ ?j2"
+    by (simp add: mult_strict_mono)
+  then have "n1 * n2 < 2 ^ (?j1 + ?j2)"
+    by (simp add: power_add)
+  then have "n1 * n2 \<le> 2 ^ (?j1 + ?j2) - 1"
+    by simp
+  then have "nlength (n1 * n2) \<le> nlength (2 ^ (?j1 + ?j2) - 1)"
+    using nlength_mono by simp
+  then show "nlength (n1 * n2) \<le> ?j1 + ?j2"
+    using nlength_pow_minus_1 by simp
+qed
+
+text \<open>
+In the following lemma @{const Suc} is needed because $n^0 = 1$.
+\<close>
+
+lemma nlength_pow: "nlength (n ^ d) \<le> Suc (d * nlength n)"
+proof (induction d)
+  case 0
+  then show ?case
+    by (metis less_or_eq_imp_le mult_not_zero nat_power_eq_Suc_0_iff nlength_pow2)
+next
+  case (Suc d)
+  have "nlength (n ^ Suc d) = nlength (n ^ d * n)"
+    by (simp add: mult.commute)
+  then have "nlength (n ^ Suc d) \<le> nlength (n ^ d) + nlength n"
+    using nlength_prod by simp
+  then show ?case
+    using Suc by simp
+qed
+
+lemma nlength_sum: "nlength (n1 + n2) \<le> Suc (max (nlength n1) (nlength n2))"
+proof -
+  let ?m = "max n1 n2"
+  have "n1 + n2 \<le> 2 * ?m"
+    by simp
+  then have "nlength (n1 + n2) \<le> nlength (2 * ?m)"
+    using nlength_mono by simp
+  moreover have "nlength ?m = max (nlength n1) (nlength n2)"
+    using nlength_mono by (metis max.absorb1 max.cobounded2 max_def)
+  ultimately show ?thesis
+    using nlength_even_le
+    by (metis canrepr_0 le_SucI le_zero_eq list.size(3) max_nat.neutr_eq_iff not_gr_zero zero_eq_add_iff_both_eq_0)
+qed
+
+lemma nlength_Suc: "nlength (Suc n) \<le> Suc (nlength n)"
+  using nlength_sum nlength_1_simp
+  by (metis One_nat_def Suc_leI add_Suc diff_Suc_1 length_greater_0_conv max.absorb_iff2
+    max.commute max_def nlength_0 plus_1_eq_Suc)
+
+lemma nlength_less_n: "n \<ge> 3 \<Longrightarrow> nlength n < n"
+proof (induction n rule: nat_induct_at_least)
+  case base
+  then show ?case
+    by (simp add: nlength_3)
+next
+  case (Suc n)
+  then show ?case
+    using nlength_Suc by (metis Suc_le_eq le_neq_implies_less nlength_le_n not_less_eq)
+qed
+
+
+subsubsection \<open>Comparing two numbers\<close>
+
+text \<open>
+In order to compare two numbers in canonical representation, we can use the
+Turing machine @{const tm_equals}, which works for arbitrary proper symbol
+sequences.
+
+\null
+\<close>
+
+lemma min_nlength: "min (nlength n1) (nlength n2) = nlength (min n1 n2)"
+  by (metis min_absorb2 min_def nat_le_linear nlength_mono)
+
+lemma max_nlength: "max (nlength n1) (nlength n2) = nlength (max n1 n2)"
+  using nlength_mono by (metis max.absorb1 max.cobounded2 max_def)
+
+lemma contents_blank_0: "\<lfloor>[\<box>]\<rfloor> = \<lfloor>[]\<rfloor>"
+  using contents_def by auto
+
+definition tm_equalsn :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_equalsn \<equiv> tm_equals"
+
+lemma tm_equalsn_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j3"
+  shows "turing_machine k G (tm_equalsn j1 j2 j3)"
+  unfolding tm_equalsn_def using assms tm_equals_tm by simp
+
+lemma transforms_tm_equalsnI [transforms_intros]:
+  fixes j1 j2 j3 :: tapeidx
+  fixes tps tps' :: "tape list" and k b n1 n2 :: nat
+  assumes "length tps = k" "j1 \<noteq> j2" "j2 \<noteq> j3" "j1 \<noteq> j3" "j1 < k" "j2 < k" "j3 < k"
+    and "b \<le> 1"
+  assumes
+    "tps ! j1 = (\<lfloor>n1\<rfloor>\<^sub>N, 1)"
+    "tps ! j2 = (\<lfloor>n2\<rfloor>\<^sub>N, 1)"
+    "tps ! j3 = (\<lfloor>b\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = (3 * nlength (min n1 n2) + 7)"
+  assumes "tps' = tps
+    [j3 := (\<lfloor>if n1 = n2 then 1 else 0\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_equalsn j1 j2 j3) tps ttt tps'"
+  unfolding tm_equalsn_def
+proof (tform tps: assms)
+  show "proper_symbols (canrepr n1)"
+    using proper_symbols_canrepr by simp
+  show "proper_symbols (canrepr n2)"
+    using proper_symbols_canrepr by simp
+  show "ttt = 3 * min (nlength n1) (nlength n2) + 7"
+    using assms(12) min_nlength by simp
+  let ?v = "if canrepr n1 = canrepr n2 then 3::nat else 0::nat"
+  have "b = 0 \<or> b = 1"
+    using assms(8) by auto
+  then have "\<lfloor>b\<rfloor>\<^sub>N = \<lfloor>[]\<rfloor> \<or> \<lfloor>b\<rfloor>\<^sub>N = \<lfloor>[\<one>]\<rfloor>"
+    using canrepr_0 canrepr_1 by auto
+  then have "tps ! j3 = (\<lfloor>[]\<rfloor>, 1) \<or> tps ! j3 = (\<lfloor>[\<one>]\<rfloor>, 1)"
+    using assms(11) by simp
+  then have v: "tps ! j3 |:=| ?v = (\<lfloor>[?v]\<rfloor>, 1)"
+    using contents_def by auto
+  show "tps' = tps[j3 := tps ! j3 |:=| ?v]"
+  proof (cases "n1 = n2")
+    case True
+    then show ?thesis
+      using canrepr_1 v assms(13) by auto
+  next
+    case False
+    then have "?v = 0"
+      by (metis canrepr)
+    then show ?thesis
+      using canrepr_0 v assms(13) contents_blank_0 by auto
+  qed
+qed
+
+
+subsubsection \<open>Copying a number between tapes\<close>
+
+text \<open>
+The next Turing machine overwrites the contents of tape $j_2$ with the contents
+of tape $j_1$ and performs a carriage return on both tapes.
+\<close>
+
+definition tm_copyn :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_copyn j1 j2 \<equiv>
+     tm_erase_cr j2 ;;
+     tm_cp_until j1 j2 {\<box>} ;;
+     tm_cr j1 ;;
+     tm_cr j2"
+
+lemma tm_copyn_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "j1 < k" "j2 < k" "j1 \<noteq> j2" "0 < j2"
+  shows "turing_machine k G (tm_copyn j1 j2)"
+  unfolding tm_copyn_def using assms tm_cp_until_tm tm_cr_tm tm_erase_cr_tm by simp
+
+locale turing_machine_move =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_erase_cr j2"
+definition "tm2 \<equiv> tm1 ;; tm_cp_until j1 j2 {\<box>}"
+definition "tm3 \<equiv> tm2 ;; tm_cr j1"
+definition "tm4 \<equiv> tm3 ;; tm_cr j2"
+
+lemma tm4_eq_tm_copyn: "tm4 = tm_copyn j1 j2"
+  unfolding tm4_def tm3_def tm2_def tm1_def tm_copyn_def by simp
+
+context
+  fixes x y :: nat and tps0 :: "tape list"
+  assumes j_less [simp]: "j1 < length tps0" "j2 < length tps0"
+  assumes j [simp]: "j1 \<noteq> j2"
+    and tps_j1 [simp]: "tps0 ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    and tps_j2 [simp]: "tps0 ! j2 = (\<lfloor>y\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j2 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "t = 7 + 2 * nlength y"
+  shows "transforms tm1 tps0 t tps1"
+  unfolding tm1_def
+proof (tform tps: tps1_def time: assms)
+  show "proper_symbols (canrepr y)"
+    using proper_symbols_canrepr by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j1 := (\<lfloor>x\<rfloor>\<^sub>N, Suc (nlength x)),
+   j2 := (\<lfloor>x\<rfloor>\<^sub>N, Suc (nlength x))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "t = 8 + (2 * nlength y + nlength x)"
+  shows "transforms tm2 tps0 t tps2"
+  unfolding tm2_def
+proof (tform tps: tps1_def time: assms)
+  show "rneigh (tps1 ! j1) {\<box>} (nlength x)"
+  proof (rule rneighI)
+    show "(tps1 ::: j1) (tps1 :#: j1 + nlength x) \<in> {\<box>}"
+      using tps1_def canrepr_0 contents_outofbounds j(1) nlength_0_simp tps_j1
+      by (metis fst_eqD lessI nth_list_update_neq plus_1_eq_Suc singleton_iff snd_eqD)
+    show "\<And>n'. n' < nlength x \<Longrightarrow> (tps1 ::: j1) (tps1 :#: j1 + n') \<notin> {\<box>}"
+      using tps1_def tps_j1 j j_less contents_inbounds proper_symbols_canrepr
+      by (metis Suc_leI add_diff_cancel_left' fst_eqD not_add_less2 nth_list_update_neq
+        plus_1_eq_Suc singletonD snd_eqD zero_less_Suc)
+  qed
+
+  have "(\<lfloor>x\<rfloor>\<^sub>N, Suc (nlength x)) = tps0[j2 := (\<lfloor>[]\<rfloor>, 1)] ! j1 |+| nlength x"
+    using tps_j1 tps_j2 by (metis fst_eqD j(1) j_less(2) nth_list_update plus_1_eq_Suc snd_eqD)
+  moreover have "(\<lfloor>x\<rfloor>\<^sub>N, Suc (nlength x)) =
+      implant (tps0[j2 := (\<lfloor>[]\<rfloor>, 1)] ! j1) (tps0[j2 := (\<lfloor>[]\<rfloor>, 1)] ! j2) (nlength x)"
+    using tps_j1 tps_j2 j j_less implant_contents nlength_0_simp
+    by (metis add.right_neutral append.simps(1) canrepr_0 diff_Suc_1 drop0 le_eq_less_or_eq
+     nth_list_update_eq nth_list_update_neq plus_1_eq_Suc take_all zero_less_one)
+  ultimately show "tps2 = tps1
+    [j1 := tps1 ! j1 |+| nlength x,
+     j2 := implant (tps1 ! j1) (tps1 ! j2) (nlength x)]"
+    unfolding tps2_def tps1_def by (simp add: list_update_swap[of j1])
+qed
+
+definition "tps3 \<equiv> tps0[j2 := (\<lfloor>x\<rfloor>\<^sub>N, Suc (nlength x))]"
+
+lemma tm3 [transforms_intros]:
+  assumes "t = 11 + (2 * nlength y + 2 * nlength x)"
+  shows "transforms tm3 tps0 t tps3"
+  unfolding tm3_def
+proof (tform tps: tps2_def)
+  have "tps2 :#: j1 = Suc (nlength x)"
+    using assms tps2_def by (metis j(1) j_less(1) nth_list_update_eq nth_list_update_neq snd_conv)
+  then show "t = 8 + (2 * nlength y + nlength x) + (tps2 :#: j1 + 2)"
+    using assms by simp
+  show "clean_tape (tps2 ! j1)"
+    using tps2_def by (simp add: clean_tape_ncontents nth_list_update_neq')
+  have "tps2 ! j1 |#=| 1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    using tps2_def by (simp add: nth_list_update_neq')
+  then show "tps3 = tps2[j1 := tps2 ! j1 |#=| 1]"
+    using tps3_def tps2_def by (metis j(1) list_update_id list_update_overwrite list_update_swap tps_j1)
+qed
+
+definition "tps4 \<equiv> tps0[j2 := (\<lfloor>x\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4:
+  assumes "t = 14 + (3 * nlength x + 2 * nlength y)"
+  shows "transforms tm4 tps0 t tps4"
+  unfolding tm4_def
+proof (tform tps: tps3_def time: tps3_def assms)
+  show "clean_tape (tps3 ! j2)"
+    using tps3_def clean_tape_ncontents by simp
+  have "tps3 ! j2 |#=| 1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    using tps3_def by (simp add: nth_list_update_neq')
+  then show "tps4 = tps3[j2 := tps3 ! j2 |#=| 1]"
+    using tps4_def tps3_def by (metis list_update_overwrite tps_j1)
+qed
+
+lemma tm4':
+  assumes "t = 14 + 3 * (nlength x + nlength y)"
+  shows "transforms tm4 tps0 t tps4"
+  using tm4 transforms_monotone assms by simp
+
+end
+
+end  (* locale turing_machine_move *)
+
+lemma transforms_tm_copynI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and k x y :: nat
+  assumes "j1 \<noteq> j2" "j1 < length tps" "j2 < length tps"
+  assumes
+    "tps ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps ! j2 = (\<lfloor>y\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 14 + 3 * (nlength x + nlength y)"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>x\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_copyn j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_move j1 j2 .
+  show ?thesis
+    using assms loc.tm4' loc.tps4_def loc.tm4_eq_tm_copyn by simp
+qed
+
+
+subsubsection \<open>Setting the tape contents to a number\<close>
+
+text \<open>
+The Turing machine in this section writes a hard-coded number to a tape.
+\<close>
+
+definition tm_setn :: "tapeidx \<Rightarrow> nat \<Rightarrow> machine" where
+  "tm_setn j n \<equiv> tm_set j (canrepr n)"
+
+lemma tm_setn_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "j < k" and "0 < j "
+  shows "turing_machine k G (tm_setn j n)"
+proof -
+  have "symbols_lt G (canrepr n)"
+    using assms(2) bit_symbols_canrepr by fastforce
+  then show ?thesis
+    unfolding tm_setn_def using tm_set_tm assms by simp
+qed
+
+lemma transforms_tm_setnI [transforms_intros]:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and x k n :: nat
+  assumes "j < length tps"
+  assumes "tps ! j = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+  assumes "t = 10 + 2 * nlength x + 2 * nlength n"
+  assumes "tps' = tps[j := (\<lfloor>n\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_setn j n) tps t tps'"
+  unfolding tm_setn_def
+  using transforms_tm_setI[OF assms(1), of "canrepr x" "canrepr n" t tps'] assms
+    canonical_canrepr canonical_def contents_clean_tape'
+  by (simp add: eval_nat_numeral(3) numeral_Bit0 proper_symbols_canrepr)
+
+
+subsection \<open>Incrementing\<close>
+
+text \<open>
+In this section we devise a Turing machine that increments a number. The next
+function describes how the symbol sequence of the incremented number looks like.
+Basically one has to flip all @{text \<one>} symbols starting at the least
+significant digit until one reaches a @{text \<zero>}, which is then replaced by a
+@{text \<one>}.  If there is no @{text \<zero>}, a @{text \<one>} is appended. Here we
+exploit that the most significant digit is to the right.
+\<close>
+
+definition nincr :: "symbol list \<Rightarrow> symbol list" where
+  "nincr zs \<equiv>
+     if \<exists>i<length zs. zs ! i = \<zero>
+     then replicate (LEAST i. i < length zs \<and> zs ! i = \<zero>) \<zero> @ [\<one>] @ drop (Suc (LEAST i. i < length zs \<and> zs ! i = \<zero>)) zs
+     else replicate (length zs) \<zero> @ [\<one>]"
+
+lemma canonical_nincr:
+  assumes "canonical zs"
+  shows "canonical (nincr zs)"
+proof -
+  have 1: "bit_symbols zs"
+    using canonical_def assms by simp
+  let ?j = "LEAST i. i < length zs \<and> zs ! i = \<zero>"
+  have "bit_symbols (nincr zs)"
+  proof (cases "\<exists>i<length zs. zs ! i = \<zero>")
+    case True
+    then have "nincr zs = replicate ?j \<zero> @ [\<one>] @ drop (Suc ?j) zs"
+      using nincr_def by simp
+    moreover have "bit_symbols (replicate ?j \<zero>)"
+      by simp
+    moreover have "bit_symbols [\<one>]"
+      by simp
+    moreover have "bit_symbols (drop (Suc ?j) zs)"
+      using 1 by simp
+    ultimately show ?thesis
+      using bit_symbols_append by presburger
+  next
+    case False
+    then show ?thesis
+      using nincr_def bit_symbols_append by auto
+  qed
+  moreover have "last (nincr zs) = \<one>"
+  proof (cases "\<exists>i<length zs. zs ! i = \<zero>")
+    case True
+    then show ?thesis
+      using nincr_def assms canonical_def by auto
+  next
+    case False
+    then show ?thesis
+      using nincr_def by auto
+  qed
+  ultimately show ?thesis
+    using canonical_def by simp
+qed
+
+lemma nincr:
+  assumes "bit_symbols zs"
+  shows "num (nincr zs) = Suc (num zs)"
+proof (cases "\<exists>i<length zs. zs ! i = \<zero>")
+  case True
+  define j where "j = (LEAST i. i < length zs \<and> zs ! i = \<zero>)"
+  then have 1: "j < length zs \<and> zs ! j = \<zero>"
+    using LeastI_ex[OF True] by simp
+  have 2: "zs ! i = \<one>" if "i < j" for i
+    using that True j_def assms "1" less_trans not_less_Least by blast
+
+  define xs :: "symbol list" where "xs = replicate j \<one> @ [\<zero>]"
+  define ys :: "symbol list" where "ys = drop (Suc j) zs"
+  have "zs = xs @ ys"
+  proof -
+    have "xs = take (Suc j) zs"
+      using xs_def 1 2
+      by (smt (verit, best) le_eq_less_or_eq length_replicate length_take min_absorb2 nth_equalityI
+       nth_replicate nth_take take_Suc_conv_app_nth)
+    then show ?thesis
+      using ys_def by simp
+  qed
+
+  have "nincr zs = replicate j \<zero> @ [\<one>] @ drop (Suc j) zs"
+    using nincr_def True j_def by simp
+  then have "num (nincr zs) = num (replicate j \<zero> @ [\<one>] @ ys)"
+    using ys_def by simp
+  also have "... = num (replicate j \<zero> @ [\<one>]) + 2 ^ Suc j * num ys"
+    using num_append by (metis append_assoc length_append_singleton length_replicate)
+  also have "... = Suc (num xs) + 2 ^ Suc j * num ys"
+  proof -
+    have "num (replicate j \<zero> @ [\<one>]) = 2 ^ j"
+      using num_replicate2_eq_pow by simp
+    also have "... = Suc (2 ^ j - 1)"
+      by simp
+    also have "... = Suc (num (replicate j \<one>))"
+      using num_replicate3_eq_pow_minus_1 by simp
+    also have "... = Suc (num (replicate j \<one> @ [\<zero>]))"
+      using num_trailing_zero by simp
+    finally have "num (replicate j \<zero> @ [\<one>]) = Suc (num xs)"
+      using xs_def by simp
+    then show ?thesis
+      by simp
+  qed
+  also have "... = Suc (num xs + 2 ^ Suc j * num ys)"
+    by simp
+  also have "... = Suc (num zs)"
+    using `zs = xs @ ys` num_append xs_def by (metis length_append_singleton length_replicate)
+  finally show ?thesis .
+next
+  case False
+  then have "\<forall>i<length zs. zs ! i = \<one>"
+    using assms by simp
+  then have zs: "zs = replicate (length zs) \<one>"
+    by (simp add: nth_equalityI)
+  then have num_zs: "num zs = 2 ^ length zs - 1"
+    by (metis num_replicate3_eq_pow_minus_1)
+  have "nincr zs = replicate (length zs) \<zero> @ [\<one>]"
+    using nincr_def False by auto
+  then have "num (nincr zs) = 2 ^ length zs"
+    by (simp add: num_replicate2_eq_pow)
+  then show ?thesis
+    using num_zs by simp
+qed
+
+lemma nincr_canrepr: "nincr (canrepr n) = canrepr (Suc n)"
+  using canrepr canonical_canrepr canreprI bit_symbols_canrepr canonical_nincr nincr
+  by metis
+
+text \<open>
+The next Turing machine performs the incrementing. Starting from the left of the
+symbol sequence on tape $j$, it writes the symbol \textbf{0} until it reaches a
+blank or the symbol \textbf{1}. Then it writes a \textbf{1} and returns the tape
+head to the beginning.
+\<close>
+
+definition tm_incr :: "tapeidx \<Rightarrow> machine" where
+  "tm_incr j \<equiv> tm_const_until j j {\<box>, \<zero>} \<zero> ;; tm_write j \<one> ;; tm_cr j"
+
+lemma tm_incr_tm:
+  assumes "G \<ge> 4" and "k \<ge> 2" and "j < k" and "j > 0"
+  shows "turing_machine k G (tm_incr j)"
+  unfolding tm_incr_def using assms tm_const_until_tm tm_write_tm tm_cr_tm by simp
+
+locale turing_machine_incr =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_const_until j j {\<box>, \<zero>} \<zero>"
+definition "tm2 \<equiv> tm1 ;; tm_write j \<one>"
+definition "tm3 \<equiv> tm2 ;; tm_cr j"
+
+lemma tm3_eq_tm_incr: "tm3 = tm_incr j"
+  unfolding tm3_def tm2_def tm1_def tm_incr_def by simp
+
+context
+  fixes x k :: nat and tps :: "tape list"
+  assumes jk [simp]: "j < k" "length tps = k"
+    and tps0 [simp]: "tps ! j = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+begin
+
+lemma tm1 [transforms_intros]:
+  assumes "i0 = (LEAST i. i \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i) \<in> {\<box>, \<zero>})"
+    and "tps' = tps[j := constplant (tps ! j) \<zero> i0]"
+  shows "transforms tm1 tps (Suc i0) tps'"
+  unfolding tm1_def
+proof (tform tps: assms(2))
+  let ?P = "\<lambda>i. i \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i) \<in> {\<box>, \<zero>}"
+  have 2: "i0 \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i0) \<in> {\<box>, \<zero>}"
+    using LeastI[of ?P "nlength x"] jk(1) assms(1) by simp
+  have 3: "\<not> ?P i" if "i < i0" for i
+    using not_less_Least[of i ?P] jk(1) assms(1) that by simp
+  show "rneigh (tps ! j) {\<box>, \<zero>} i0"
+  proof (rule rneighI)
+    show "(tps ::: j) (tps :#: j + i0) \<in> {\<box>, \<zero>}"
+      using tps0 2 jk(1) assms(1) by simp
+    show "\<And>n'. n' < i0 \<Longrightarrow> (tps ::: j) (tps :#: j + n') \<notin> {\<box>, \<zero>}"
+      using tps0 2 3 jk(1) assms(1) by simp
+  qed
+qed
+
+lemma tm2 [transforms_intros]:
+  assumes "i0 = (LEAST i. i \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i) \<in> {\<box>, \<zero>})"
+    and "ttt = Suc (Suc i0)"
+    and "tps' = tps[j := (\<lfloor>Suc x\<rfloor>\<^sub>N, Suc i0)]"
+  shows "transforms tm2 tps ttt tps'"
+  unfolding tm2_def
+proof (tform tps: assms(1,3) time: assms(1,2))
+  let ?P = "\<lambda>i. i \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i) \<in> {\<box>, \<zero>}"
+  have 1: "?P (nlength x)"
+    by simp
+  have 2: "i0 \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i0) \<in> {\<box>, \<zero>}"
+    using LeastI[of ?P "nlength x"] assms(1) by simp
+  have 3: "\<not> ?P i" if "i < i0" for i
+    using not_less_Least[of i ?P] assms(1) that by simp
+  let ?i = "LEAST i. i \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i) \<in> {\<box>, \<zero>}"
+  show "tps' = tps
+    [j := constplant (tps ! j) 2 ?i,
+     j := tps[j := constplant (tps ! j) \<zero> ?i] ! j |:=| \<one>]"
+     (is "tps' = ?rhs")
+  proof -
+    have "?rhs = tps [j := constplant (\<lfloor>x\<rfloor>\<^sub>N, Suc 0) \<zero> i0 |:=| \<one>]"
+      using jk assms(1) by simp
+    moreover have "(\<lfloor>Suc x\<rfloor>\<^sub>N, Suc i0) = constplant (\<lfloor>x\<rfloor>\<^sub>N, Suc 0) 2 i0 |:=| \<one>"
+      (is "?l = ?r")
+    proof -
+      have "snd ?l = snd ?r"
+        by (simp add: transplant_def)
+      moreover have "\<lfloor>Suc x\<rfloor>\<^sub>N = fst ?r"
+      proof -
+        let ?zs = "canrepr x"
+        have l: "\<lfloor>Suc x\<rfloor>\<^sub>N = \<lfloor>nincr ?zs\<rfloor>"
+          by (simp add: nincr_canrepr)
+        have r: "fst ?r = (\<lambda>i. if Suc 0 \<le> i \<and> i < Suc i0 then \<zero> else \<lfloor>x\<rfloor>\<^sub>N i)(Suc i0 := \<one>)"
+          using constplant by auto
+        show ?thesis
+        proof (cases "\<exists>i<length ?zs. ?zs ! i = \<zero>")
+          case True
+          let ?Q = "\<lambda>i. i < length ?zs \<and> ?zs ! i = \<zero>"
+          have Q1: "?Q (Least ?Q)"
+            using True by (metis (mono_tags, lifting) LeastI_ex)
+          have Q2: "\<not> ?Q i" if "i < Least ?Q" for i
+            using True not_less_Least that by blast
+          have "Least ?P = Least ?Q"
+          proof (rule Least_equality)
+            show "Least ?Q \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc (Least ?Q)) \<in> {\<box>, \<zero>}"
+            proof
+              show "Least ?Q \<le> nlength x"
+                using True by (metis (mono_tags, lifting) LeastI_ex less_imp_le)
+              show "\<lfloor>x\<rfloor>\<^sub>N (Suc (Least ?Q)) \<in> {\<box>, \<zero>}"
+                using True by (simp add: Q1 Suc_leI)
+            qed
+            then show "\<And>y. y \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc y) \<in> {\<box>, \<zero>} \<Longrightarrow> (Least ?Q) \<le> y"
+              using True Q1 Q2 bit_symbols_canrepr contents_def
+              by (smt (z3) Least_le Suc_leI bot_nat_0.not_eq_extremum diff_Suc_1 insert_iff le_neq_implies_less
+                nat.simps(3) nlength_0_simp nlength_le_n nlength_less_n singletonD)
+          qed
+          then have i0: "i0 = Least ?Q"
+            using assms(1) by simp
+          then have nincr_zs: "nincr ?zs = replicate i0 \<zero> @ [\<one>] @ drop (Suc i0) ?zs"
+            using nincr_def True by simp
+          show ?thesis
+          proof
+            fix i
+            consider
+               "i = 0"
+             | "Suc 0 \<le> i \<and> i < Suc i0"
+             | "i = Suc i0"
+             | "i > Suc i0 \<and> i \<le> length ?zs"
+             | "i > Suc i0 \<and> i > length ?zs"
+              by linarith
+            then have "\<lfloor>replicate i0 \<zero> @ [\<one>] @ drop (Suc i0) ?zs\<rfloor> i =
+                ((\<lambda>i. if Suc 0 \<le> i \<and> i < Suc i0 then \<zero> else \<lfloor>x\<rfloor>\<^sub>N i)(Suc i0 := \<one>)) i"
+                (is "?A i = ?B i")
+            proof (cases)
+              case 1
+              then show ?thesis
+                by (simp add: transplant_def)
+            next
+              case 2
+              then have "i - 1 < i0"
+                by auto
+              then have "(replicate i0 \<zero> @ [\<one>] @ drop (Suc i0) ?zs) ! (i - 1) = \<zero>"
+                by (metis length_replicate nth_append nth_replicate)
+              then have "?A i = \<zero>"
+                using contents_def i0 "2" Q1 nincr_canrepr nincr_zs
+                by (metis Suc_le_lessD le_trans less_Suc_eq_le less_imp_le_nat less_numeral_extra(3) nlength_Suc_le)
+              moreover have "?B i = \<zero>"
+                using i0 2 by simp
+              ultimately show ?thesis
+                by simp
+            next
+              case 3
+              then show ?thesis
+                using i0 Q1 canrepr_0 contents_inbounds nincr_canrepr nincr_zs nlength_0_simp nlength_Suc nlength_Suc_le
+                by (smt (z3) Suc_leI append_Cons diff_Suc_1 fun_upd_apply le_trans length_replicate
+                  nth_append_length zero_less_Suc)
+            next
+              case 4
+              then have "?A i = (replicate i0 \<zero> @ [\<one>] @ drop (Suc i0) ?zs) ! (i - 1)"
+                by auto
+              then have "?A i = ((replicate i0 \<zero> @ [\<one>]) @ drop (Suc i0) ?zs) ! (i - 1)"
+                by simp
+              moreover have "length (replicate i0 \<zero> @ [\<one>]) = Suc i0"
+                by simp
+              moreover have "i - 1 < length ?zs"
+                using 4 by auto
+              moreover have "i - 1 >= Suc i0"
+                using 4 by auto
+              ultimately have "?A i = ?zs ! (i - 1)"
+                using i0 Q1
+                by (metis (no_types, lifting) Suc_leI append_take_drop_id length_take min_absorb2 not_le nth_append)
+              moreover have "?B i = \<lfloor>x\<rfloor>\<^sub>N i"
+                using 4 by simp
+              ultimately show ?thesis
+                using i0 4 contents_def by simp
+            next
+              case 5
+              then show ?thesis
+                by auto
+            qed
+            then show "\<lfloor>Suc x\<rfloor>\<^sub>N i = fst (constplant (\<lfloor>x\<rfloor>\<^sub>N, Suc 0) \<zero> i0 |:=| \<one>) i"
+              using nincr_zs l r by simp
+          qed
+        next
+          case False
+          then have nincr_zs: "nincr ?zs = replicate (length ?zs) \<zero> @ [\<one>]"
+            using nincr_def by auto
+          have "Least ?P = length ?zs"
+          proof (rule Least_equality)
+            show "nlength x \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc (nlength x)) \<in> {\<box>, \<zero>}"
+              by simp
+            show "\<And>y. y \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc y) \<in> {\<box>, \<zero>} \<Longrightarrow> nlength x \<le> y"
+              using False contents_def bit_symbols_canrepr
+              by (metis diff_Suc_1 insert_iff le_neq_implies_less nat.simps(3) not_less_eq_eq numeral_3_eq_3 singletonD)
+          qed
+          then have i0: "i0 = length ?zs"
+            using assms(1) by simp
+          show ?thesis
+          proof
+            fix i
+            consider "i = 0" | "Suc 0 \<le> i \<and> i < Suc (length ?zs)" | "i = Suc (length ?zs)" | "i > Suc (length ?zs)"
+              by linarith
+            then have "\<lfloor>replicate (length ?zs) \<zero> @ [\<one>]\<rfloor> i =
+                ((\<lambda>i. if Suc 0 \<le> i \<and> i < Suc i0 then \<zero> else \<lfloor>x\<rfloor>\<^sub>N i)(Suc i0 := \<one>)) i"
+                (is "?A i = ?B i")
+            proof (cases)
+              case 1
+              then show ?thesis
+                by (simp add: transplant_def)
+            next
+              case 2
+              then have "?A i = \<zero>"
+                by (metis One_nat_def Suc_le_lessD add.commute contents_def diff_Suc_1 length_Cons length_append
+                  length_replicate less_Suc_eq_0_disj less_imp_le_nat less_numeral_extra(3) list.size(3) nth_append
+                   nth_replicate plus_1_eq_Suc)
+              moreover have "?B i = \<zero>"
+                using i0 2 by simp
+              ultimately show ?thesis
+                by simp
+            next
+              case 3
+              then show ?thesis
+                using i0 canrepr_0 contents_inbounds nincr_canrepr nincr_zs nlength_0_simp nlength_Suc
+                by (metis One_nat_def add.commute diff_Suc_1 fun_upd_apply length_Cons length_append
+                  length_replicate nth_append_length plus_1_eq_Suc zero_less_Suc)
+            next
+              case 4
+              then show ?thesis
+                using i0 by simp
+            qed
+            then show "\<lfloor>Suc x\<rfloor>\<^sub>N i = fst (constplant (\<lfloor>x\<rfloor>\<^sub>N, Suc 0) \<zero> i0 |:=| \<one>) i"
+              using nincr_zs l r by simp
+          qed
+        qed
+      qed
+      ultimately show ?thesis
+        by simp
+    qed
+    ultimately show ?thesis
+      using assms(3) by simp
+  qed
+qed
+
+lemma tm3:
+  assumes "i0 = (LEAST i. i \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i) \<in> {\<box>, \<zero>})"
+    and "ttt = 5 + 2 * i0"
+    and "tps' = tps[j := (\<lfloor>Suc x\<rfloor>\<^sub>N, Suc 0)]"
+  shows "transforms tm3 tps ttt tps'"
+  unfolding tm3_def
+proof (tform tps: assms(1,3) time: assms(1,2))
+  let ?tps = "tps[j := (\<lfloor>Suc x\<rfloor>\<^sub>N, Suc (LEAST i. i \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i) \<in> {\<box>, \<zero>}))]"
+  show "clean_tape (?tps ! j)"
+    using clean_tape_ncontents by (simp add: assms(1,3))
+qed
+
+lemma tm3':
+  assumes "ttt = 5 + 2 * nlength x"
+    and "tps' = tps[j := (\<lfloor>Suc x\<rfloor>\<^sub>N, Suc 0)]"
+  shows "transforms tm3 tps ttt tps'"
+proof -
+  let ?P = "\<lambda>i. i \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i) \<in> {\<box>, \<zero>}"
+  define i0 where "i0 = Least ?P"
+  have "i0 \<le> nlength x \<and> \<lfloor>x\<rfloor>\<^sub>N (Suc i0) \<in> {\<box>, \<zero>}"
+    using LeastI[of ?P "nlength x"] i0_def by simp
+  then have "5 + 2 * i0 \<le> 5 + 2 * nlength x"
+    by simp
+  moreover have "transforms tm3 tps (5 + 2 * i0) tps'"
+    using assms tm3 i0_def by simp
+  ultimately show ?thesis
+    using transforms_monotone assms(1) by simp
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_incrI [transforms_intros]:
+  assumes "j < k"
+    and "length tps = k"
+    and "tps ! j = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    and "ttt = 5 + 2 * nlength x"
+    and "tps' = tps[j := (\<lfloor>Suc x\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_incr j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_incr j .
+  show ?thesis
+    using assms loc.tm3' loc.tm3_eq_tm_incr by simp
+qed
+
+
+subsubsection \<open>Incrementing multiple times\<close>
+
+text \<open>
+Adding a constant by iteratively incrementing is not exactly efficient, but it
+still only takes constant time and thus does not endanger any time bounds.
+\<close>
+
+fun tm_plus_const :: "nat \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_plus_const 0 j = []" |
+  "tm_plus_const (Suc c) j = tm_plus_const c j ;; tm_incr j"
+
+lemma tm_plus_const_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j" and "j < k"
+  shows "turing_machine k G (tm_plus_const c j)"
+  using assms Nil_tm tm_incr_tm by (induction c) simp_all
+
+lemma transforms_tm_plus_constI [transforms_intros]:
+  fixes c :: nat
+  assumes "j < k"
+    and "j > 0"
+    and "length tps = k"
+    and "tps ! j = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    and "ttt = c * (5 + 2 * nlength (x + c))"
+    and "tps' = tps[j := (\<lfloor>x + c\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_plus_const c j) tps ttt tps'"
+  using assms(5,6,4)
+proof (induction c arbitrary: ttt tps')
+  case 0
+  then show ?case
+    using transforms_Nil assms
+    by (metis add_cancel_left_right list_update_id mult_eq_0_iff tm_plus_const.simps(1))
+next
+  case (Suc c)
+  define tpsA where "tpsA = tps[j := (\<lfloor>x + c\<rfloor>\<^sub>N, 1)]"
+  let ?ttt = "c * (5 + 2 * nlength (x + c)) + (5 + 2 * nlength (x + c))"
+  have "transforms (tm_plus_const c j ;; tm_incr j) tps ?ttt tps'"
+  proof (tform tps: assms)
+    show "transforms (tm_plus_const c j) tps (c * (5 + 2 * nlength (x + c))) tpsA"
+      using tpsA_def assms Suc by simp
+    show "j < length tpsA"
+      using tpsA_def assms(1,3) by simp
+    show "tpsA ! j = (\<lfloor>x + c\<rfloor>\<^sub>N, 1)"
+      using tpsA_def assms(1,3) by simp
+    show "tps' = tpsA[j := (\<lfloor>Suc (x + c)\<rfloor>\<^sub>N, 1)]"
+      using tpsA_def assms Suc by (metis add_Suc_right list_update_overwrite)
+  qed
+  moreover have "?ttt \<le> ttt"
+  proof -
+    have "?ttt = Suc c * (5 + 2 * nlength (x + c))"
+      by simp
+    also have "... \<le> Suc c * (5 + 2 * nlength (x + Suc c))"
+      using nlength_mono Suc_mult_le_cancel1 by auto
+    finally show "?ttt \<le> ttt"
+      using Suc by simp
+  qed
+  ultimately have "transforms (tm_plus_const c j ;; tm_incr j) tps ttt tps'"
+    using transforms_monotone by simp
+  then show ?case
+    by simp
+qed
+
+
+subsection \<open>Decrementing\<close>
+
+text \<open>
+Decrementing a number is almost like incrementing but with the symbols
+\textbf{0} and \textbf{1} swapped. One difference is that in order to get a
+canonical symbol sequence, a trailing zero must be removed, whereas incrementing
+cannot result in a trailing zero. Another difference is that decrementing the
+number zero yields zero.
+
+The next function returns the leftmost symbol~\textbf{1}, that is, the one
+that needs to be flipped.
+\<close>
+
+definition first1 :: "symbol list \<Rightarrow> nat" where
+  "first1 zs \<equiv> LEAST i. i < length zs \<and> zs ! i = \<one>"
+
+lemma canonical_ex_3:
+  assumes "canonical zs" and "zs \<noteq> []"
+  shows "\<exists>i<length zs. zs ! i = \<one>"
+  using assms canonical_def by (metis One_nat_def Suc_pred last_conv_nth length_greater_0_conv lessI)
+
+lemma canonical_first1:
+  assumes "canonical zs" and "zs \<noteq> []"
+  shows "first1 zs < length zs \<and> zs ! first1 zs = \<one>"
+  using assms canonical_ex_3 by (metis (mono_tags, lifting) LeastI first1_def)
+
+lemma canonical_first1_less:
+  assumes "canonical zs" and "zs \<noteq> []"
+  shows "\<forall>i<first1 zs. zs ! i = \<zero>"
+proof -
+  have "\<forall>i<first1 zs. zs ! i \<noteq> \<one>"
+    using assms first1_def canonical_first1 not_less_Least by fastforce
+  then show ?thesis
+    using assms canonical_def by (meson canonical_first1 less_trans)
+qed
+
+text \<open>
+The next function describes how the canonical representation of the decremented
+symbol sequence looks like. It has special cases for the empty sequence and for
+sequences whose only \textbf{1} is the most significant digit.
+\<close>
+
+definition ndecr :: "symbol list \<Rightarrow> symbol list" where
+  "ndecr zs \<equiv>
+    if zs = [] then []
+    else if first1 zs = length zs - 1
+      then replicate (first1 zs) \<one>
+      else replicate (first1 zs) \<one> @ [\<zero>] @ drop (Suc (first1 zs)) zs"
+
+lemma canonical_ndecr:
+  assumes "canonical zs"
+  shows "canonical (ndecr zs)"
+proof -
+  let ?i = "first1 zs"
+  consider
+      "zs = []"
+    | "zs \<noteq> [] \<and> first1 zs = length zs - 1"
+    | "zs \<noteq> [] \<and> first1 zs < length zs - 1"
+    using canonical_first1 assms by fastforce
+  then show ?thesis
+  proof (cases)
+    case 1
+    then show ?thesis
+      using ndecr_def canonical_def by simp
+  next
+    case 2
+    then show ?thesis
+      using canonical_def ndecr_def not_less_eq by fastforce
+  next
+    case 3
+    then have "Suc (first1 zs) < length zs"
+      by auto
+    then have "last (drop (Suc (first1 zs)) zs) = \<one>"
+      using assms canonical_def 3 by simp
+    moreover have "bit_symbols (replicate (first1 zs) \<one> @ [\<zero>] @ drop (Suc (first1 zs)) zs)"
+    proof -
+      have "bit_symbols (replicate (first1 zs) \<one>)"
+        by simp
+      moreover have "bit_symbols [\<zero>]"
+        by simp
+      moreover have "bit_symbols (drop (Suc (first1 zs)) zs)"
+        using assms canonical_def by simp
+      ultimately show ?thesis
+        using bit_symbols_append by presburger
+    qed
+    ultimately show ?thesis
+      using canonical_def ndecr_def 3 by auto
+  qed
+qed
+
+lemma ndecr:
+  assumes "canonical zs"
+  shows "num (ndecr zs) = num zs - 1"
+proof -
+  let ?i = "first1 zs"
+  consider "zs = []" | "zs \<noteq> [] \<and> first1 zs = length zs - 1" | "zs \<noteq> [] \<and> first1 zs < length zs - 1"
+    using canonical_first1 assms by fastforce
+  then show ?thesis
+  proof (cases)
+    case 1
+    then show ?thesis
+      using ndecr_def canrepr_0 canrepr by (metis zero_diff)
+  next
+    case 2
+    then have less: "zs ! i = \<zero>" if "i < first1 zs" for i
+      using that assms canonical_first1_less by simp
+    have at: "zs ! (first1 zs) = \<one>"
+      using 2 canonical_first1 assms by blast
+    have "zs = replicate (first1 zs) \<zero> @ [\<one>]" (is "zs = ?zs")
+    proof (rule nth_equalityI)
+      show len: "length zs = length ?zs"
+        using 2 by simp
+      show "zs ! i = ?zs ! i" if "i < length zs" for i
+      proof (cases "i < first1 zs")
+        case True
+        then show ?thesis
+          by (simp add: less nth_append)
+      next
+        case False
+        then show ?thesis
+          using len that at
+          by (metis Suc_leI leD length_append_singleton length_replicate linorder_neqE_nat nth_append_length)
+      qed
+    qed
+    moreover from this have "ndecr zs = replicate (first1 zs) 3"
+      using ndecr_def 2 by simp
+    ultimately show ?thesis
+      using num_replicate2_eq_pow num_replicate3_eq_pow_minus_1 by metis
+  next
+    case 3
+    then have less: "zs ! i = \<zero>" if "i < ?i" for i
+      using that assms canonical_first1_less by simp
+    have at: "zs ! ?i = \<one>"
+      using 3 canonical_first1 assms by simp
+    have zs: "zs = replicate ?i \<zero> @ [\<one>] @ drop (Suc ?i) zs" (is "zs = ?zs")
+    proof (rule nth_equalityI)
+      show len: "length zs = length ?zs"
+        using 3 by auto
+      show "zs ! i = ?zs ! i" if "i < length zs" for i
+      proof -
+        consider "i < ?i" | "i = ?i" | "i > ?i"
+          by linarith
+        then show ?thesis
+        proof (cases)
+          case 1
+          then show ?thesis
+            using less by (metis length_replicate nth_append nth_replicate)
+        next
+          case 2
+          then show ?thesis
+            using at by (metis append_Cons length_replicate nth_append_length)
+        next
+          case 3
+          have "?zs = (replicate ?i \<zero> @ [\<one>]) @ drop (Suc ?i) zs"
+            by simp
+          then have "?zs ! i = drop (Suc ?i) zs ! (i - Suc ?i)"
+            using 3 by (simp add: nth_append)
+          then have "?zs ! i = zs ! i"
+            using 3 that by simp
+          then show ?thesis
+            by simp
+        qed
+      qed
+    qed
+    then have "ndecr zs = replicate ?i \<one> @ [\<zero>] @ drop (Suc ?i) zs"
+      using ndecr_def 3 by simp
+    then have "Suc (num (ndecr zs)) = Suc (num ((replicate ?i \<one> @ [\<zero>]) @ drop (Suc ?i) zs))"
+        (is "_ = Suc (num (?xs @ ?ys))")
+      by simp
+    also have "... = Suc (num ?xs + 2 ^ length ?xs * num ?ys)"
+      using num_append by blast
+    also have "... = Suc (num ?xs + 2 ^ Suc ?i * num ?ys)"
+      by simp
+    also have "... = Suc (2 ^ ?i - 1 + 2 ^ Suc ?i * num ?ys)"
+      using num_replicate3_eq_pow_minus_1 num_trailing_zero[of 2 "replicate ?i \<one>"] by simp
+    also have "... = 2 ^ ?i + 2 ^ Suc ?i * num ?ys"
+      by simp
+    also have "... = num (replicate ?i \<zero> @ [\<one>]) + 2 ^ Suc ?i * num ?ys"
+      using num_replicate2_eq_pow by simp
+    also have "... = num ((replicate ?i \<zero> @ [\<one>]) @ ?ys)"
+      using num_append by (metis length_append_singleton length_replicate)
+    also have "... = num (replicate ?i \<zero> @ [\<one>] @ ?ys)"
+      by simp
+    also have "... = num zs"
+      using zs by simp
+    finally have "Suc (num (ndecr zs)) = num zs" .
+    then show ?thesis
+      by simp
+  qed
+qed
+
+text \<open>
+The next Turing machine implements the function @{const ndecr}. It does nothing
+on the empty input, which represents zero. On other inputs it writes symbols
+\textbf{1} going right until it reaches a \textbf{1} symbol, which is guaranteed
+to happen for non-empty canonical representations. It then overwrites this
+\textbf{1} with \textbf{0}.  If there is a blank symbol to the right of this
+\textbf{0}, the \textbf{0} is removed again.
+\<close>
+
+definition tm_decr :: "tapeidx \<Rightarrow> machine" where
+  "tm_decr j \<equiv>
+    IF \<lambda>rs. rs ! j = \<box> THEN
+      []
+    ELSE
+      tm_const_until j j {\<one>} \<one> ;;
+      tm_rtrans j (\<lambda>_. \<zero>) ;;
+      IF \<lambda>rs. rs ! j = \<box> THEN
+        tm_left j ;;
+        tm_write j \<box>
+      ELSE
+        []
+      ENDIF ;;
+      tm_cr j
+    ENDIF"
+
+lemma tm_decr_tm:
+  assumes "G \<ge> 4" and "k \<ge> 2" and "j < k" and "0 < j"
+  shows "turing_machine k G (tm_decr j)"
+  unfolding tm_decr_def
+  using assms tm_cr_tm tm_const_until_tm tm_rtrans_tm tm_left_tm tm_write_tm
+    turing_machine_branch_turing_machine Nil_tm
+  by simp
+
+locale turing_machine_decr =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_const_until j j {\<one>} \<one>"
+definition "tm2 \<equiv> tm1 ;; tm_rtrans j (\<lambda>_. \<zero>)"
+definition "tm23 \<equiv> tm_left j"
+definition "tm24 \<equiv> tm23 ;; tm_write j \<box>"
+definition "tm25 \<equiv> IF \<lambda>rs. rs ! j = \<box> THEN tm24 ELSE [] ENDIF"
+definition "tm5 \<equiv> tm2 ;; tm25"
+definition "tm6 \<equiv> tm5 ;; tm_cr j"
+definition "tm7 \<equiv> IF \<lambda>rs. rs ! j = \<box> THEN [] ELSE tm6 ENDIF"
+
+lemma tm7_eq_tm_decr: "tm7 = tm_decr j"
+  unfolding tm1_def tm2_def tm23_def tm24_def tm25_def tm5_def tm6_def tm7_def tm_decr_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and xs :: "symbol list" and k :: nat
+  assumes jk: "length tps0 = k" "j < k"
+    and can: "canonical xs"
+    and tps0: "tps0 ! j = (\<lfloor>xs\<rfloor>, 1)"
+begin
+
+lemma bs: "bit_symbols xs"
+  using can canonical_def by simp
+
+context
+  assumes read_tps0: "read tps0 ! j = \<box>"
+begin
+
+lemma xs_Nil: "xs = []"
+  using tps0 jk tapes_at_read' read_tps0 bs contents_inbounds
+  by (metis can canreprI canrepr_0 fst_conv ncontents_1_blank_iff_zero snd_conv)
+
+lemma transforms_NilI:
+  assumes "ttt = 0"
+    and "tps' = tps0[j := (\<lfloor>ndecr xs\<rfloor>, 1)]"
+  shows "transforms [] tps0 ttt tps'"
+  using transforms_Nil xs_Nil ndecr_def tps0 assms by (metis Basics.transforms_Nil list_update_id)
+
+end  (* context read tps0 ! j = 0 *)
+
+context
+  assumes read_tps0': "read tps0 ! j \<noteq> \<box>"
+begin
+
+lemma xs: "xs \<noteq> []"
+  using tps0 jk tapes_at_read' read_tps0' bs contents_inbounds
+  by (metis canrepr_0 fst_conv ncontents_1_blank_iff_zero snd_conv)
+
+lemma first1: "first1 xs < length xs" "xs ! first1 xs = \<one>" "\<forall>i<first1 xs. xs ! i = \<zero>"
+  using canonical_first1[OF can xs] canonical_first1_less[OF can xs] by simp_all
+
+definition "tps1 \<equiv> tps0
+  [j := (\<lfloor>replicate (first1 xs) \<one> @ [\<one>] @ (drop (Suc (first1 xs)) xs)\<rfloor>, Suc (first1 xs))]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = Suc (first1 xs)"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps1_def jk time: assms)
+  show "rneigh (tps0 ! j) {\<one>} (first1 xs)"
+  proof (rule rneighI)
+    show "(tps0 ::: j) (tps0 :#: j + first1 xs) \<in> {\<one>}"
+      using first1(1,2) tps0 jk by (simp add: Suc_leI)
+    show "\<And>n'. n' < first1 xs \<Longrightarrow> (tps0 ::: j) (tps0 :#: j + n') \<notin> {\<one>}"
+      using first1(3) tps0 jk by (simp add: contents_def)
+  qed
+  show "tps1 = tps0
+    [j := tps0 ! j |+| first1 xs,
+     j := constplant (tps0 ! j) \<one> (first1 xs)]"
+  proof -
+    have "tps1 ! j = constplant (tps0 ! j) 3 (first1 xs)"
+      (is "_ = ?rhs")
+    proof -
+      have "fst ?rhs = (\<lambda>i. if 1 \<le> i \<and> i < 1 + first1 xs then \<one> else \<lfloor>xs\<rfloor> i)"
+        using tps0 jk constplant by auto
+      also have "... = \<lfloor>replicate (first1 xs) \<one> @ [\<one>] @ drop (Suc (first1 xs)) xs\<rfloor>"
+      proof
+        fix i
+        consider
+            "i = 0"
+          | "i \<ge> 1 \<and> i < 1 + first1 xs"
+          | "i = 1 + first1 xs"
+          | "1 + first1 xs < i \<and> i \<le> length xs"
+          | "i > length xs"
+          by linarith
+        then show "(if 1 \<le> i \<and> i < 1 + first1 xs then \<one> else \<lfloor>xs\<rfloor> i) =
+          \<lfloor>replicate (first1 xs) \<one> @ [\<one>] @ drop (Suc (first1 xs)) xs\<rfloor> i"
+          (is "?l = ?r")
+        proof (cases)
+          case 1
+          then show ?thesis
+            by simp
+        next
+          case 2
+          then show ?thesis
+            by (smt (verit) One_nat_def Suc_diff_Suc add_diff_inverse_nat contents_inbounds first1(1) length_append
+              length_drop length_replicate less_imp_le_nat less_le_trans list.size(3) list.size(4) not_le not_less_eq
+              nth_append nth_replicate plus_1_eq_Suc)
+        next
+          case 3
+          then show ?thesis
+            using first1
+            by (smt (verit) One_nat_def Suc_diff_Suc Suc_leI add_diff_inverse_nat append_Cons contents_inbounds
+              diff_Suc_1 length_append length_drop length_replicate less_SucI less_Suc_eq_0_disj list.size(3)
+              list.size(4) not_less_eq nth_append_length)
+        next
+          case 4
+          then have "?r = (replicate (first1 xs) \<one> @ [\<one>] @ drop (Suc (first1 xs)) xs) ! (i - 1)"
+            by auto
+          also have "... = ((replicate (first1 xs) \<one> @ [\<one>]) @ drop (Suc (first1 xs)) xs) ! (i - 1)"
+            by simp
+          also have "... = (drop (Suc (first1 xs)) xs) ! (i - 1 - Suc (first1 xs))"
+            using 4
+            by (metis Suc_leI add_diff_inverse_nat gr_implies_not0 leD length_append_singleton
+              length_replicate less_one nth_append plus_1_eq_Suc)
+          also have "... = xs ! (i - 1)"
+            using 4 by (metis Suc_leI add_diff_inverse_nat first1(1) gr_implies_not0 leD less_one nth_drop plus_1_eq_Suc)
+          also have "... = \<lfloor>xs\<rfloor> i"
+            using 4 by simp
+          also have "... = ?l"
+            using 4 by simp
+          finally have "?r = ?l" .
+          then show ?thesis
+            by simp
+        next
+          case 5
+          then show ?thesis
+            using first1(1) by simp
+        qed
+      qed
+      also have "... = tps1 ::: j"
+        using tps1_def jk by simp
+      finally have "fst ?rhs = fst (tps1 ! j)" .
+      then show ?thesis
+        using tps1_def jk constplant tps0 by simp
+    qed
+    then show ?thesis
+      using tps1_def tps0 jk by simp
+  qed
+qed
+
+definition "tps2 \<equiv> tps0
+  [j := (\<lfloor>replicate (first1 xs) \<one> @ [\<zero>] @ drop (Suc (first1 xs)) xs\<rfloor>, Suc (Suc (first1 xs)))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = first1 xs + 2"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps2_def tps1_def jk time: assms)
+  show "tps2 = tps1[j := tps1 ! j |:=| \<zero> |+| 1]"
+    using tps1_def tps2_def jk contents_append_update by simp
+qed
+
+definition "tps5 \<equiv> tps0
+  [j := (\<lfloor>ndecr xs\<rfloor>, if read tps2 ! j = \<box> then Suc (first1 xs) else Suc (Suc (first1 xs)))]"
+
+context
+  assumes read_tps2: "read tps2 ! j = \<box>"
+begin
+
+lemma proper_contents_outofbounds:
+  assumes "proper_symbols zs" and "\<lfloor>zs\<rfloor> i = \<box>"
+  shows "i > length zs"
+  using contents_def proper_symbols_ne0 assms
+  by (metis Suc_diff_1 bot_nat_0.not_eq_extremum linorder_le_less_linear not_less_eq zero_neq_one)
+
+lemma first1_eq: "first1 xs = length xs - 1"
+proof -
+  have "tps2 ! j = (\<lfloor>replicate (first1 xs) \<one> @ [\<zero>] @ drop (Suc (first1 xs)) xs\<rfloor>, Suc (Suc (first1 xs)))"
+      (is "_ = (\<lfloor>?zs\<rfloor>, ?i)")
+    using tps2_def jk by simp
+  have "proper_symbols xs"
+    using can bs by fastforce
+  then have *: "proper_symbols ?zs"
+    using proper_symbols_append[of "[\<zero>]" "drop (Suc (first1 xs)) xs"] proper_symbols_append
+    by simp
+  have "read tps2 ! j = \<lfloor>?zs\<rfloor> ?i"
+    using tps2_def jk tapes_at_read'[of j tps2] by simp
+  then have "\<lfloor>?zs\<rfloor> ?i = \<box>"
+    using read_tps2 by simp
+  then have "?i > length ?zs"
+    using * proper_contents_outofbounds by blast
+  moreover have "length ?zs = length xs"
+    using first1 by simp
+  ultimately have "Suc (first1 xs) \<ge> length xs"
+    by simp
+  moreover have "length xs > 0"
+    using xs by simp
+  ultimately have "first1 xs \<ge> length xs - 1"
+    by simp
+  then show ?thesis
+    using first1(1) by simp
+qed
+
+lemma drop_xs_Nil: "drop (Suc (first1 xs)) xs = []"
+  using first1_eq xs by simp
+
+lemma tps2_eq: "tps2 = tps0[j := (\<lfloor>replicate (first1 xs) \<one> @ [\<zero>]\<rfloor>, Suc (Suc (first1 xs)))]"
+  using tps2_def drop_xs_Nil jk by simp
+
+definition "tps23 \<equiv> tps0
+  [j := (\<lfloor>replicate (first1 xs) \<one> @ [\<zero>]\<rfloor>, Suc (first1 xs))]"
+
+lemma tm23 [transforms_intros]:
+  assumes "ttt = 1"
+  shows "transforms tm23 tps2 ttt tps23"
+  unfolding tm23_def
+proof (tform tps: tps2_def tps23_def jk time: assms)
+  show "tps23 = tps2[j := tps2 ! j |-| 1]"
+    using tps23_def tps2_eq jk by simp
+qed
+
+definition "tps24 \<equiv> tps0
+  [j := (\<lfloor>replicate (first1 xs) \<one>\<rfloor>, Suc (first1 xs))]"
+
+lemma tm24:
+  assumes "ttt = 2"
+  shows "transforms tm24 tps2 ttt tps24"
+  unfolding tm24_def
+proof (tform tps: tps23_def tps24_def time: assms)
+  show "tps24 = tps23[j := tps23 ! j |:=| \<box>]"
+  proof -
+    have "tps23 ! j |:=| \<box> = (\<lfloor>replicate (first1 xs) \<one> @ [\<zero>]\<rfloor>, Suc (first1 xs)) |:=| \<box>"
+      using tps23_def jk by simp
+    then have "tps23 ! j |:=| \<box> = (\<lfloor>replicate (first1 xs) \<one> @ [\<box>]\<rfloor>, Suc (first1 xs))"
+      using contents_append_update by auto
+    then have "tps23 ! j |:=| \<box> = (\<lfloor>replicate (first1 xs) \<one>\<rfloor>, Suc (first1 xs))"
+      using contents_append_blanks by (metis replicate_0 replicate_Suc)
+    moreover have "tps24 ! j = (\<lfloor>replicate (first1 xs) \<one>\<rfloor>, Suc (first1 xs))"
+      using tps24_def jk by simp
+    ultimately show ?thesis
+      using tps23_def tps24_def by auto
+  qed
+qed
+
+corollary tm24' [transforms_intros]:
+  assumes "ttt = 2" and "tps' = tps0[j := (\<lfloor>ndecr xs\<rfloor>, Suc (first1 xs))]"
+  shows "transforms tm24 tps2 ttt tps'"
+proof -
+  have "tps24 = tps0[j := (\<lfloor>ndecr xs\<rfloor>, Suc (first1 xs))]"
+    using tps24_def jk ndecr_def first1_eq xs by simp
+  then show ?thesis
+    using assms tm24 by simp
+qed
+
+end  (* context read tps2 ! j = 0 *)
+
+context
+  assumes read_tps2': "read tps2 ! j \<noteq> \<box>"
+begin
+
+lemma first1_neq: "first1 xs \<noteq> length xs - 1"
+proof (rule ccontr)
+  assume eq: "\<not> first1 xs \<noteq> length xs - 1"
+
+  have "tps2 ! j = (\<lfloor>replicate (first1 xs) \<one> @ [\<zero>] @ drop (Suc (first1 xs)) xs\<rfloor>, Suc (Suc (first1 xs)))"
+      (is "_ = (\<lfloor>?zs\<rfloor>, ?i)")
+    using tps2_def jk by simp
+  have "length ?zs = length xs"
+    using first1 by simp
+  then have "Suc (Suc (first1 xs)) = Suc (length ?zs)"
+    using xs eq by simp
+  then have *: "\<lfloor>?zs\<rfloor> ?i = 0"
+    using contents_outofbounds by simp
+
+  have "read tps2 ! j = \<lfloor>?zs\<rfloor> ?i"
+    using tps2_def jk tapes_at_read'[of j tps2] by simp
+  then have "\<lfloor>?zs\<rfloor> ?i \<noteq> \<box>"
+    using read_tps2' by simp
+  then show False
+    using * by simp
+qed
+
+lemma tps2: "tps2 = tps0[j := (\<lfloor>ndecr xs\<rfloor>, Suc (Suc (first1 xs)))]"
+  using tps2_def ndecr_def first1_neq xs by simp
+
+end  (* context read tps2 ! j \<noteq> 0 *)
+
+lemma tm25 [transforms_intros]:
+  assumes "ttt = (if read tps2 ! j = \<box> then 4 else 1)"
+  shows "transforms tm25 tps2 ttt tps5"
+  unfolding tm25_def by (tform tps: tps2 tps5_def time: assms)
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = first1 xs + 2 + (if read tps2 ! j = \<box> then 4 else 1)"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def by (tform time: assms)
+
+definition "tps6 \<equiv> tps0
+  [j := (\<lfloor>ndecr xs\<rfloor>, 1)]"
+
+lemma tm6:
+  assumes "ttt = first1 xs + 2 + (if read tps2 ! j = \<box> then 4 else 1) + (tps5 :#: j + 2)"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+proof (tform tps: tps5_def tps6_def jk time: assms)
+  show "clean_tape (tps5 ! j)"
+  proof -
+    have "tps5 ::: j = \<lfloor>ndecr xs\<rfloor>"
+      using tps5_def jk by simp
+    moreover have "bit_symbols (ndecr xs)"
+      using canonical_ndecr can canonical_def by simp
+    ultimately show ?thesis
+      using One_nat_def Suc_1 Suc_le_lessD clean_contents_proper
+      by (metis contents_clean_tape' lessI one_less_numeral_iff semiring_norm(77))
+  qed
+qed
+
+lemma tm6' [transforms_intros]:
+  assumes "ttt = 2 * first1 xs + 9"
+  shows "transforms tm6 tps0 ttt tps6"
+proof -
+  let ?ttt = "first1 xs + 2 + (if read tps2 ! j = \<box> then 4 else 1) + (tps5 :#: j + 2)"
+  have "tps5 :#: j = (if read tps2 ! j = \<box> then Suc (first1 xs) else Suc (Suc (first1 xs)))"
+    using tps5_def jk by simp
+  then have "?ttt \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using tm6 transforms_monotone assms by simp
+qed
+
+end  (* context read tps0 ! j \<noteq> 0 *)
+
+definition "tps7 \<equiv> tps0[j := (\<lfloor>ndecr xs\<rfloor>, 1)]"
+
+lemma tm7:
+  assumes "ttt = 8 + 2 * length xs"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def
+proof (tform tps: tps6_def tps7_def time: assms)
+  show "tps7 = tps0" if "read tps0 ! j = \<box>"
+    using that ndecr_def tps0 tps7_def xs_Nil jk by (simp add: list_update_same_conv)
+  show "2 * first1 xs + 9 + 1 \<le> ttt" if "read tps0 ! j \<noteq> \<box>"
+  proof -
+    have "length xs > 0"
+      using that xs by simp
+    then show ?thesis
+      using first1(1) that assms by simp
+  qed
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_decrI [transforms_intros]:
+  fixes tps tps' :: "tape list" and n :: nat and k ttt :: nat
+  assumes "j < k" "length tps = k"
+  assumes "tps ! j = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 8 + 2 * nlength n"
+  assumes "tps' = tps[j := (\<lfloor>n - 1\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_decr j) tps ttt tps'"
+proof -
+  let ?xs = "canrepr n"
+  have can: "canonical ?xs"
+    using canonical_canrepr by simp
+  have tps0: "tps ! j = (\<lfloor>?xs\<rfloor>, 1)"
+    using assms by simp
+  have tps': "tps' = tps[j := (\<lfloor>ndecr ?xs\<rfloor>, 1)]"
+    using ndecr assms(5) by (metis canrepr canreprI can canonical_ndecr)
+  interpret loc: turing_machine_decr j .
+  have "transforms loc.tm7 tps ttt tps'"
+    using loc.tm7 loc.tps7_def by (metis assms(1,2,4) can tps' tps0)
+  then show ?thesis
+    using loc.tm7_eq_tm_decr by simp
+qed
+
+
+subsection \<open>Addition\<close>
+
+text \<open>
+In this section we construct a Turing machine that adds two numbers in canonical
+representation each given on a separate tape and overwrites the second number
+with the sum. The TM implements the common algorithm with carry starting from
+the least significant digit.
+
+Given two symbol sequences @{term xs} and @{term ys} representing numbers, the
+next function computes the carry bit that occurs in the $i$-th position. For the
+least significant position, 0, there is no carry (that is, it is 0); for
+position $i + 1$ the carry is the sum of the bits of @{term xs} and @{term ys}
+in position $i$ and the carry for position $i$. The function gives the carry as
+symbol \textbf{0} or \textbf{1}, except for position 0, where it is the start
+symbol~$\triangleright$. The start symbol represents the same bit as the
+symbol~\textbf{0} as defined by @{const todigit}.  The reason for this special
+treatment is that the TM will store the carry on a memorization tape
+(see~Section~\ref{s:tm-memorizing}), which initially contains the start symbol.
+\<close>
+
+fun carry :: "symbol list \<Rightarrow> symbol list \<Rightarrow> nat \<Rightarrow> symbol" where
+  "carry xs ys 0 = 1" |
+  "carry xs ys (Suc i) = tosym ((todigit (digit xs i) + todigit (digit ys i) + todigit (carry xs ys i)) div 2)"
+
+text \<open>
+The next function specifies the $i$-th digit of the sum.
+\<close>
+
+definition sumdigit :: "symbol list \<Rightarrow> symbol list \<Rightarrow> nat \<Rightarrow> symbol" where
+  "sumdigit xs ys i \<equiv> tosym ((todigit (digit xs i) + todigit (digit ys i) + todigit (carry xs ys i)) mod 2)"
+
+lemma carry_sumdigit: "todigit (sumdigit xs ys i) + 2 * (todigit (carry xs ys (Suc i))) =
+    todigit (carry xs ys i) + todigit (digit xs i) + todigit (digit ys i)"
+  using sumdigit_def by simp
+
+lemma carry_sumdigit_eq_sum:
+  "num xs + num ys =
+   num (map (sumdigit xs ys) [0..<t]) + 2 ^ t * todigit (carry xs ys t) + 2 ^ t * num (drop t xs) + 2 ^ t * num (drop t ys)"
+proof (induction t)
+  case 0
+  then show ?case
+    using num_def by simp
+next
+  case (Suc t)
+  let ?z = "sumdigit xs ys"
+  let ?c = "carry xs ys"
+  let ?zzz = "map ?z [0..<Suc t]"
+  have "num (take (Suc t) ?zzz) = num (take t ?zzz) + 2 ^ t * todigit (digit ?zzz t)"
+    using num_take_Suc by blast
+  moreover have "take (Suc t) ?zzz = map (sumdigit xs ys) [0..<Suc t]"
+    by simp
+  moreover have "take t ?zzz = map (sumdigit xs ys) [0..<t]"
+    by simp
+  ultimately have 1: "num (map ?z [0..<Suc t]) = num (map ?z [0..<t]) + 2 ^ t * todigit (digit ?zzz t)"
+    by simp
+
+  have 2: "digit ?zzz t = sumdigit xs ys t"
+    using digit_def
+    by (metis One_nat_def add_Suc diff_add_inverse length_map length_upt lessI nth_map_upt plus_1_eq_Suc)
+
+  have "todigit (?z t) + 2 * (todigit (carry xs ys (Suc t))) =
+      todigit (carry xs ys t) + todigit (digit xs t) + todigit (digit ys t)"
+    using carry_sumdigit .
+  then have "2 ^ t * (todigit (?z t) + 2 * (todigit (?c (Suc t)))) =
+      2 ^ t * (todigit (?c t) + todigit (digit xs t) + todigit (digit ys t))"
+    by simp
+  then have "2 ^ t * todigit (?z t) + 2 ^ t * 2 * todigit (?c (Suc t)) =
+      2 ^ t * todigit (?c t) + 2 ^ t * todigit (digit xs t) + 2 ^ t * todigit (digit ys t)"
+    using add_mult_distrib2 by simp
+  then have "num (map ?z [0..<t]) + 2 ^ t * (todigit (?z t)) + 2 ^ Suc t * (todigit (?c (Suc t))) =
+      num (map ?z [0..<t]) + 2 ^ t * (todigit (?c t)) + 2 ^ t * (todigit (digit xs t)) + 2^t * (todigit (digit ys t))"
+    by simp
+  then have "num (map ?z [0..<Suc t]) + 2 ^ Suc t * (todigit (?c (Suc t))) =
+      num (map ?z [0..<t]) + 2 ^ t * todigit (?c t) + 2 ^ t * todigit (digit xs t) + 2 ^ t * todigit (digit ys t)"
+    using 1 2 by simp
+  then have "num (map ?z [0..<Suc t]) + 2 ^ Suc t * (todigit (?c (Suc t))) +
+        2 ^ Suc t * num (drop (Suc t) xs) + 2 ^ Suc t * num (drop (Suc t) ys) =
+      num (map ?z [0..<t]) + 2 ^ t * todigit (?c t) + 2 ^ t * todigit (digit xs t) + 2 ^ t * todigit (digit ys t) +
+        2 ^ Suc t * num (drop (Suc t) xs) + 2 ^ Suc t * num (drop (Suc t) ys)"
+    by simp
+  also have "... = num (map ?z [0..<t]) + 2 ^ t * (todigit (?c t)) +
+        2 ^ t * (todigit (digit xs t) + 2 * num (drop (Suc t) xs)) + 2 ^ t * (todigit (digit ys t) + 2 * num (drop (Suc t) ys))"
+    by (simp add: add_mult_distrib2)
+  also have "... = num (map ?z [0..<t]) + 2 ^ t * (todigit (?c t)) +
+        2 ^ t * num (drop t xs) + 2 ^ t * num (drop t ys)"
+    using num_drop by metis
+  also have "... = num xs + num ys"
+    using Suc by simp
+  finally show ?case
+    by simp
+qed
+
+lemma carry_le:
+  assumes "symbols_lt 4 xs" and "symbols_lt 4 ys"
+  shows "carry xs ys t \<le> \<one>"
+proof (induction t)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc t)
+  then have "todigit (carry xs ys t) \<le> 1"
+    by simp
+  moreover have "todigit (digit xs t) \<le> 1"
+    using assms(1) digit_def by auto
+  moreover have "todigit (digit ys t) \<le> 1"
+    using assms(2) digit_def by auto
+  ultimately show ?case
+    by simp
+qed
+
+lemma num_sumdigit_eq_sum:
+  assumes "length xs \<le> n"
+    and "length ys \<le> n"
+    and "symbols_lt 4 xs"
+    and "symbols_lt 4 ys"
+  shows "num xs + num ys = num (map (sumdigit xs ys) [0..<Suc n])"
+proof -
+  have "num xs + num ys =
+      num (map (sumdigit xs ys) [0..<Suc n]) + 2 ^ Suc n * todigit (carry xs ys (Suc n)) +
+        2 ^ Suc n * num (drop (Suc n) xs) + 2 ^ Suc n * num (drop (Suc n) ys)"
+    using carry_sumdigit_eq_sum by blast
+  also have "... = num (map (sumdigit xs ys) [0..<Suc n]) + 2 ^ Suc n * todigit (carry xs ys (Suc n))"
+    using assms(1,2) by (simp add: num_def)
+  also have "... = num (map (sumdigit xs ys) [0..<Suc n])"
+  proof -
+    have "digit xs n = 0"
+      using assms(1) digit_def by simp
+    moreover have "digit ys n = 0"
+      using assms(2) digit_def by simp
+    ultimately have "(digit xs n + digit ys n + todigit (carry xs ys n)) div 2 = 0"
+      using carry_le[OF assms(3,4), of n] by simp
+    then show ?thesis
+      by auto
+  qed
+  finally show ?thesis .
+qed
+
+lemma num_sumdigit_eq_sum':
+  assumes "symbols_lt 4 xs" and "symbols_lt 4 ys"
+  shows "num xs + num ys = num (map (sumdigit xs ys) [0..<Suc (max (length xs) (length ys))])"
+  using assms num_sumdigit_eq_sum by simp
+
+lemma num_sumdigit_eq_sum'':
+  assumes "bit_symbols xs" and "bit_symbols ys"
+  shows "num xs + num ys = num (map (sumdigit xs ys) [0..<Suc (max (length xs) (length ys))])"
+proof -
+  have "symbols_lt 4 xs"
+    using assms(1) by auto
+  moreover have "symbols_lt 4 ys"
+    using assms(2) by auto
+  ultimately show ?thesis
+    using num_sumdigit_eq_sum' by simp
+qed
+
+lemma sumdigit_bit_symbols: "bit_symbols (map (sumdigit xs ys) [0..<t])"
+  using sumdigit_def by auto
+
+text \<open>
+The core of the addition Turing machine is the following command. It scans the
+symbols on tape $j_1$ and $j_2$ in lockstep until it reaches blanks on both
+tapes. In every step it adds the symbols on both tapes and the symbol on the
+last tape, which is a memorization tape storing the carry bit. The sum of these
+three bits modulo~2 is written to tape $j_2$ and the new carry to the
+memorization tape.
+\<close>
+
+definition cmd_plus :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> command" where
+  "cmd_plus j1 j2 rs \<equiv>
+    (if rs ! j1 = \<box> \<and> rs ! j2 = \<box> then 1 else 0,
+     (map (\<lambda>j.
+       if j = j1 then (rs ! j, Right)
+       else if j = j2 then (tosym ((todigit (rs ! j1) + todigit (rs ! j2) + todigit (last rs)) mod 2), Right)
+       else if j = length rs - 1 then (tosym ((todigit (rs ! j1) + todigit (rs ! j2) + todigit (last rs)) div 2), Stay)
+       else (rs ! j, Stay)) [0..<length rs]))"
+
+lemma sem_cmd_plus:
+  assumes "j1 \<noteq> j2"
+    and "j1 < k - 1"
+    and "j2 < k - 1"
+    and "j2 > 0"
+    and "length tps = k"
+    and "bit_symbols xs"
+    and "bit_symbols ys"
+    and "tps ! j1 = (\<lfloor>xs\<rfloor>, Suc t)"
+    and "tps ! j2 = (\<lfloor>map (sumdigit xs ys) [0..<t] @ drop t ys\<rfloor>, Suc t)"
+    and "last tps = \<lceil>carry xs ys t\<rceil>"
+    and "rs = read tps"
+    and "tps' = tps
+      [j1 := tps!j1 |+| 1,
+       j2 := tps!j2 |:=| sumdigit xs ys t |+| 1,
+       length tps - 1 := \<lceil>carry xs ys (Suc t)\<rceil>]"
+  shows "sem (cmd_plus j1 j2) (0, tps) = (if t < max (length xs) (length ys) then 0 else 1, tps')"
+proof
+  have "k \<ge> 2"
+    using assms(3,4) by simp
+  have rs1: "rs ! j1 = digit xs t"
+    using assms(2,5,8,11) digit_def read_def contents_def by simp
+  let ?zs = "map (sumdigit xs ys) [0..<t] @ drop t ys"
+  have rs2: "rs ! j2 = digit ys t"
+  proof (cases "t < length ys")
+    case True
+    then have "?zs ! t = ys ! t"
+      by (simp add: nth_append)
+    then show ?thesis
+      using assms(3,5,9,11) digit_def read_def contents_def by simp
+  next
+    case False
+    then have "length ?zs = t"
+      by simp
+    then have "\<lfloor>?zs\<rfloor> (Suc t) = \<box>"
+      using False contents_def by simp
+    then show ?thesis
+      using digit_def read_def contents_def False assms(3,5,9,11) by simp
+  qed
+  have rs3: "last rs = carry xs ys t"
+    using `k \<ge> 2` assms onesie_read onesie_def read_def read_length tapes_at_read'
+    by (metis (no_types, lifting) diff_less last_conv_nth length_greater_0_conv less_one list.size(3) not_numeral_le_zero)
+  have *: "tosym ((todigit (rs ! j1) + todigit (rs ! j2) + todigit (last rs)) mod 2) = sumdigit xs ys t"
+    using rs1 rs2 rs3 sumdigit_def by simp
+
+  have "\<not> (digit xs t = 0 \<and> digit ys t = 0)" if "t < max (length xs) (length ys)"
+    using assms(6,7) digit_def that by auto
+  then have 4: "\<not> (rs ! j1 = 0 \<and> rs ! j2 = 0)" if "t < max (length xs) (length ys)"
+    using rs1 rs2 that by simp
+  then have fst1: "fst (sem (cmd_plus j1 j2) (0, tps)) = fst (0, tps')" if "t < max (length xs) (length ys)"
+    using that cmd_plus_def assms(11) by (smt (verit, ccfv_threshold) fst_conv prod.sel(2) sem)
+
+  have "digit xs t = 0 \<and> digit ys t = 0" if "t \<ge> max (length xs) (length ys)"
+    using that digit_def by simp
+  then have 5: "rs ! j1 = \<box> \<and> rs ! j2 = \<box>" if "t \<ge> max (length xs) (length ys)"
+    using rs1 rs2 that by simp
+  then have "fst (sem (cmd_plus j1 j2) (0, tps)) = fst (1, tps')" if "t \<ge> max (length xs) (length ys)"
+    using that cmd_plus_def assms(11) by (smt (verit, ccfv_threshold) fst_conv prod.sel(2) sem)
+  then show "fst (sem (cmd_plus j1 j2) (0, tps)) = fst (if t < max (length xs) (length ys) then 0 else 1, tps')"
+    using fst1 by (simp add: not_less)
+
+  show "snd (sem (cmd_plus j1 j2) (0, tps)) = snd (if t < max (length xs) (length ys) then 0 else 1, tps')"
+  proof (rule snd_semI)
+    show "proper_command k (cmd_plus j1 j2)"
+      using cmd_plus_def by simp
+    show "length tps = k"
+      using assms(5) .
+    show "length tps' = k"
+      using assms(5,12) by simp
+    have len: "length (read tps) = k"
+      by (simp add: assms read_length)
+    show "act (cmd_plus j1 j2 (read tps) [!] j) (tps ! j) = tps' ! j"
+      if "j < k" for j
+    proof -
+      have j: "j < length tps"
+        using len that assms(5) by simp
+      consider
+          "j = j1"
+        | "j \<noteq> j1 \<and> j = j2"
+        | "j \<noteq> j1 \<and> j \<noteq> j2 \<and> j = length rs - 1"
+        | "j \<noteq> j1 \<and> j \<noteq> j2 \<and> j \<noteq> length rs - 1"
+        by auto
+      then show ?thesis
+      proof (cases)
+        case 1
+        then have "cmd_plus j1 j2 (read tps) [!] j = (read tps ! j, Right)"
+          using that len cmd_plus_def by simp
+        then have "act (cmd_plus j1 j2 (read tps) [!] j) (tps ! j) = tps ! j |+| 1"
+          using act_Right[OF j] by simp
+        moreover have "tps' ! j = tps ! j |+| 1"
+          using assms(1,2,5,12) that 1 by simp
+        ultimately show ?thesis
+          by simp
+      next
+        case 2
+        then have "cmd_plus j1 j2 (read tps) [!] j =
+            (tosym ((todigit (rs ! j1) + todigit (rs ! j2) + todigit (last rs)) mod 2), Right)"
+          using that len cmd_plus_def assms(11) by simp
+        then have "cmd_plus j1 j2 (read tps) [!] j = (sumdigit xs ys t, Right)"
+          using * by simp
+        moreover have "tps' ! j2 = tps!j2 |:=| sumdigit xs ys t |+| 1"
+          using assms(3,5,12) by simp
+        ultimately show ?thesis
+          using act_Right' 2 by simp
+      next
+        case 3
+        then have "cmd_plus j1 j2 (read tps) [!] j =
+            (tosym ((todigit (rs ! j1) + todigit (rs ! j2) + todigit (last rs)) div 2), Stay)"
+          using that len cmd_plus_def assms(11) by simp
+        then have "cmd_plus j1 j2 (read tps) [!] j = (carry xs ys (Suc t), Stay)"
+          using rs1 rs2 rs3 by simp
+        moreover have "tps' ! (length tps - 1) = \<lceil>carry xs ys (Suc t)\<rceil>"
+          using 3 assms(5,11,12) len that by simp
+        ultimately show ?thesis
+          using 3 act_onesie assms(3,5,10,11) len
+          by (metis add_diff_inverse_nat last_length less_nat_zero_code nat_diff_split_asm plus_1_eq_Suc)
+      next
+        case 4
+        then have "cmd_plus j1 j2 (read tps) [!] j = (read tps ! j, Stay)"
+          using that len cmd_plus_def assms(11) by simp
+        then have "act (cmd_plus j1 j2 (read tps) [!] j) (tps ! j) = tps ! j"
+          using act_Stay[OF j] by simp
+        moreover have "tps' ! j = tps ! j"
+          using that 4 len assms(5,11,12) by simp
+        ultimately show ?thesis
+          by simp
+      qed
+    qed
+  qed
+qed
+
+lemma contents_map_append_drop:
+  "\<lfloor>map f [0..<t] @ drop t zs\<rfloor>(Suc t := f t) = \<lfloor>map f [0..<Suc t] @ drop (Suc t) zs\<rfloor>"
+proof (cases "t < length zs")
+  case lt: True
+  then have t_lt: "t < length (map f [0..<t] @ drop t zs)"
+    by simp
+  show ?thesis
+  proof
+    fix x
+    consider
+        "x = 0"
+      | "x > 0 \<and> x < Suc t"
+      | "x = Suc t"
+      | "x > Suc t \<and> x \<le> length zs"
+      | "x > Suc t \<and> x > length zs"
+      by linarith
+    then show "(\<lfloor>map f [0..<t] @ drop t zs\<rfloor>(Suc t := f t)) x =
+        \<lfloor>map f [0..<Suc t] @ drop (Suc t) zs\<rfloor> x"
+        (is "?lhs x = ?rhs x")
+    proof (cases)
+      case 1
+      then show ?thesis
+        using contents_def by simp
+    next
+      case 2
+      then have "?lhs x = (map f [0..<t] @ drop t zs) ! (x - 1)"
+        using contents_def by simp
+      moreover have "x - 1 < t"
+        using 2 by auto
+      ultimately have left: "?lhs x = f (x - 1)"
+        by (metis add.left_neutral diff_zero length_map length_upt nth_append nth_map_upt)
+      have "?rhs x = (map f [0..<Suc t] @ drop (Suc t) zs) ! (x - 1)"
+        using 2 contents_def by simp
+      moreover have "x - 1 < Suc t"
+        using 2 by auto
+      ultimately have "?rhs x = f (x - 1)"
+        by (metis diff_add_inverse diff_zero length_map length_upt nth_append nth_map_upt)
+      then show ?thesis
+        using left by simp
+    next
+      case 3
+      then show ?thesis
+        using contents_def lt
+        by (smt (z3) One_nat_def Suc_leI add_Suc append_take_drop_id diff_Suc_1 diff_zero fun_upd_same
+          length_append length_map length_take length_upt lessI min_absorb2 nat.simps(3) nth_append nth_map_upt plus_1_eq_Suc)
+    next
+      case 4
+      then have "?lhs x = \<lfloor>map f [0..<t] @ drop t zs\<rfloor> x"
+        using contents_def by simp
+      then have "?lhs x = (map f [0..<t] @ drop t zs) ! (x - 1)"
+        using 4 contents_def by simp
+      then have left: "?lhs x = drop t zs ! (x - 1 - t)"
+        using 4
+        by (metis Suc_lessE diff_Suc_1 length_map length_upt less_Suc_eq_le less_or_eq_imp_le minus_nat.diff_0 not_less_eq nth_append)
+      have "x \<le> length (map f [0..<Suc t] @ drop (Suc t) zs)"
+        using 4 lt by auto
+      moreover have "x > 0"
+        using 4 by simp
+      ultimately have "?rhs x = (map f [0..<Suc t] @ drop (Suc t) zs) ! (x - 1)"
+        using 4 contents_inbounds by simp
+      moreover have "x - 1 \<ge> Suc t"
+        using 4 by auto
+      ultimately have "?rhs x = drop (Suc t) zs ! (x - 1 - Suc t)"
+        by (metis diff_zero leD length_map length_upt nth_append)
+      then show ?thesis
+        using left 4 by (metis Cons_nth_drop_Suc Suc_diff_Suc diff_Suc_eq_diff_pred lt nth_Cons_Suc)
+    next
+      case 5
+      then show ?thesis
+        using lt contents_def by auto
+    qed
+  qed
+next
+  case False
+  moreover have "\<lfloor>map f [0..<t]\<rfloor>(Suc t := f t) = \<lfloor>map f [0..<Suc t]\<rfloor>"
+  proof
+    fix x
+    show "(\<lfloor>map f [0..<t]\<rfloor>(Suc t := f t)) x = \<lfloor>map f [0..<Suc t]\<rfloor> x"
+    proof (cases "x < Suc t")
+      case True
+      then show ?thesis
+        using contents_def
+        by (smt (verit, del_insts) diff_Suc_1 diff_zero fun_upd_apply length_map length_upt less_Suc_eq_0_disj
+          less_Suc_eq_le less_imp_le_nat nat_neq_iff nth_map_upt)
+    next
+      case ge: False
+      show ?thesis
+      proof (cases "x = Suc t")
+        case True
+        then show ?thesis
+          using contents_def
+          by (metis One_nat_def add_Suc diff_Suc_1 diff_zero fun_upd_same ge le_eq_less_or_eq length_map
+            length_upt lessI less_Suc_eq_0_disj nth_map_upt plus_1_eq_Suc)
+      next
+        case False
+        then have "x > Suc t"
+          using ge by simp
+        then show ?thesis
+          using contents_def by simp
+      qed
+    qed
+  qed
+  ultimately show ?thesis
+    by simp
+qed
+
+corollary sem_cmd_plus':
+  assumes "j1 \<noteq> j2"
+    and "j1 < k - 1"
+    and "j2 < k - 1"
+    and "j2 > 0"
+    and "length tps = k"
+    and "bit_symbols xs"
+    and "bit_symbols ys"
+    and "tps ! j1 = (\<lfloor>xs\<rfloor>, Suc t)"
+    and "tps ! j2 = (\<lfloor>map (sumdigit xs ys) [0..<t] @ drop t ys\<rfloor>, Suc t)"
+    and "last tps = \<lceil>carry xs ys t\<rceil>"
+    and "tps' = tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc (Suc t)),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<Suc t] @ drop (Suc t) ys\<rfloor>, Suc (Suc t)),
+       length tps - 1 := \<lceil>carry xs ys (Suc t)\<rceil>]"
+  shows "sem (cmd_plus j1 j2) (0, tps) = (if Suc t \<le> max (length xs) (length ys) then 0 else 1, tps')"
+proof -
+  have "tps ! j1 |+| 1 = (\<lfloor>xs\<rfloor>, Suc (Suc t))"
+    using assms(8) by simp
+  moreover have "tps ! j2 |:=| sumdigit xs ys t |+| 1 =
+      (\<lfloor>map (sumdigit xs ys) [0..<Suc t] @ drop (Suc t) ys\<rfloor>, Suc (Suc t))"
+    using contents_map_append_drop assms(9) by simp
+  ultimately show ?thesis
+    using sem_cmd_plus[OF assms(1-10)] assms(11) by auto
+qed
+
+text \<open>
+The next Turing machine comprises just the command @{const cmd_plus}. It
+overwrites tape $j_2$ with the sum of the numbers on tape $j_1$ and $j_2$. The
+carry bit is maintained on the last tape.
+\<close>
+
+definition tm_plus :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_plus j1 j2 \<equiv> [cmd_plus j1 j2]"
+
+lemma tm_plus_tm:
+  assumes "j2 > 0" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_plus j1 j2)"
+  unfolding tm_plus_def using assms(1-3) cmd_plus_def turing_machine_def by auto
+
+lemma tm_plus_immobile:
+  fixes k :: nat
+  assumes "j1 < k" and "j2 < k"
+  shows "immobile (tm_plus j1 j2) k (Suc k)"
+proof -
+  let ?M = "tm_plus j1 j2"
+  { fix q :: nat and rs :: "symbol list"
+    assume q: "q < length ?M"
+    assume rs: "length rs = Suc k"
+    then have len: "length rs - 1 = k"
+      by simp
+    have neq: "k \<noteq> j1" "k \<noteq> j2"
+      using assms by simp_all
+    have "?M ! q = cmd_plus j1 j2"
+      using tm_plus_def q by simp
+    moreover have "(cmd_plus j1 j2) rs [!] k =
+        (tosym ((todigit (rs ! j1) + todigit (rs ! j2) + todigit (last rs)) div 2), Stay)"
+      using cmd_plus_def rs len neq by fastforce
+    ultimately have "(cmd_plus j1 j2) rs [~] k = Stay"
+      by simp
+  }
+  then show ?thesis
+    by (simp add: immobile_def tm_plus_def)
+qed
+
+lemma execute_tm_plus:
+  assumes "j1 \<noteq> j2"
+    and "j1 < k - 1"
+    and "j2 < k - 1"
+    and "j2 > 0"
+    and "length tps = k"
+    and "bit_symbols xs"
+    and "bit_symbols ys"
+    and "t \<le> Suc (max (length xs) (length ys))"
+    and "tps ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>ys\<rfloor>, 1)"
+    and "last tps = \<lceil>\<triangleright>\<rceil>"
+  shows "execute (tm_plus j1 j2) (0, tps) t =
+    (if t \<le> max (length xs) (length ys) then 0 else 1, tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<t] @ drop t ys\<rfloor>, Suc t),
+       length tps - 1 := \<lceil>carry xs ys t\<rceil>])"
+  using assms(8)
+proof (induction t)
+  case 0
+  have "carry xs ys 0 = 1"
+    by simp
+  moreover have "map (sumdigit xs ys) [0..<0] @ drop 0 ys = ys"
+    by simp
+  ultimately have "tps = tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc 0),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<0] @ drop 0 ys\<rfloor>, Suc 0),
+       length tps - 1 := \<lceil>carry xs ys 0\<rceil>]"
+    using assms
+    by (metis One_nat_def add_diff_inverse_nat last_length less_nat_zero_code
+      list_update_id nat_diff_split_asm plus_1_eq_Suc)
+  then show ?case
+    by simp
+next
+  case (Suc t)
+  let ?M = "tm_plus j1 j2"
+  have "execute ?M (0, tps) (Suc t) = exe ?M (execute ?M (0, tps) t)"
+      (is "_ = exe ?M ?cfg")
+    by simp
+  also have "... = sem (cmd_plus j1 j2) ?cfg"
+    using Suc tm_plus_def exe_lt_length by simp
+  also have "... = (if Suc t \<le> max (length xs) (length ys) then 0 else 1, tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc (Suc t)),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<Suc t] @ drop (Suc t) ys\<rfloor>, Suc (Suc t)),
+       length tps - 1 := \<lceil>carry xs ys (Suc t)\<rceil>])"
+  proof -
+    let ?tps = "tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<t] @ drop t ys\<rfloor>, Suc t),
+       length tps - 1 := \<lceil>carry xs ys t\<rceil>]"
+    let ?tps' = "?tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc (Suc t)),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<Suc t] @ drop (Suc t) ys\<rfloor>, Suc (Suc t)),
+       length tps - 1 := \<lceil>carry xs ys (Suc t)\<rceil>]"
+    have cfg: "?cfg = (0, ?tps)"
+      using Suc by simp
+    have tps_k: "length ?tps = k"
+      using assms(2,3,5) by simp
+    have tps_j1: "?tps ! j1 = (\<lfloor>xs\<rfloor>, Suc t)"
+      using assms(1-3,5) by simp
+    have tps_j2: "?tps ! j2 = (\<lfloor>map (sumdigit xs ys) [0..<t] @ drop t ys\<rfloor>, Suc t)"
+      using assms(1-3,5) by simp
+    have tps_last: "last ?tps = \<lceil>carry xs ys t\<rceil>"
+      using assms
+      by (metis One_nat_def carry.simps(1) diff_Suc_1 last_list_update length_list_update list_update_nonempty prod.sel(2) tps_j1)
+    then have "sem (cmd_plus j1 j2) (0, ?tps) = (if Suc t \<le> max (length xs) (length ys) then 0 else 1, ?tps')"
+      using sem_cmd_plus'[OF assms(1-4) tps_k assms(6,7) tps_j1 tps_j2 tps_last] assms(1-3)
+      by (smt (verit, best) Suc.prems Suc_lessD assms(5) tps_k)
+    then have "sem (cmd_plus j1 j2) ?cfg = (if Suc t \<le> max (length xs) (length ys) then 0 else 1, ?tps')"
+      using cfg by simp
+    moreover have "?tps' = tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc (Suc t)),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<Suc t] @ drop (Suc t) ys\<rfloor>, Suc (Suc t)),
+       length tps - 1 := \<lceil>carry xs ys (Suc t)\<rceil>]"
+      using assms by (smt (z3) list_update_overwrite list_update_swap)
+    ultimately show ?thesis
+      by simp
+  qed
+  finally show ?case
+    by simp
+qed
+
+lemma tm_plus_bounded_write:
+  assumes "j1 < k - 1"
+  shows "bounded_write (tm_plus j1 j2) (k - 1) 4"
+  using assms cmd_plus_def tm_plus_def bounded_write_def by simp
+
+lemma carry_max_length:
+  assumes "bit_symbols xs" and "bit_symbols ys"
+  shows "carry xs ys (Suc (max (length xs) (length ys))) = \<zero>"
+proof -
+  let ?t = "max (length xs) (length ys)"
+  have "carry xs ys (Suc ?t) = tosym ((todigit (digit xs ?t) + todigit (digit ys ?t) + todigit (carry xs ys ?t)) div 2)"
+    by simp
+  then have "carry xs ys (Suc ?t) = tosym (todigit (carry xs ys ?t) div 2)"
+    using digit_def by simp
+  moreover have "carry xs ys ?t \<le> \<one>"
+    using carry_le assms by fastforce
+  ultimately show ?thesis
+    by simp
+qed
+
+corollary execute_tm_plus_halt:
+  assumes "j1 \<noteq> j2"
+    and "j1 < k - 1"
+    and "j2 < k - 1"
+    and "j2 > 0"
+    and "length tps = k"
+    and "bit_symbols xs"
+    and "bit_symbols ys"
+    and "t = Suc (max (length xs) (length ys))"
+    and "tps ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>ys\<rfloor>, 1)"
+    and "last tps = \<lceil>\<triangleright>\<rceil>"
+  shows "execute (tm_plus j1 j2) (0, tps) t =
+    (1, tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<t]\<rfloor>, Suc t),
+       length tps - 1 := \<lceil>\<zero>\<rceil>])"
+proof -
+  have "execute (tm_plus j1 j2) (0, tps) t =
+    (1, tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<t] @ drop t ys\<rfloor>, Suc t),
+       length tps - 1 := \<lceil>carry xs ys t\<rceil>])"
+    using assms(8) execute_tm_plus[OF assms(1-7) _ assms(9-11)] Suc_leI Suc_n_not_le_n lessI
+    by presburger
+  then have "execute (tm_plus j1 j2) (0, tps) t =
+    (1, tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<t]\<rfloor>, Suc t),
+       length tps - 1 := \<lceil>carry xs ys t\<rceil>])"
+    using assms(8) by simp
+  then show "execute (tm_plus j1 j2) (0, tps) t =
+    (1, tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<t]\<rfloor>, Suc t),
+       length tps - 1 := \<lceil>\<zero>\<rceil>])"
+    using assms(8) carry_max_length[OF assms(6,7)] by metis
+qed
+
+lemma transforms_tm_plusI:
+  assumes "j1 \<noteq> j2"
+    and "j1 < k - 1"
+    and "j2 < k - 1"
+    and "j2 > 0"
+    and "length tps = k"
+    and "bit_symbols xs"
+    and "bit_symbols ys"
+    and "t = Suc (max (length xs) (length ys))"
+    and "tps ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>ys\<rfloor>, 1)"
+    and "last tps = \<lceil>\<triangleright>\<rceil>"
+    and "tps' = tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<t]\<rfloor>, Suc t),
+       length tps - 1 := \<lceil>\<zero>\<rceil>]"
+  shows "transforms (tm_plus j1 j2) tps t tps'"
+  using assms execute_tm_plus_halt[OF assms(1-11)] tm_plus_def transforms_def transits_def
+  by auto
+
+text \<open>
+The next Turing machine removes the memorization tape from @{const tm_plus}.
+\<close>
+
+definition tm_plus' :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_plus' j1 j2 \<equiv> cartesian (tm_plus j1 j2) 4"
+
+lemma tm_plus'_tm:
+  assumes "j2 > 0" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_plus' j1 j2)"
+  unfolding tm_plus'_def using assms cartesian_tm tm_plus_tm by simp
+
+lemma transforms_tm_plus'I [transforms_intros]:
+  fixes k t :: nat and j1 j2 :: tapeidx and tps tps' :: "tape list" and xs zs :: "symbol list"
+  assumes "j1 \<noteq> j2"
+    and "j1 < k"
+    and "j2 < k"
+    and "j2 > 0"
+    and "length tps = k"
+    and "bit_symbols xs"
+    and "bit_symbols ys"
+    and "t = Suc (max (length xs) (length ys))"
+    and "tps ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>ys\<rfloor>, 1)"
+    and "tps' = tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<t]\<rfloor>, Suc t)]"
+  shows "transforms (tm_plus' j1 j2) tps t tps'"
+proof -
+  let ?tps = "tps @ [\<lceil>\<triangleright>\<rceil>]"
+  let ?tps' = "?tps
+      [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+       j2 := (\<lfloor>map (sumdigit xs ys) [0..<t]\<rfloor>, Suc t),
+       length ?tps - 1 := \<lceil>\<zero>\<rceil>]"
+  let ?M = "tm_plus j1 j2"
+
+  have 1: "length ?tps = Suc k"
+    using assms(5) by simp
+  have 2: "?tps ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    by (simp add: assms(9) assms(2) assms(5) nth_append)
+  have 3: "?tps ! j2 = (\<lfloor>ys\<rfloor>, 1)"
+    by (simp add: assms(10) assms(3) assms(5) nth_append)
+  have 4: "last ?tps = \<lceil>\<triangleright>\<rceil>"
+    by simp
+  have 5: "k \<ge> 2"
+    using assms(3,4) by simp
+  have "transforms (tm_plus j1 j2) ?tps t ?tps'"
+    using transforms_tm_plusI[OF assms(1) _ _ assms(4) 1 assms(6,7,8) 2 3 4, of ?tps'] assms(2,3)
+    by simp
+  moreover have "?tps' = tps' @ [\<lceil>\<zero>\<rceil>]"
+    using assms by (simp add: list_update_append)
+  ultimately have "transforms (tm_plus j1 j2) (tps @ [\<lceil>\<triangleright>\<rceil>]) t (tps' @ [\<lceil>\<zero>\<rceil>])"
+    by simp
+  moreover have "turing_machine (Suc k) 4 ?M"
+    using tm_plus_tm assms by simp
+  moreover have "immobile ?M k (Suc k)"
+    using tm_plus_immobile assms by simp
+  moreover have "bounded_write (tm_plus j1 j2) k 4"
+    using tm_plus_bounded_write[of j1 "Suc k"] assms(2) by simp
+  ultimately have "transforms (cartesian (tm_plus j1 j2) 4) tps t tps'"
+    using cartesian_transforms_onesie[where ?M="?M" and ?b=4] assms(5) 5
+    by simp
+  then show ?thesis
+    using tm_plus'_def by simp
+qed
+
+text \<open>
+The next Turing machine is the one we actually use to add two numbers. After
+computing the sum by running @{const tm_plus'}, it removes trailing zeros
+and performs a carriage return on the tapes $j_1$ and $j_2$.
+\<close>
+
+definition tm_add :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_add j1 j2 \<equiv>
+    tm_plus' j1 j2 ;;
+    tm_lconst_until j2 j2 {h. h \<noteq> \<zero> \<and> h \<noteq> \<box>} \<box> ;;
+    tm_cr j1 ;;
+    tm_cr j2"
+
+lemma tm_add_tm:
+  assumes "j2 > 0" and "k \<ge> 2" and "G \<ge> 4" and "j2 < k"
+  shows "turing_machine k G (tm_add j1 j2)"
+  unfolding tm_add_def using tm_plus'_tm tm_lconst_until_tm tm_cr_tm assms by simp
+
+locale turing_machine_add =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_plus' j1 j2"
+definition "tm2 \<equiv> tm1 ;; tm_lconst_until j2 j2 {h. h \<noteq> \<zero> \<and> h \<noteq> \<box>} \<box>"
+definition "tm3 \<equiv> tm2 ;; tm_cr j1"
+definition "tm4 \<equiv> tm3 ;; tm_cr j2"
+
+lemma tm4_eq_tm_add: "tm4 = tm_add j1 j2"
+  using tm4_def tm3_def tm2_def tm1_def tm_add_def by simp
+
+context
+  fixes x y k :: nat and tps0 :: "tape list"
+  assumes jk: "j1 \<noteq> j2" "j1 < k" "j2 < k" "j2 > 0" "k = length tps0"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>canrepr x\<rfloor>, 1)"
+    "tps0 ! j2 = (\<lfloor>canrepr y\<rfloor>, 1)"
+begin
+
+abbreviation "xs \<equiv> canrepr x"
+
+abbreviation "ys \<equiv> canrepr y"
+
+lemma xs: "bit_symbols xs"
+  using bit_symbols_canrepr by simp
+
+lemma ys: "bit_symbols ys"
+  using bit_symbols_canrepr by simp
+
+abbreviation "n \<equiv> Suc (max (length xs) (length ys))"
+
+abbreviation "m \<equiv> length (canrepr (num xs + num ys))"
+
+definition "tps1 \<equiv> tps0
+  [j1 := (\<lfloor>xs\<rfloor>, Suc n),
+   j2 := (\<lfloor>map (sumdigit xs ys) [0..<n]\<rfloor>, Suc n)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = n"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: jk xs ys tps0 time: assms)
+  show "tps1 = tps0
+    [j1 := (\<lfloor>xs\<rfloor>, Suc ttt),
+     j2 := (\<lfloor>map (sumdigit xs ys) [0..<ttt]\<rfloor>, Suc ttt)]"
+    using tps1_def assms by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j1 := (\<lfloor>xs\<rfloor>, Suc n),
+   j2 := (\<lfloor>canrepr (num xs + num ys)\<rfloor>, m)]"
+
+lemma contents_canlen:
+  assumes "bit_symbols zs"
+  shows "\<lfloor>zs\<rfloor> (canlen zs) \<in> {h. h \<noteq> \<zero> \<and> \<box> < h}"
+  using assms contents_def canlen_le_length canlen_one by auto
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = n + Suc (Suc n - canlen (map (sumdigit xs ys) [0..<n]))"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps1_def jk xs ys tps0)
+  let ?zs = "map (sumdigit xs ys) [0..<n]"
+  have "bit_symbols ?zs"
+    using sumdigit_bit_symbols by blast
+  let ?ln = "Suc n - canlen ?zs"
+  have "lneigh (\<lfloor>?zs\<rfloor>, Suc n) {h. h \<noteq> \<zero> \<and> \<box> < h} ?ln"
+  proof (rule lneighI)
+    have "\<lfloor>?zs\<rfloor> (canlen ?zs) \<in> {h. h \<noteq> \<zero> \<and> \<box> < h}"
+      using contents_canlen[OF `bit_symbols ?zs`] by simp
+    moreover have "Suc n - ?ln = canlen ?zs"
+      by (metis One_nat_def diff_Suc_1 diff_Suc_Suc diff_diff_cancel le_imp_less_Suc
+        length_map length_upt less_imp_le_nat canlen_le_length)
+    ultimately have "\<lfloor>?zs\<rfloor> (Suc n - ?ln) \<in> {h. h \<noteq> \<zero> \<and> \<box> < h}"
+      by simp
+    then show "fst (\<lfloor>?zs\<rfloor>, Suc n) (snd (\<lfloor>?zs\<rfloor>, Suc n) - ?ln) \<in> {h. h \<noteq> \<zero> \<and> \<box> < h}"
+      by simp
+
+    have "\<lfloor>?zs\<rfloor> (Suc n - n') \<in> {\<box>, \<zero>}" if "n' < ?ln" for n'
+    proof (cases "Suc n - n' \<le> n")
+      case True
+      moreover have 1: "Suc n - n' > 0"
+        using that by simp
+      ultimately have "\<lfloor>?zs\<rfloor> (Suc n - n') = ?zs ! (Suc n - n' - 1)"
+        using contents_def by simp
+      moreover have "Suc n - n' - 1 < length ?zs"
+        using that True by simp
+      moreover have "Suc n - n' - 1 \<ge> canlen ?zs"
+        using that by simp
+      ultimately show ?thesis
+        using canlen_at_ge[of ?zs] by simp
+    next
+      case False
+      then show ?thesis
+        by simp
+    qed
+    then have "\<lfloor>?zs\<rfloor> (Suc n - n') \<notin> {h. h \<noteq> \<zero> \<and> \<box> < h}" if "n' < ?ln" for n'
+      using that by fastforce
+    then show "fst (\<lfloor>?zs\<rfloor>, Suc n) (snd (\<lfloor>?zs\<rfloor>, Suc n) - n') \<notin> {h. h \<noteq> \<zero> \<and> \<box> < h}"
+        if "n' < ?ln" for n'
+      using that by simp
+  qed
+  then show "lneigh (tps1 ! j2) {h. h \<noteq> \<zero> \<and> h \<noteq> \<box>} ?ln"
+    using assms tps1_def jk by simp
+  show "Suc n - canlen (map (sumdigit xs ys) [0..<n]) \<le> tps1 :#: j2"
+    "Suc n - canlen (map (sumdigit xs ys) [0..<n]) \<le> tps1 :#: j2"
+    using assms tps1_def jk by simp_all
+
+  have num_zs: "num ?zs = num xs + num ys"
+    using assms num_sumdigit_eq_sum'' xs ys by simp
+  then have canrepr: "canrepr (num xs + num ys) = take (canlen ?zs) ?zs"
+    using canrepr_take_canlen `bit_symbols ?zs` by blast
+  have len_canrepr: "length (canrepr (num xs + num ys)) = canlen ?zs"
+    using num_zs length_canrepr_canlen sumdigit_bit_symbols by blast
+
+  have "lconstplant (\<lfloor>?zs\<rfloor>, Suc n) \<box> ?ln =
+      (\<lfloor>canrepr (num xs + num ys)\<rfloor>, m)"
+    (is "lconstplant ?tp \<box> ?ln = _")
+  proof -
+    have "(if Suc n - ?ln < i \<and> i \<le> Suc n then \<box> else \<lfloor>?zs\<rfloor> i) =
+        \<lfloor>take (canlen ?zs) ?zs\<rfloor> i"
+        (is "?lhs = ?rhs")
+      for i
+    proof -
+      consider
+          "i = 0"
+        | "i > 0 \<and> i \<le> canlen ?zs"
+        | "i > canlen ?zs \<and> i \<le> Suc n"
+        | "i > canlen ?zs \<and> i > Suc n"
+        by linarith
+      then show ?thesis
+      proof (cases)
+        case 1
+        then show ?thesis
+          by simp
+      next
+        case 2
+        then have "i \<le> Suc n - ?ln"
+          using canlen_le_length
+          by (metis diff_diff_cancel diff_zero le_imp_less_Suc length_map length_upt less_imp_le_nat)
+        then have lhs: "?lhs = \<lfloor>?zs\<rfloor> i"
+          by simp
+        have "take (canlen ?zs) ?zs ! (i - 1) = ?zs ! (i - 1)"
+          using 2 by (metis Suc_diff_1 Suc_less_eq le_imp_less_Suc nth_take)
+        then have "?rhs = \<lfloor>?zs\<rfloor> i"
+          using 2 contents_inbounds len_canrepr local.canrepr not_le canlen_le_length
+          by (metis add_diff_inverse_nat add_leE)
+        then show ?thesis
+          using lhs by simp
+      next
+        case 3
+        then have "Suc n - ?ln < i \<and> i \<le> Suc n"
+          by (metis diff_diff_cancel less_imp_le_nat less_le_trans)
+        then have "?lhs = 0"
+          by simp
+        moreover have "?rhs = 0"
+          using 3 contents_outofbounds len_canrepr canrepr by metis
+        ultimately show ?thesis
+          by simp
+      next
+        case 4
+        then have "?lhs = 0"
+          by simp
+        moreover have "?rhs = 0"
+          using 4 contents_outofbounds len_canrepr canrepr by metis
+        ultimately show ?thesis
+          by simp
+      qed
+    qed
+    then have "(\<lambda>i. if Suc n - ?ln < i \<and> i \<le> Suc n then \<box> else \<lfloor>?zs\<rfloor> i) =
+        \<lfloor>canrepr (num xs + num ys)\<rfloor>"
+      using canrepr by simp
+    moreover have "fst ?tp = \<lfloor>?zs\<rfloor>"
+      by simp
+    ultimately have "(\<lambda>i. if Suc n - ?ln < i \<and> i \<le> Suc n then 0 else fst ?tp i) =
+        \<lfloor>canrepr (num xs + num ys)\<rfloor>" by metis
+    moreover have "Suc n - ?ln = m"
+      using len_canrepr
+      by (metis add_diff_inverse_nat diff_add_inverse2 diff_is_0_eq diff_zero le_imp_less_Suc length_map
+        length_upt less_imp_le_nat less_numeral_extra(3) canlen_le_length zero_less_diff)
+    ultimately show ?thesis
+      using lconstplant[of ?tp 0 ?ln] by simp
+  qed
+  then show "tps2 = tps1
+    [j2 := tps1 ! j2 |-| ?ln,
+     j2 := lconstplant (tps1 ! j2) 0 ?ln]"
+    using tps2_def tps1_def jk by simp
+
+  show "ttt = n + Suc ?ln"
+    using assms by simp
+qed
+
+definition "tps3 \<equiv> tps0
+  [j1 := (\<lfloor>xs\<rfloor>, 1),
+   j2 := (\<lfloor>canrepr (num xs + num ys)\<rfloor>, m)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = n + Suc (Suc n - canlen (map (sumdigit xs ys) [0..<n])) + Suc n + 2"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps2_def jk xs ys tps0 time: assms tps2_def jk)
+  show "clean_tape (tps2 ! j1)"
+    using tps2_def jk xs
+    by (metis clean_tape_ncontents nth_list_update_eq nth_list_update_neq)
+  show "tps3 = tps2[j1 := tps2 ! j1 |#=| 1]"
+    using tps3_def tps2_def jk by (simp add: list_update_swap)
+qed
+
+definition "tps4 \<equiv> tps0
+  [j1 := (\<lfloor>xs\<rfloor>, 1),
+   j2 := (\<lfloor>canrepr (num xs + num ys)\<rfloor>, 1)]"
+
+lemma tm4:
+  assumes "ttt = n + Suc (Suc n - canlen (map (sumdigit xs ys) [0..<n])) + Suc n + 2 + m + 2"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: tps3_def jk xs ys tps0 time: assms tps3_def jk)
+  show "clean_tape (tps3 ! j2)"
+    using tps3_def tps2_def jk tps0(1) by (metis clean_tape_ncontents list_update_id nth_list_update_eq)
+  show "tps4 = tps3[j2 := tps3 ! j2 |#=| 1]"
+    using tps4_def tps3_def jk by simp
+qed
+
+lemma tm4':
+  assumes "ttt = 3 * max (length xs) (length ys) + 10"
+  shows "transforms tm4 tps0 ttt tps4"
+proof -
+  let ?zs = "map (sumdigit xs ys) [0..<n]"
+  have "num ?zs = num xs + num ys"
+    using num_sumdigit_eq_sum'' xs ys by simp
+  then have 1: "length (canrepr (num xs + num ys)) = canlen ?zs"
+    using length_canrepr_canlen sumdigit_bit_symbols by blast
+  moreover have "length ?zs = n"
+    by simp
+  ultimately have "m \<le> n"
+    by (metis canlen_le_length)
+
+  have "n + Suc (Suc n - canlen ?zs) + Suc n + 2 + m + 2 =
+      n + Suc (Suc n - m) + Suc n + 2 + m + 2"
+    using 1 by simp
+  also have "... = n + Suc (Suc n - m) + Suc n + 4 + m"
+    by simp
+  also have "... = n + Suc (Suc n) - m + Suc n + 4 + m"
+    using `m \<le> n` by simp
+  also have "... = n + Suc (Suc n) + Suc n + 4"
+    using `m \<le> n` by simp
+  also have "... = 3 * n + 7"
+    by simp
+  also have "... = ttt"
+    using assms by simp
+  finally have "n + Suc (Suc n - canlen ?zs) + Suc n + 2 + m + 2 = ttt" .
+  then show ?thesis
+    using tm4 by simp
+qed
+
+definition "tps4' \<equiv> tps0
+  [j2 := (\<lfloor>x + y\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4'':
+  assumes "ttt = 3 * max (nlength x) (nlength y) + 10"
+  shows "transforms tm4 tps0 ttt tps4'"
+proof -
+  have "canrepr (num xs + num ys) = canrepr (x + y)"
+    by (simp add: canrepr)
+  then show ?thesis
+    using assms tps0(1) tps4'_def tps4_def tm4' by (metis list_update_id)
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_addI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes x y k ttt :: nat and tps tps' :: "tape list"
+  assumes "j1 \<noteq> j2" "j1 < k" "j2 < k" "j2 > 0" "k = length tps"
+  assumes
+    "tps ! j1 = (\<lfloor>canrepr x\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>canrepr y\<rfloor>, 1)"
+  assumes "ttt = 3 * max (nlength x) (nlength y) + 10"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>x + y\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_add j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_add j1 j2 .
+  show ?thesis
+    using loc.tm4_eq_tm_add loc.tps4'_def loc.tm4'' assms by simp
+qed
+
+
+subsection \<open>Multiplication\<close>
+
+text \<open>
+In this section we construct a Turing machine that multiplies two numbers, each
+on its own tape, and writes the result to another tape. It employs the common
+algorithm for multiplication, which for binary numbers requires only doubling a
+number and adding two numbers. For the latter we already have a TM; for the
+former we are going to construct one.
+\<close>
+
+
+subsubsection \<open>The common algorithm\<close>
+
+text \<open>
+For two numbers given as symbol sequences @{term xs} and @{term ys}, the common
+algorithm maintains an intermediate result, initialized with 0, and scans @{term
+xs} starting from the most significant digit. In each step the intermediate
+result is multiplied by two, and if the current digit of @{term xs} is @{text
+\<one>}, the value of @{term ys} is added to the intermediate result.
+\<close>
+
+fun prod :: "symbol list \<Rightarrow> symbol list \<Rightarrow> nat \<Rightarrow> nat" where
+  "prod xs ys 0 = 0" |
+  "prod xs ys (Suc i) = 2 * prod xs ys i + (if xs ! (length xs - 1 - i) = 3 then num ys else 0)"
+
+text \<open>
+After $i$ steps of the algorithm, the intermediate result is the product of @{term ys}
+and the $i$ most significant bits of @{term xs}.
+\<close>
+
+lemma prod:
+  assumes "i \<le> length xs"
+  shows "prod xs ys i = num (drop (length xs - i) xs) * num ys"
+  using assms
+proof (induction i)
+  case 0
+  then show ?case
+    using num_def by simp
+next
+  case (Suc i)
+  then have "i < length xs"
+    by simp
+  then have "drop (length xs - Suc i) xs = (xs ! (length xs - 1 - i)) # drop (length xs - i) xs"
+    by (metis Cons_nth_drop_Suc Suc_diff_Suc diff_Suc_eq_diff_pred
+      diff_Suc_less gr_implies_not0 length_greater_0_conv list.size(3))
+  then show ?case
+    using num_Cons Suc by simp
+qed
+
+text \<open>
+After @{term "length xs"} steps, the intermediate result is the final result:
+\<close>
+
+corollary prod_eq_prod: "prod xs ys (length xs) = num xs * num ys"
+  using prod by simp
+
+definition prod' :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
+  "prod' x y i \<equiv> prod (canrepr x) (canrepr y) i"
+
+lemma prod': "prod' x y (nlength x) = x * y"
+  using prod_eq_prod prod'_def by (simp add: canrepr)
+
+
+subsubsection \<open>Multiplying by two\<close>
+
+text \<open>
+Since we represent numbers with the least significant bit at the left, a
+multiplication by two is a right shift with a \textbf{0} inserted as the least
+significant digit. The next command implements the right shift. It scans the
+tape $j$ and memorizes the current symbol on the last tape. It only writes the
+symbols \textbf{0} and \textbf{1}.
+\<close>
+
+definition cmd_double :: "tapeidx \<Rightarrow> command" where
+  "cmd_double j rs \<equiv>
+    (if rs ! j = \<box> then 1 else 0,
+     (map (\<lambda>i.
+       if i = j then
+         if last rs = \<triangleright> \<and> rs ! j = \<box> then (rs ! i, Right)
+         else (tosym (todigit (last rs)), Right)
+       else if i = length rs - 1 then (tosym (todigit (rs ! j)), Stay)
+       else (rs ! i, Stay)) [0..<length rs]))"
+
+lemma turing_command_double:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "j > 0" and "j < k - 1"
+  shows "turing_command k 1 G (cmd_double j)"
+proof
+  show "\<And>gs. length gs = k \<Longrightarrow> length ([!!] cmd_double j gs) = length gs"
+    using cmd_double_def by simp
+  show "\<And>gs. length gs = k \<Longrightarrow> 0 < k \<Longrightarrow> cmd_double j gs [.] 0 = gs ! 0"
+    using assms cmd_double_def by simp
+  show "cmd_double j gs [.] j' < G"
+    if "length gs = k" "\<And>i. i < length gs \<Longrightarrow> gs ! i < G" "j' < length gs"
+    for j' gs
+  proof -
+    consider "j' = j" | "j' = k - 1" | "j' \<noteq> j \<and> j' \<noteq> k - 1"
+      by auto
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "cmd_double j gs [!] j' =
+         (if last gs = \<triangleright> \<and> gs ! j = \<box> then (gs ! j, Right)
+          else (tosym (todigit (last gs)), Right))"
+        using cmd_double_def assms(1,4) that(1) by simp
+      then have "cmd_double j gs [.] j' =
+         (if last gs = \<triangleright> \<and> gs ! j = \<box> then gs ! j else tosym (todigit (last gs)))"
+        by simp
+      then show ?thesis
+        using that assms by simp
+    next
+      case 2
+      then have "cmd_double j gs [!] j' = (tosym (todigit (gs ! j)), Stay)"
+        using cmd_double_def assms(1,4) that(1) by simp
+      then show ?thesis
+        using assms by simp
+    next
+      case 3
+      then show ?thesis
+        using cmd_double_def assms that by simp
+    qed
+  qed
+  show "\<And>gs. length gs = k \<Longrightarrow> [*] (cmd_double j gs) \<le> 1"
+    using assms cmd_double_def by simp
+qed
+
+lemma sem_cmd_double_0:
+  assumes "j < k"
+    and "bit_symbols xs"
+    and "i \<le> length xs"
+    and "i > 0"
+    and "length tps = Suc k"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, i)"
+    and "tps ! k = \<lceil>z\<rceil>"
+    and "tps' = tps [j := tps ! j |:=| tosym (todigit z) |+| 1, k := \<lceil>xs ! (i - 1)\<rceil>]"
+  shows "sem (cmd_double j) (0, tps) = (0, tps')"
+proof (rule semI)
+  show "proper_command (Suc k) (cmd_double j)"
+    using cmd_double_def by simp
+  show "length tps = Suc k"
+    using assms(5) .
+  show "length tps' = Suc k"
+    using assms(5,8) by simp
+  show "fst (cmd_double j (read tps)) = 0"
+    using assms contents_def cmd_double_def tapes_at_read'[of j tps]
+    by (smt (verit, del_insts) One_nat_def Suc_le_lessD Suc_le_mono Suc_pred fst_conv
+      less_imp_le_nat snd_conv zero_neq_numeral)
+  show "act (cmd_double j (read tps) [!] j') (tps ! j') = tps' ! j'"
+      if "j' < Suc k" for j'
+  proof -
+    define rs where "rs = read tps"
+    then have rsj: "rs ! j = xs ! (i - 1)"
+      using assms tapes_at_read' contents_inbounds
+      by (metis fst_conv le_imp_less_Suc less_imp_le_nat snd_conv)
+    then have rs23: "rs ! j = \<zero> \<or> rs ! j = \<one>"
+      using assms by simp
+    have lenrs: "length rs = Suc k"
+      by (simp add: rs_def assms(5) read_length)
+    consider "j' = j" | "j' = k" | "j' \<noteq> j \<and> j' \<noteq> k"
+      by auto
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "j' < length rs"
+        using lenrs that by simp
+      then have "cmd_double j rs [!] j' =
+         (if last rs = \<triangleright> \<and> rs ! j = \<box> then (rs ! j, Right)
+          else (tosym (todigit (last rs)), Right))"
+        using cmd_double_def that 1 by simp
+      then have "cmd_double j rs [!] j' = (tosym (todigit (last rs)), Right)"
+        using rs23 lenrs assms by auto
+      moreover have "last rs = z"
+        using lenrs assms(5,7) rs_def onesie_read[of z] tapes_at_read'[of _ tps]
+        by (metis diff_Suc_1 last_conv_nth length_0_conv lessI old.nat.distinct(2))
+      ultimately show ?thesis
+        using act_Right' rs_def 1 assms(1,5,8) by simp
+    next
+      case 2
+      then have "j' = length rs - 1" "j' \<noteq> j" "j' < length rs"
+        using lenrs that assms(1) by simp_all
+      then have "(cmd_double j rs) [!] j' = (tosym (todigit (rs ! j)), Stay)"
+        using cmd_double_def by simp
+      then have "(cmd_double j rs) [!] j' = (xs ! (i - 1), Stay)"
+        using rsj rs23 by auto
+      then show ?thesis
+        using act_onesie rs_def 2 assms that by simp
+    next
+      case 3
+      then have "j' \<noteq> length rs - 1" "j' \<noteq> j" "j' < length rs"
+        using lenrs that by simp_all
+      then have "(cmd_double j rs) [!] j' = (rs ! j', Stay)"
+        using cmd_double_def by simp
+      then show ?thesis
+        using act_Stay rs_def assms that 3 by simp
+    qed
+  qed
+qed
+
+lemma sem_cmd_double_1:
+  assumes "j < k"
+    and "bit_symbols xs"
+    and "i > length xs"
+    and "length tps = Suc k"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, i)"
+    and "tps ! k = \<lceil>z\<rceil>"
+    and "tps' = tps
+      [j := tps ! j |:=| (if z = \<triangleright> then \<box> else tosym (todigit z)) |+| 1,
+       k := \<lceil>\<zero>\<rceil>]"
+  shows "sem (cmd_double j) (0, tps) = (1, tps')"
+proof (rule semI)
+  show "proper_command (Suc k) (cmd_double j)"
+    using cmd_double_def by simp
+  show "length tps = Suc k"
+    using assms(4) .
+  show "length tps' = Suc k"
+    using assms(4,7) by simp
+  show "fst (cmd_double j (read tps)) = 1"
+    using assms contents_def cmd_double_def tapes_at_read'[of j tps] by simp
+  have "j < length tps"
+    using assms by simp
+  show "act (cmd_double j (read tps) [!] j') (tps ! j') = tps' ! j'"
+      if "j' < Suc k" for j'
+  proof -
+    define rs where "rs = read tps"
+    then have rsj: "rs ! j = \<box>"
+      using tapes_at_read'[OF `j < length tps`] assms(1,3,4,5) by simp
+    have lenrs: "length rs = Suc k"
+      by (simp add: rs_def assms(4) read_length)
+    consider "j' = j" | "j' = k" | "j' \<noteq> j \<and> j' \<noteq> k"
+      by auto
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "j' < length rs"
+        using lenrs that by simp
+      then have "cmd_double j rs [!] j' =
+         (if last rs = \<triangleright> \<and> rs ! j = \<box> then (rs ! j, Right)
+          else (tosym (todigit (last rs)), Right))"
+        using cmd_double_def that 1 by simp
+      moreover have "last rs = z"
+        using assms onesie_read rs_def tapes_at_read'
+        by (metis diff_Suc_1 last_conv_nth length_0_conv lenrs lessI nat.simps(3))
+      ultimately have "cmd_double j rs [!] j' =
+         (if z = \<triangleright> then (\<box>, Right) else (tosym (todigit z), Right))"
+        using rsj 1 by simp
+      then show ?thesis
+        using act_Right' rs_def 1 assms(1,4,7) by simp
+    next
+      case 2
+      then have "j' = length rs - 1" "j' \<noteq> j" "j' < length rs"
+        using lenrs that assms(1) by simp_all
+      then have "(cmd_double j rs) [!] j' = (tosym (todigit (rs ! j)), Stay)"
+        using cmd_double_def by simp
+      then have "(cmd_double j rs) [!] j' = (2, Stay)"
+        using rsj by auto
+      then show ?thesis
+        using act_onesie rs_def 2 assms that by simp
+    next
+      case 3
+      then have "j' \<noteq> length rs - 1" "j' \<noteq> j" "j' < length rs"
+        using lenrs that by simp_all
+      then have "(cmd_double j rs) [!] j' = (rs ! j', Stay)"
+        using cmd_double_def by simp
+      then show ?thesis
+        using act_Stay rs_def assms that 3 by simp
+    qed
+  qed
+qed
+
+text \<open>
+The next Turing machine consists just of the command @{const cmd_double}.
+\<close>
+
+definition tm_double :: "tapeidx \<Rightarrow> machine" where
+  "tm_double j \<equiv> [cmd_double j]"
+
+lemma tm_double_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "j > 0" and "j < k - 1"
+  shows "turing_machine k G (tm_double j)"
+  using assms tm_double_def turing_command_double by auto
+
+lemma execute_tm_double_0:
+  assumes "j < k"
+    and "bit_symbols xs"
+    and "length xs > 0"
+    and "length tps = Suc k"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, 1)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "t \<ge> 1"
+    and "t \<le> length xs"
+  shows "execute (tm_double j) (0, tps) t =
+    (0, tps [j := (\<lfloor>\<zero> # take (t - 1) xs @ drop t xs\<rfloor>, Suc t), k := \<lceil>xs ! (t - 1)\<rceil>])"
+  using assms(7,8)
+proof (induction t rule: nat_induct_at_least)
+  case base
+  have "execute (tm_double j) (0, tps) 1 = exe (tm_double j) (execute (tm_double j) (0, tps) 0)"
+    by simp
+  also have "... = sem (cmd_double j) (execute (tm_double j) (0, tps) 0)"
+    using tm_double_def exe_lt_length by simp
+  also have "... = sem (cmd_double j) (0, tps)"
+    by simp
+  also have "... = (0, tps [j := tps ! j |:=| tosym (todigit 1) |+| 1, k := \<lceil>xs ! (1 - 1)\<rceil>])"
+    using assms(7,8) sem_cmd_double_0[OF assms(1-2) _ _ assms(4,5,6)] by simp
+  also have "... = (0, tps [j := (\<lfloor>\<zero> # take (1 - 1) xs @ drop 1 xs\<rfloor>, Suc 1), k := \<lceil>xs ! (1 - 1)\<rceil>])"
+  proof -
+    have "tps ! j |:=| tosym (todigit 1) |+| 1 = (\<lfloor>xs\<rfloor>, 1) |:=| tosym (todigit 1) |+| 1"
+      using assms(5) by simp
+    also have "... = (\<lfloor>xs\<rfloor>(1 := tosym (todigit 1)), Suc 1)"
+      by simp
+    also have "... = (\<lfloor>xs\<rfloor>(1 := \<zero>), Suc 1)"
+      by auto
+    also have "... = (\<lfloor>\<zero> # drop 1 xs\<rfloor>, Suc 1)"
+    proof -
+      have "\<lfloor>\<zero> # drop 1 xs\<rfloor> = \<lfloor>xs\<rfloor>(1 := \<zero>)"
+      proof
+        fix i :: nat
+        consider "i = 0" | "i = 1" | "i > 1 \<and> i \<le> length xs" | "i > length xs"
+          by linarith
+        then show "\<lfloor>\<zero> # drop 1 xs\<rfloor> i = (\<lfloor>xs\<rfloor>(1 := \<zero>)) i"
+        proof (cases)
+          case 1
+          then show ?thesis
+            by simp
+        next
+          case 2
+          then show ?thesis
+            by simp
+        next
+          case 3
+          then have "\<lfloor>\<zero> # drop 1 xs\<rfloor> i = (\<zero> # drop 1 xs) ! (i - 1)"
+            using assms(3) by simp
+          also have "... = (drop 1 xs) ! (i - 2)"
+            using 3 by (metis Suc_1 diff_Suc_eq_diff_pred nth_Cons_pos zero_less_diff)
+          also have "... = xs ! (Suc (i - 2))"
+            using 3 assms(5) by simp
+          also have "... = xs ! (i - 1)"
+            using 3 by (metis Suc_1 Suc_diff_Suc)
+          also have "... = \<lfloor>xs\<rfloor> i"
+            using 3 by simp
+          also have "... = (\<lfloor>xs\<rfloor>(1 := \<zero>)) i"
+            using 3 by simp
+          finally show ?thesis .
+        next
+          case 4
+          then show ?thesis
+            by simp
+        qed
+      qed
+      then show ?thesis
+        by simp
+    qed
+    also have "... = (\<lfloor>\<zero> # take (1 - 1) xs @ drop 1 xs\<rfloor>, Suc 1)"
+      by simp
+    finally show ?thesis
+      by auto
+  qed
+  finally show ?case .
+next
+  case (Suc t)
+  let ?xs = "\<zero> # take (t - 1) xs @ drop t xs"
+  let ?z = "xs ! (t - 1)"
+  let ?tps = "tps
+     [j := (\<lfloor>?xs\<rfloor>, Suc t),
+      k := \<lceil>?z\<rceil>]"
+  have lenxs: "length ?xs = length xs"
+    using Suc by simp
+  have 0: "?xs ! t = xs ! t"
+  proof -
+    have "t > 0"
+      using Suc by simp
+    then have "length (\<zero> # take (t - 1) xs) = t"
+      using Suc by simp
+    moreover have "length (drop t xs) > 0"
+      using Suc by simp
+    moreover have "drop t xs ! 0 = xs ! t"
+      using Suc by simp
+    ultimately have "((\<zero> # take (t - 1) xs) @ drop t xs) ! t = xs ! t"
+      by (metis diff_self_eq_0 less_not_refl3 nth_append)
+    then show ?thesis
+      by simp
+  qed
+  have 1: "bit_symbols ?xs"
+  proof -
+    have "bit_symbols (take (t - 1) xs)"
+      using assms(2) by simp
+    moreover have "bit_symbols (drop t xs)"
+      using assms(2) by simp
+    moreover have "bit_symbols [\<zero>]"
+      by simp
+    ultimately have "bit_symbols ([\<zero>] @ take (t - 1) xs @ drop t xs)"
+      using bit_symbols_append by presburger
+    then show ?thesis
+      by simp
+  qed
+  have 2: "Suc t \<le> length ?xs"
+    using Suc by simp
+  have 3: "Suc t > 0"
+    using Suc by simp
+  have 4: "length ?tps = Suc k"
+    using assms by simp
+  have 5: "?tps ! j = (\<lfloor>?xs\<rfloor>, Suc t)"
+    by (simp add: Suc_lessD assms(1,4) nat_neq_iff)
+  have 6: "?tps ! k = \<lceil>?z\<rceil>"
+    by (simp add: assms(4))
+  have "execute (tm_double j) (0, tps) (Suc t) = exe (tm_double j) (execute (tm_double j) (0, tps) t)"
+    by simp
+  also have "... = sem (cmd_double j) (execute (tm_double j) (0, tps) t)"
+    using tm_double_def exe_lt_length Suc by simp
+  also have "... = sem (cmd_double j) (0, ?tps)"
+    using Suc by simp
+  also have "... = (0, ?tps [j := ?tps ! j |:=| tosym (todigit ?z) |+| 1, k := \<lceil>?xs ! (Suc t - 1)\<rceil>])"
+    using sem_cmd_double_0[OF assms(1) 1 2 3 4 5 6] by simp
+  also have "... = (0, ?tps [j := ?tps ! j |:=| tosym (todigit ?z) |+| 1, k := \<lceil>xs ! (Suc t - 1)\<rceil>])"
+    using 0 by simp
+  also have "... = (0, tps [j := ?tps ! j |:=| tosym (todigit ?z) |+| 1, k := \<lceil>xs ! (Suc t - 1)\<rceil>])"
+    using assms by (smt (z3) list_update_overwrite list_update_swap)
+  also have "... = (0, tps [j := (\<lfloor>?xs\<rfloor>, Suc t) |:=| tosym (todigit ?z) |+| 1, k := \<lceil>xs ! (Suc t - 1)\<rceil>])"
+    using 5 by simp
+  also have "... = (0, tps
+      [j := (\<lfloor>?xs\<rfloor>(Suc t := tosym (todigit ?z)), Suc (Suc t)),
+       k := \<lceil>xs ! (Suc t - 1)\<rceil>])"
+    by simp
+  also have "... = (0, tps
+      [j := (\<lfloor>2 # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor>, Suc (Suc t)),
+       k := \<lceil>xs ! (Suc t - 1)\<rceil>])"
+  proof -
+    have "\<lfloor>?xs\<rfloor>(Suc t := tosym (todigit ?z)) = \<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor>"
+    proof
+      fix i :: nat
+      consider "i = 0" | "i > 0 \<and> i < Suc t" | "i = Suc t" | "i > Suc t \<and> i \<le> length xs" | "i > length xs"
+        by linarith
+      then show "(\<lfloor>?xs\<rfloor>(Suc t := tosym (todigit ?z))) i = \<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor> i"
+      proof (cases)
+        case 1
+        then show ?thesis
+          by simp
+      next
+        case 2
+        then have lhs: "(\<lfloor>?xs\<rfloor>(Suc t := tosym (todigit ?z))) i = ?xs ! (i - 1)"
+          using lenxs Suc by simp
+        have "\<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor> i =
+            (\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs) ! (i - 1)"
+          using Suc 2 by auto
+        then have "\<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor> i =
+            ((\<zero> # take (Suc t - 1) xs) @ drop (Suc t) xs) ! (i - 1)"
+          by simp
+        moreover have "length (\<zero> # take (Suc t - 1) xs) = Suc t"
+          using Suc.prems by simp
+        ultimately have "\<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor> i =
+            (\<zero> # take (Suc t - 1) xs) ! (i - 1)"
+          using 2 by (metis Suc_diff_1 Suc_lessD nth_append)
+        also have "... = (\<zero> # take t xs) ! (i - 1)"
+          by simp
+        also have "... = (\<zero> # take (t - 1) xs @ [xs ! (t - 1)]) ! (i - 1)"
+          using Suc by (metis Suc_diff_le Suc_le_lessD Suc_lessD diff_Suc_1 take_Suc_conv_app_nth)
+        also have "... = ((\<zero> # take (t - 1) xs) @ [xs ! (t - 1)]) ! (i - 1)"
+          by simp
+        also have "... = (\<zero> # take (t - 1) xs) ! (i - 1)"
+          using 2 Suc
+          by (metis One_nat_def Suc_leD Suc_le_eq Suc_pred length_Cons length_take less_Suc_eq_le
+            min_absorb2 nth_append)
+        also have "... = ((\<zero> # take (t - 1) xs) @ drop t xs) ! (i - 1)"
+          using 2 Suc
+          by (metis Suc_diff_1 Suc_diff_le Suc_leD Suc_lessD diff_Suc_1 length_Cons length_take
+            less_Suc_eq min_absorb2 nth_append)
+        also have "... = ?xs ! (i - 1)"
+          by simp
+        finally have "\<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor> i = ?xs ! (i - 1)" .
+        then show ?thesis
+          using lhs by simp
+      next
+        case 3
+        moreover have "?z = \<zero> \<or> ?z = \<one>"
+          using `bit_symbols ?xs` Suc assms(2) by (metis Suc_diff_le Suc_leD Suc_le_lessD diff_Suc_1)
+        ultimately have lhs: "(\<lfloor>?xs\<rfloor>(Suc t := tosym (todigit ?z))) i = ?z"
+          by auto
+        have "\<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor> i =
+            \<lfloor>(\<zero> # take t xs) @ drop (Suc t) xs\<rfloor> (Suc t)"
+          using 3 by simp
+        also have "... = ((\<zero> # take t xs) @ drop (Suc t) xs) ! t"
+          using 3 Suc by simp
+        also have "... = (\<zero> # take t xs) ! t"
+          using Suc by (metis Suc_leD length_Cons length_take lessI min_absorb2 nth_append)
+        also have "... = xs ! (t - 1)"
+          using Suc by simp
+        finally have "\<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor> i = ?z" .
+        then show ?thesis
+          using lhs by simp
+      next
+        case 4
+        then have "(\<lfloor>?xs\<rfloor>(Suc t := tosym (todigit ?z))) i = \<lfloor>?xs\<rfloor> i"
+          by simp
+        also have "... = ?xs ! (i - 1)"
+          using 4 by auto
+        also have "... = ((\<zero> # take (t - 1) xs) @ drop t xs) ! (i - 1)"
+          by simp
+        also have "... = drop t xs ! (i - 1 - t)"
+          using 4 Suc
+          by (smt (verit, ccfv_threshold) Cons_eq_appendI Suc_diff_1 Suc_leD
+            add_diff_cancel_right' bot_nat_0.extremum_uniqueI diff_diff_cancel
+            length_append length_drop lenxs not_le not_less_eq nth_append)
+        also have "... = xs ! (i - 1)"
+          using 4 Suc by simp
+        finally have lhs: "(\<lfloor>?xs\<rfloor>(Suc t := tosym (todigit ?z))) i = xs ! (i - 1)" .
+        have "\<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor> i =
+            (\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs) ! (i - 1)"
+          using 4 by auto
+        also have "... = ((\<zero> # take t xs) @ drop (Suc t) xs) ! (i - 1)"
+          by simp
+        also have "... = (drop (Suc t) xs) ! (i - 1 - Suc t)"
+          using Suc 4
+          by (smt (z3) Suc_diff_1 Suc_leD Suc_leI bot_nat_0.extremum_uniqueI length_Cons length_take
+            min_absorb2 not_le nth_append)
+        also have "... = xs ! (i - 1)"
+          using Suc 4 Suc_lessE by fastforce
+        finally have "\<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor> i = xs ! (i - 1)" .
+        then show ?thesis
+          using lhs by simp
+      next
+        case 5
+        then have "(\<lfloor>?xs\<rfloor>(Suc t := tosym (todigit ?z))) i = \<lfloor>?xs\<rfloor> i"
+          using Suc by simp
+        then have lhs: "(\<lfloor>?xs\<rfloor>(Suc t := tosym (todigit ?z))) i = \<box>"
+          using 5 contents_outofbounds lenxs by simp
+        have "length (\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs) = length xs"
+          using Suc by simp
+        then have "\<lfloor>\<zero> # take (Suc t - 1) xs @ drop (Suc t) xs\<rfloor> i = \<box>"
+          using 5 contents_outofbounds by simp
+        then show ?thesis
+          using lhs by simp
+      qed
+    qed
+    then show ?thesis
+      by simp
+  qed
+  finally show ?case .
+qed
+
+lemma execute_tm_double_1:
+  assumes "j < k"
+    and "bit_symbols xs"
+    and "length xs > 0"
+    and "length tps = Suc k"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, 1)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+  shows "execute (tm_double j) (0, tps) (Suc (length xs)) =
+    (1, tps [j := (\<lfloor>\<zero> # xs\<rfloor>, length xs + 2), k := \<lceil>\<zero>\<rceil>])"
+proof -
+  let ?z = "xs ! (length xs - 1)"
+  let ?xs = "\<zero> # take (length xs - 1) xs"
+  have "?z \<noteq> \<triangleright>"
+    using assms(2,3) by (metis One_nat_def Suc_1 diff_less less_Suc_eq not_less_eq numeral_3_eq_3)
+  have z23: "?z = \<zero> \<or> ?z = \<one>"
+    using assms(2,3) by (meson diff_less zero_less_one)
+  have lenxs: "length ?xs = length xs"
+    using assms(3) by (metis Suc_diff_1 diff_le_self length_Cons length_take min_absorb2)
+  have 0: "bit_symbols ?xs"
+    using assms(2) bit_symbols_append[of "[\<zero>]" "take (length xs - 1) xs"] by simp
+
+  have "execute (tm_double j) (0, tps) (length xs) =
+    (0, tps
+      [j := (\<lfloor>\<zero> # take (length xs - 1) xs @ drop (length xs) xs\<rfloor>, Suc (length xs)),
+       k := \<lceil>?z\<rceil>])"
+    using execute_tm_double_0[OF assms(1-6), where ?t="length xs"] assms(3) by simp
+  then have *: "execute (tm_double j) (0, tps) (length xs) =
+    (0, tps [j := (\<lfloor>?xs\<rfloor>, Suc (length ?xs)), k := \<lceil>?z\<rceil>])"
+    (is "_ = (0, ?tps)")
+    using lenxs by simp
+
+  let ?i = "Suc (length ?xs)"
+  have 1: "?i > length ?xs"
+    by simp
+  have 2: "length ?tps = Suc k"
+    using assms(4) by simp
+  have 3: "?tps ! j = (\<lfloor>?xs\<rfloor>, ?i)"
+    using assms(1,4) by simp
+  have 4: "?tps ! k = \<lceil>?z\<rceil>"
+    using assms(4) by simp
+
+  have "execute (tm_double j) (0, tps) (Suc (length xs)) = exe (tm_double j) (0, ?tps)"
+    using * by simp
+  also have "... = sem (cmd_double j) (0, ?tps)"
+    using tm_double_def exe_lt_length by simp
+  also have "... = (1, ?tps
+      [j := ?tps ! j |:=| (if ?z = \<triangleright> then \<box> else tosym (todigit ?z)) |+| 1,
+       k := \<lceil>\<zero>\<rceil>])"
+    using sem_cmd_double_1[OF assms(1) 0 1 2 3 4] by simp
+  also have "... = (1, ?tps
+      [j := ?tps ! j |:=| (tosym (todigit ?z)) |+| 1,
+       k := \<lceil>\<zero>\<rceil>])"
+    using `?z \<noteq> 1` by simp
+  also have "... = (1, ?tps
+      [j := (\<lfloor>?xs\<rfloor>, Suc (length ?xs)) |:=| (tosym (todigit ?z)) |+| 1,
+       k := \<lceil>\<zero>\<rceil>])"
+    using 3 by simp
+  also have "... = (1, ?tps
+      [j := (\<lfloor>?xs\<rfloor>, Suc (length ?xs)) |:=| ?z |+| 1,
+       k := \<lceil>\<zero>\<rceil>])"
+    using z23 One_nat_def Suc_1 add_2_eq_Suc' numeral_3_eq_3 by presburger
+  also have "... = (1, tps
+      [j := (\<lfloor>?xs\<rfloor>, Suc (length ?xs)) |:=| ?z |+| 1,
+       k := \<lceil>\<zero>\<rceil>])"
+    by (smt (z3) list_update_overwrite list_update_swap)
+  also have "... = (1, tps
+      [j := (\<lfloor>?xs\<rfloor>(Suc (length ?xs) := ?z), length ?xs + 2),
+       k := \<lceil>\<zero>\<rceil>])"
+    by simp
+  also have "... = (1, tps
+      [j := (\<lfloor>?xs\<rfloor>(Suc (length ?xs) := ?z), length xs + 2),
+       k := \<lceil>\<zero>\<rceil>])"
+    using lenxs by simp
+  also have "... = (1, tps [j := (\<lfloor>\<zero> # xs\<rfloor>, length xs + 2), k := \<lceil>\<zero>\<rceil>])"
+  proof -
+    have "\<lfloor>?xs\<rfloor>(Suc (length ?xs) := ?z) = \<lfloor>\<zero> # xs\<rfloor>"
+    proof
+      fix i
+      consider "i = 0" | "i > 0 \<and> i \<le> length xs" | "i = Suc (length xs)" | "i > Suc (length xs)"
+        by linarith
+      then show "(\<lfloor>?xs\<rfloor>(Suc (length ?xs) := ?z)) i = \<lfloor>\<zero> # xs\<rfloor> i"
+      proof (cases)
+        case 1
+        then show ?thesis
+          by simp
+      next
+        case 2
+        then have "(\<lfloor>?xs\<rfloor>(Suc (length ?xs) := ?z)) i = \<lfloor>?xs\<rfloor> i"
+          using lenxs by simp
+        also have "... = ?xs ! (i - 1)"
+          using 2 by auto
+        also have "... = (\<zero> # xs) ! (i - 1)"
+          using lenxs 2 assms(3) by (metis Suc_diff_1 Suc_le_lessD nth_take take_Suc_Cons)
+        also have "... = \<lfloor>\<zero> # xs\<rfloor> i"
+          using 2 by simp
+        finally show ?thesis .
+      next
+        case 3
+        then have lhs: "(\<lfloor>?xs\<rfloor>(Suc (length ?xs) := ?z)) i = ?z"
+          using lenxs by simp
+        have "\<lfloor>\<zero> # xs\<rfloor> i = (\<zero> # xs) ! (i - 1)"
+          using 3 lenxs by simp
+        also have "... = xs ! (i - 2)"
+          using 3 assms(3) by simp
+        also have "... = ?z"
+          using 3 by simp
+        finally have "\<lfloor>\<zero> # xs\<rfloor> i = ?z" .
+        then show ?thesis
+          using lhs by simp
+      next
+        case 4
+        then show ?thesis
+          using 4 lenxs by simp
+      qed
+    qed
+    then show ?thesis
+      by simp
+  qed
+  finally show ?thesis .
+qed
+
+lemma execute_tm_double_Nil:
+  assumes "j < k"
+    and "length tps = Suc k"
+    and "tps ! j = (\<lfloor>[]\<rfloor>, 1)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+  shows "execute (tm_double j) (0, tps) (Suc 0) =
+    (1, tps [j := (\<lfloor>[]\<rfloor>, 2), k := \<lceil>\<zero>\<rceil>])"
+proof -
+  have "execute (tm_double j) (0, tps) (Suc 0) = exe (tm_double j) (execute (tm_double j) (0, tps) 0)"
+    by simp
+  also have "... = exe (tm_double j) (0, tps)"
+    by simp
+  also have "... = sem (cmd_double j) (0, tps)"
+    using tm_double_def exe_lt_length by simp
+  also have "... = (1, tps
+      [j := tps ! j |:=| (if (1::nat) = 1 then 0 else tosym (todigit 1)) |+| 1,
+       k := \<lceil>\<zero>\<rceil>])"
+    using sem_cmd_double_1[OF assms(1) _ _ assms(2-4)] by simp
+  also have "... = (1, tps [j := tps ! j |:=| \<box> |+| 1, k := \<lceil>\<zero>\<rceil>])"
+    by simp
+  also have "... = (1, tps [j := (\<lfloor>[]\<rfloor>, 1) |:=| \<box> |+| 1, k := \<lceil>\<zero>\<rceil>])"
+    using assms(3) by simp
+  also have "... = (1, tps [j := (\<lfloor>[]\<rfloor>(1 := \<box>), 2), k := \<lceil>\<zero>\<rceil>])"
+    by (metis fst_eqD one_add_one snd_eqD)
+  also have "... = (1, tps [j := (\<lfloor>[]\<rfloor>, 2), k := \<lceil>\<zero>\<rceil>])"
+    by (metis contents_outofbounds fun_upd_idem_iff list.size(3) zero_less_one)
+  finally show ?thesis .
+qed
+
+lemma execute_tm_double:
+  assumes "j < k"
+    and "length tps = Suc k"
+    and "tps ! j = (\<lfloor>canrepr n\<rfloor>, 1)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+  shows "execute (tm_double j) (0, tps) (Suc (length (canrepr n))) =
+    (1, tps [j := (\<lfloor>canrepr (2 * n)\<rfloor>, length (canrepr n) + 2), k := \<lceil>\<zero>\<rceil>])"
+proof (cases "n = 0")
+  case True
+  then have "canrepr n = []"
+    using canrepr_0 by simp
+  then show ?thesis
+    using execute_tm_double_Nil[OF assms(1-2) _ assms(4)] assms(3) True
+    by (metis add_2_eq_Suc' list.size(3) mult_0_right numeral_2_eq_2)
+next
+  case False
+  let ?xs = "canrepr n"
+  have "num (\<zero> # ?xs) = 2 * num ?xs"
+    using num_Cons by simp
+  then have "num (\<zero> # ?xs) = 2 * n"
+    using canrepr by simp
+  moreover have "canonical (\<zero> # ?xs)"
+  proof -
+    have "?xs \<noteq> []"
+      using False canrepr canrepr_0 by metis
+    then show ?thesis
+      using canonical_Cons canonical_canrepr by simp
+  qed
+  ultimately have "canrepr (2 * n) = \<zero> # ?xs"
+    using canreprI by blast
+  then show ?thesis
+    using execute_tm_double_1[OF assms(1) _ _ assms(2) _ assms(4)] assms(3) False canrepr canrepr_0 bit_symbols_canrepr
+    by (metis length_greater_0_conv)
+qed
+
+lemma execute_tm_double_app:
+  assumes "j < k"
+    and "length tps = k"
+    and "tps ! j = (\<lfloor>canrepr n\<rfloor>, 1)"
+  shows "execute (tm_double j) (0, tps @ [\<lceil>\<triangleright>\<rceil>]) (Suc (length (canrepr n))) =
+    (1, tps [j := (\<lfloor>canrepr (2 * n)\<rfloor>, length (canrepr n) + 2)] @ [\<lceil>\<zero>\<rceil>])"
+proof -
+  let ?tps = "tps @ [\<lceil>\<triangleright>\<rceil>]"
+  have "length ?tps = Suc k"
+    using assms(2) by simp
+  moreover have "?tps ! j = (\<lfloor>canrepr n\<rfloor>, 1)"
+    using assms(1,2,3) by (simp add: nth_append)
+  moreover have "?tps ! k = \<lceil>\<triangleright>\<rceil>"
+    using assms(2) by (simp add: nth_append)
+  moreover have "tps [j := (\<lfloor>canrepr (2 * n)\<rfloor>, length (canrepr n) + 2)] @ [\<lceil>\<zero>\<rceil>] =
+      ?tps [j := (\<lfloor>canrepr (2 * n)\<rfloor>, length (canrepr n) + 2), k := \<lceil>\<zero>\<rceil>]"
+    using assms by (metis length_list_update list_update_append1 list_update_length)
+  ultimately show ?thesis
+    using assms execute_tm_double[OF assms(1), where ?tps="tps @ [\<lceil>\<triangleright>\<rceil>]"]
+    by simp
+qed
+
+lemma transforms_tm_double:
+  assumes "j < k"
+    and "length tps = k"
+    and "tps ! j = (\<lfloor>canrepr n\<rfloor>, 1)"
+  shows "transforms (tm_double j)
+    (tps @ [\<lceil>\<triangleright>\<rceil>])
+    (Suc (length (canrepr n)))
+    (tps [j := (\<lfloor>canrepr (2 * n)\<rfloor>, length (canrepr n) + 2)] @ [\<lceil>\<zero>\<rceil>])"
+  using assms transforms_def transits_def tm_double_def execute_tm_double_app by auto
+
+lemma tm_double_immobile:
+  fixes k :: nat
+  assumes "j > 0" and "j < k"
+  shows "immobile (tm_double j) k (Suc k)"
+proof -
+  let ?M = "tm_double j"
+  { fix q :: nat and rs :: "symbol list"
+    assume q: "q < length ?M"
+    assume rs: "length rs = Suc k"
+    then have len: "length rs - 1 = k"
+      by simp
+    have neq: "k \<noteq> j"
+      using assms(2) by simp
+    have "?M ! q = cmd_double j"
+      using tm_double_def q by simp
+    moreover have "(cmd_double j) rs [!] k = (tosym (todigit (rs ! j)), Stay)"
+      using cmd_double_def rs len neq by fastforce
+    ultimately have "(cmd_double j) rs [~] k = Stay"
+      by simp
+  }
+  then show ?thesis
+    by (simp add: immobile_def tm_double_def)
+qed
+
+lemma tm_double_bounded_write:
+  assumes "j < k - 1"
+  shows "bounded_write (tm_double j) (k - 1) 4"
+  using assms cmd_double_def tm_double_def bounded_write_def by simp
+
+text \<open>
+The next Turing machine removes the memorization tape.
+\<close>
+
+definition tm_double' :: "nat \<Rightarrow> machine" where
+  "tm_double' j \<equiv> cartesian (tm_double j) 4"
+
+lemma tm_double'_tm:
+  assumes "j > 0" and "k \<ge> 2" and "G \<ge> 4" and "j < k"
+  shows "turing_machine k G (tm_double' j)"
+  unfolding tm_double'_def using assms cartesian_tm tm_double_tm by simp
+
+lemma transforms_tm_double'I [transforms_intros]:
+  assumes "j > 0" and "j < k"
+    and "length tps = k"
+    and "tps ! j = (\<lfloor>canrepr n\<rfloor>, 1)"
+    and "t = (Suc (length (canrepr n)))"
+    and "tps' = tps [j := (\<lfloor>canrepr (2 * n)\<rfloor>, length (canrepr n) + 2)]"
+  shows "transforms (tm_double' j) tps t tps'"
+  unfolding tm_double'_def
+proof (rule cartesian_transforms_onesie)
+  show "turing_machine (Suc k) 4 (tm_double j)"
+    using assms(1,2) tm_double_tm by simp
+  show "length tps = k" "2 \<le> k" "(1::nat) < 4"
+    using assms by simp_all
+  show "bounded_write (tm_double j) k 4"
+    by (metis assms(2) diff_Suc_1 tm_double_bounded_write)
+  show "immobile (tm_double j) k (Suc k)"
+    by (simp add: assms(1,2) tm_double_immobile)
+  show "transforms (tm_double j) (tps @ [\<lceil>\<triangleright>\<rceil>]) t (tps' @ [\<lceil>\<zero>\<rceil>])"
+    using assms transforms_tm_double by simp
+qed
+
+text \<open>
+The next Turing machine is the one we actually use to double a number. It runs
+@{const tm_double'} and performs a carriage return.
+\<close>
+
+definition tm_times2 :: "tapeidx \<Rightarrow> machine" where
+  "tm_times2 j \<equiv> tm_double' j ;; tm_cr j"
+
+lemma tm_times2_tm:
+  assumes "k \<ge> 2" and "j > 0" and "j < k" and "G \<ge> 4"
+  shows "turing_machine k G (tm_times2 j)"
+  using assms by (simp add: assms(1) tm_cr_tm tm_double'_tm tm_times2_def)
+
+lemma transforms_tm_times2I [transforms_intros]:
+  assumes "j > 0" and "j < k"
+    and "length tps = k"
+    and "tps ! j = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    and "t = 5 + 2 * nlength n"
+    and "tps' = tps [j := (\<lfloor>2 * n\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_times2 j) tps t tps'"
+  unfolding tm_times2_def
+proof (tform tps: assms)
+  show "clean_tape (tps[j := (\<lfloor>2 * n\<rfloor>\<^sub>N, nlength n + 2)] ! j)"
+    using clean_tape_ncontents assms by simp
+  show "t = Suc (nlength n) + (tps[j := (\<lfloor>2 * n\<rfloor>\<^sub>N, nlength n + 2)] :#: j + 2)"
+    using assms by simp
+qed
+
+
+subsubsection \<open>Multiplying arbitrary numbers\<close>
+
+text \<open>
+Before we can multiply arbitrary numbers we need just a few more lemmas.
+
+\null
+\<close>
+
+lemma num_drop_le_nu: "num (drop j xs) \<le> num xs"
+proof (cases "j \<le> length xs")
+  case True
+  let ?ys = "drop j xs"
+  have map_shift_upt: "map (\<lambda>i. f (j + i)) [0..<l] = map f [j..<j + l]"
+      for f :: "nat \<Rightarrow> nat" and j l
+    by (rule nth_equalityI) simp_all
+
+  have "num ?ys = (\<Sum>i\<leftarrow>[0..<length ?ys]. todigit (?ys ! i) * 2 ^ i)"
+    using num_def by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<length ?ys]. todigit (xs ! (j + i)) * 2 ^ i)"
+    by (simp add: True)
+  also have "... \<le> 2 ^ j * (\<Sum>i\<leftarrow>[0..<length ?ys].  todigit (xs ! (j + i)) * 2 ^ i)"
+    by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<length ?ys]. 2 ^ j * todigit (xs ! (j + i)) * 2 ^ i)"
+    by (simp add: mult.assoc sum_list_const_mult)
+  also have "... = (\<Sum>i\<leftarrow>[0..<length ?ys]. todigit (xs ! (j + i)) * 2 ^ (j + i))"
+    by (simp add: ab_semigroup_mult_class.mult_ac(1) mult.commute power_add)
+  also have "... = (\<Sum>i\<leftarrow>[j..<j + length ?ys]. todigit (xs ! i) * 2 ^ i)"
+    using map_shift_upt[of "\<lambda>i. todigit (xs ! i) * 2 ^ i" j "length ?ys"] by simp
+  also have "... \<le> (\<Sum>i\<leftarrow>[0..<j]. todigit (xs ! i) * 2 ^ i) +
+      (\<Sum>i\<leftarrow>[j..<j + length ?ys]. todigit (xs ! i) * 2 ^ i)"
+    by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<j + length ?ys]. todigit (xs ! i) * 2 ^ i)"
+    by (metis (no_types, lifting) le_add2 le_add_same_cancel2 map_append sum_list.append upt_add_eq_append)
+  also have "... = (\<Sum>i\<leftarrow>[0..<length xs]. todigit (xs ! i) * 2 ^ i)"
+    by (simp add: True)
+  also have "... = num xs"
+    using num_def by simp
+  finally show ?thesis .
+next
+  case False
+  then show ?thesis
+    using canrepr canrepr_0 by (metis drop_all nat_le_linear zero_le)
+qed
+
+lemma nlength_prod_le_prod:
+  assumes "i \<le> length xs"
+  shows "nlength (prod xs ys i) \<le> nlength (num xs * num ys)"
+  using prod[OF assms] num_drop_le_nu mult_le_mono1 nlength_mono by simp
+
+corollary nlength_prod'_le_prod:
+  assumes "i \<le> nlength x"
+  shows "nlength (prod' x y i) \<le> nlength (x * y)"
+  using assms prod'_def nlength_prod_le_prod by (metis prod' prod_eq_prod)
+
+lemma two_times_prod:
+  assumes "i < length xs"
+  shows "2 * prod xs ys i \<le> num xs * num ys"
+proof -
+  have "2 * prod xs ys i \<le> prod xs ys (Suc i)"
+    by simp
+  also have "... = num (drop (length xs - Suc i) xs) * num ys"
+    using prod[of "Suc i" xs] assms by simp
+  also have "... \<le> num xs * num ys"
+    using num_drop_le_nu by simp
+  finally show ?thesis .
+qed
+
+corollary two_times_prod':
+  assumes "i < nlength x"
+  shows "2 * prod' x y i \<le> x * y"
+  using assms two_times_prod prod'_def by (metis prod' prod_eq_prod)
+
+text \<open>
+The next Turing machine multiplies the numbers on tapes $j_1$ and $j_2$ and
+writes the result to tape $j_3$. It iterates over the binary digits on $j_1$
+starting from the most significant digit. In each iteration it doubles the
+intermediate result on $j_3$. If the current digit is @{text \<one>}, the number on
+$j_2$ is added to $j_3$.
+\<close>
+
+definition tm_mult :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_mult j1 j2 j3 \<equiv>
+    tm_right_until j1 {\<box>} ;;
+    tm_left j1 ;;
+    WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<triangleright> DO
+      tm_times2 j3 ;;
+      IF \<lambda>rs. rs ! j1 = \<one> THEN
+        tm_add j2 j3
+      ELSE
+        []
+      ENDIF ;;
+      tm_left j1
+    DONE ;;
+    tm_right j1"
+
+lemma tm_mult_tm:
+  assumes "j1 \<noteq> j2" "j2 \<noteq> j3" "j3 \<noteq> j1" and "j3 > 0"
+  assumes "k \<ge> 2"
+    and "G \<ge> 4"
+    and "j1 < k" "j2 < k" "j3 < k"
+  shows "turing_machine k G (tm_mult j1 j2 j3)"
+  unfolding tm_mult_def
+  using assms tm_left_tm tm_right_tm Nil_tm tm_add_tm tm_times2_tm tm_right_until_tm
+    turing_machine_branch_turing_machine turing_machine_loop_turing_machine
+  by simp
+
+locale turing_machine_mult =
+  fixes j1 j2 j3 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_right_until j1 {\<box>}"
+definition "tm2 \<equiv> tm1 ;; tm_left j1"
+definition "tmIf \<equiv> IF \<lambda>rs. rs ! j1 = \<one> THEN tm_add j2 j3 ELSE [] ENDIF"
+definition "tmBody1 \<equiv> tm_times2 j3 ;; tmIf"
+definition "tmBody \<equiv> tmBody1 ;; tm_left j1"
+definition "tmWhile \<equiv> WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<triangleright> DO tmBody DONE"
+definition "tm3 \<equiv> tm2 ;; tmWhile"
+definition "tm4 \<equiv> tm3 ;; tm_right j1"
+
+lemma tm4_eq_tm_mult: "tm4 = tm_mult j1 j2 j3"
+  using tm1_def tm2_def tm3_def tm4_def tm_mult_def tmIf_def tmBody_def tmBody1_def tmWhile_def
+  by simp
+
+context
+  fixes x y k :: nat and tps0 :: "tape list"
+  assumes jk: "j1 \<noteq> j2" "j2 \<noteq> j3" "j3 \<noteq> j1" "j3 > 0" "j1 < k" "j2 < k" "j3 < k" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps0 ! j2 = (\<lfloor>y\<rfloor>\<^sub>N, 1)"
+    "tps0 ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0 [j1 := (\<lfloor>x\<rfloor>\<^sub>N, Suc (nlength x))]"
+
+lemma tm1 [transforms_intros]:
+  assumes "t = Suc (nlength x)"
+  shows "transforms tm1 tps0 t tps1"
+  unfolding tm1_def
+proof (tform tps: assms tps0 tps1_def jk)
+  show "rneigh (tps0 ! j1) {\<box>} (nlength x)"
+  proof (rule rneighI)
+    show "(tps0 ::: j1) (tps0 :#: j1 + nlength x) \<in> {\<box>}"
+      by (simp add: tps0)
+    show "\<And>n'. n' < nlength x \<Longrightarrow> (tps0 ::: j1) (tps0 :#: j1 + n') \<notin> {\<box>}"
+      using tps0 bit_symbols_canrepr contents_def by fastforce
+  qed
+qed
+
+definition "tps2 \<equiv> tps0 [j1 := (\<lfloor>x\<rfloor>\<^sub>N, nlength x)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "t = Suc (Suc (nlength x))" and "tps' = tps2"
+  shows "transforms tm2 tps0 t tps'"
+  unfolding tm2_def by (tform tps: assms tps1_def tps2_def jk)
+
+definition "tpsL t \<equiv> tps0
+   [j1 := (\<lfloor>x\<rfloor>\<^sub>N, nlength x - t),
+    j3 := (\<lfloor>prod' x y t\<rfloor>\<^sub>N, 1)]"
+
+definition "tpsL1 t \<equiv> tps0
+   [j1 := (\<lfloor>x\<rfloor>\<^sub>N, nlength x - t),
+    j3 := (\<lfloor>2 * prod' x y t\<rfloor>\<^sub>N, 1)]"
+
+definition "tpsL2 t \<equiv> tps0
+   [j1 := (\<lfloor>x\<rfloor>\<^sub>N, nlength x - t),
+    j3 := (\<lfloor>prod' x y (Suc t)\<rfloor>\<^sub>N, 1)]"
+
+definition "tpsL3 t \<equiv> tps0
+   [j1 := (\<lfloor>x\<rfloor>\<^sub>N, nlength x - t - 1),
+    j3 := (\<lfloor>prod' x y (Suc t)\<rfloor>\<^sub>N, 1)]"
+
+lemma tmIf [transforms_intros]:
+  assumes "t < nlength x" and "ttt = 12 + 3 * nlength (x * y)"
+  shows "transforms tmIf (tpsL1 t) ttt (tpsL2 t)"
+  unfolding tmIf_def
+proof (tform tps: assms tpsL1_def tps0 jk)
+  have "nlength y \<le> nlength (x * y) \<and> nlength (2 * prod' x y t) \<le> nlength (x * y)"
+  proof
+    have "x > 0"
+      using assms(1) gr_implies_not_zero nlength_0 by auto
+    then have "y \<le> x * y"
+      by simp
+    then show "nlength y \<le> nlength (x * y)"
+      using nlength_mono by simp
+    show "nlength (2 * prod' x y t) \<le> nlength (x * y)"
+      using assms(1) by (simp add: nlength_mono two_times_prod')
+  qed
+  then show "3 * max (nlength y) (nlength (2 * Arithmetic.prod' x y t)) + 10 + 2 \<le> ttt"
+    using assms(2) by simp
+  let ?xs = "canrepr x" and ?ys = "canrepr y"
+  let ?r = "read (tpsL1 t) ! j1"
+  have "?r = (\<lfloor>x\<rfloor>\<^sub>N) (nlength x - t)"
+    using tpsL1_def jk tapes_at_read'
+    by (metis fst_conv length_list_update list_update_swap nth_list_update_eq snd_conv)
+  then have r: "?r = canrepr x ! (nlength x - 1 - t)"
+    using assms contents_def by simp
+  have "prod' x y (Suc t) = 2 * prod' x y t + (if ?xs ! (length ?xs - 1 - t) = \<one> then num ?ys else 0)"
+    using prod'_def by simp
+  also have "... = 2 * prod' x y t + (if ?r = \<one> then num ?ys else 0)"
+    using r by simp
+  also have "... = 2 * prod' x y t + (if ?r = \<one> then y else 0)"
+    using canrepr by simp
+  finally have "prod' x y (Suc t) = 2 * prod' x y t + (if ?r = \<one> then y else 0)" .
+  then show "read (tpsL1 t) ! j1 \<noteq> \<one> \<Longrightarrow> tpsL2 t = tpsL1 t"
+       and "read (tpsL1 t) ! j1 = \<one> \<Longrightarrow>
+      tpsL2 t = (tpsL1 t) [j3 := (\<lfloor>y + 2 * Arithmetic.prod' x y t\<rfloor>\<^sub>N, 1)]"
+    by (simp_all add: add.commute tpsL1_def tpsL2_def)
+qed
+
+lemma tmBody1 [transforms_intros]:
+  assumes "t < nlength x"
+    and "ttt = 17 + 2 * nlength (Arithmetic.prod' x y t) + 3 * nlength (x * y)"
+  shows "transforms tmBody1 (tpsL t) ttt (tpsL2 t)"
+  unfolding tmBody1_def by (tform tps: jk tpsL_def tpsL1_def assms(1) time: assms(2))
+
+lemma tmBody:
+  assumes "t < nlength x"
+    and "ttt = 6 + 2 * nlength (prod' x y t) + (12 + 3 * nlength (x * y))"
+  shows "transforms tmBody (tpsL t) ttt (tpsL (Suc t))"
+  unfolding tmBody_def by (tform tps: jk tpsL_def tpsL2_def assms(1) time: assms(2))
+
+lemma tmBody' [transforms_intros]:
+  assumes "t < nlength x" and "ttt = 18 + 5 * nlength (x * y)"
+  shows "transforms tmBody (tpsL t) ttt (tpsL (Suc t))"
+proof -
+  have "6 + 2 * nlength (prod' x y t) + (12 + 3 * nlength (x * y)) \<le> 18 + 5 * nlength (x * y)"
+    using assms nlength_prod'_le_prod by simp
+  then show ?thesis
+    using tmBody assms transforms_monotone by blast
+qed
+
+lemma read_contents:
+  fixes tps :: "tape list" and j :: tapeidx and zs :: "symbol list"
+  assumes "tps ! j = (\<lfloor>zs\<rfloor>, i)" and "i > 0" and "i \<le> length zs" and "j < length tps"
+  shows "read tps ! j = zs ! (i - 1)"
+  using assms tapes_at_read' by fastforce
+
+lemma tmWhile [transforms_intros]:
+  assumes "ttt = 1 + 25 * (nlength x + nlength y) * (nlength x + nlength y)"
+  shows "transforms tmWhile (tpsL 0) ttt (tpsL (nlength x))"
+  unfolding tmWhile_def
+proof (tform)
+  show "read (tpsL i) ! j1 \<noteq> \<triangleright>" if "i < nlength x" for i
+  proof -
+    have "(tpsL i) ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, nlength x - i)"
+      using tpsL_def jk by simp
+    moreover have *: "nlength x - i > 0" "nlength x - i \<le> length (canrepr x)"
+      using that by simp_all
+    moreover have "length (tpsL i) = k"
+      using tpsL_def jk by simp
+    ultimately have "read (tpsL i) ! j1 = canrepr x ! (nlength x - i - 1)"
+      using jk read_contents by simp
+    then show ?thesis
+      using * bit_symbols_canrepr
+      by (metis One_nat_def Suc_le_lessD Suc_pred less_numeral_extra(4) proper_symbols_canrepr)
+  qed
+  show "\<not> read (tpsL (nlength x)) ! j1 \<noteq> \<triangleright>"
+  proof -
+    have "(tpsL (nlength x)) ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, nlength x - nlength x)"
+      using tpsL_def jk by simp
+    then have "(tpsL (nlength x)) ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, 0)"
+      by simp
+    then have "read (tpsL (nlength x)) ! j1 = \<triangleright>"
+      using tapes_at_read' tpsL_def contents_at_0 jk by (metis fst_conv length_list_update snd_conv)
+    then show ?thesis
+      by simp
+  qed
+  show "nlength x * (18 + 5 * nlength (x * y) + 2) + 1 \<le> ttt"
+  proof (cases "x = 0")
+    case True
+    then show ?thesis
+      using assms by simp
+  next
+    case False
+    have "nlength x * (18 + 5 * nlength (x * y) + 2) + 1 = nlength x * (20 + 5 * nlength (x * y)) + 1"
+      by simp
+    also have "... \<le> nlength x * (20 + 5 * (nlength x + nlength y)) + 1"
+      using nlength_prod by (meson add_mono le_refl mult_le_mono)
+    also have "... \<le> nlength x * (20 * (nlength x + nlength y) + 5 * (nlength x + nlength y)) + 1"
+    proof -
+      have "1 \<le> nlength x + nlength y"
+        using False nlength_0 by (simp add: Suc_leI)
+      then show ?thesis
+        by simp
+    qed
+    also have "... \<le> nlength x * (25 * (nlength x + nlength y)) + 1"
+      by simp
+    also have "... \<le> (nlength x + nlength y) * (25 * (nlength x + nlength y)) + 1"
+      by simp
+    finally show ?thesis
+      using assms by linarith
+  qed
+qed
+
+lemma tm3:
+  assumes "ttt = Suc (Suc (nlength x)) +
+    Suc ((25 * nlength x + 25 * nlength y) * (nlength x + nlength y))"
+  shows "transforms tm3 tps0 ttt (tpsL (nlength x))"
+  unfolding tm3_def
+proof (tform time: assms)
+  show "tpsL 0 = tps2"
+  proof -
+    have "prod' x y 0 = 0"
+      using prod'_def by simp
+    then show ?thesis
+      using tpsL_def tps2_def jk tps0 by (metis diff_zero list_update_id list_update_swap)
+  qed
+qed
+
+definition "tps3 \<equiv> tps0
+   [j1 := (\<lfloor>x\<rfloor>\<^sub>N, 0),
+    j3 := (\<lfloor>x * y\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3' [transforms_intros]:
+  assumes "ttt = 3 + 26 * (nlength x + nlength y) * (nlength x + nlength y)"
+  shows "transforms tm3 tps0 ttt tps3"
+proof -
+  have "Suc (Suc (nlength x)) + Suc ((25 * nlength x + 25 * nlength y) * (nlength x + nlength y)) \<le>
+      Suc (Suc (nlength x + nlength y)) + Suc ((25 * nlength x + 25 * nlength y) * (nlength x + nlength y))"
+    by simp
+  also have "... \<le> 2 + (nlength x + nlength y) * (nlength x + nlength y) + 1 +
+      25 * (nlength x + nlength y) * (nlength x + nlength y)"
+    by (simp add: le_square)
+  also have "... = 3 + 26 * (nlength x + nlength y) * (nlength x + nlength y)"
+    by linarith
+  finally have "Suc (Suc (nlength x)) + Suc ((25 * nlength x + 25 * nlength y) * (nlength x + nlength y)) \<le>
+      3 + 26 * (nlength x + nlength y) * (nlength x + nlength y)" .
+  moreover have "tps3 = tpsL (nlength x)"
+    using tps3_def tpsL_def by (simp add: prod')
+  ultimately show ?thesis
+    using tm3 assms transforms_monotone by simp
+qed
+
+definition "tps4 \<equiv> tps0
+  [j3 := (\<lfloor>x * y\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4:
+  assumes "ttt = 4 + 26 * (nlength x + nlength y) * (nlength x + nlength y)"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: tps3_def jk time: assms)
+  show "tps4 = tps3[j1 := tps3 ! j1 |+| 1]"
+    using tps4_def tps3_def jk tps0
+    by (metis One_nat_def add.right_neutral add_Suc_right fst_conv list_update_id list_update_overwrite
+     list_update_swap nth_list_update_eq nth_list_update_neq snd_conv)
+qed
+
+end  (* context x y k tps0 *)
+
+end  (* locale turing_machine_mult *)
+
+lemma transforms_tm_mult [transforms_intros]:
+  fixes j1 j2 j3 :: tapeidx and x y k ttt :: nat and tps tps' :: "tape list"
+  assumes "j1 \<noteq> j2" "j2 \<noteq> j3" "j3 \<noteq> j1" "j3 > 0"
+  assumes "length tps = k"
+    and "j1 < k" "j2 < k" "j3 < k"
+    and "tps ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    and "tps ! j2 = (\<lfloor>y\<rfloor>\<^sub>N, 1)"
+    and "tps ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    and "ttt = 4 + 26 * (nlength x + nlength y) * (nlength x + nlength y)"
+    and "tps' = tps [j3 := (\<lfloor>x * y\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_mult j1 j2 j3) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_mult j1 j2 j3 .
+  show ?thesis
+    using assms loc.tps4_def loc.tm4 loc.tm4_eq_tm_mult by metis
+qed
+
+
+subsection \<open>Powers\<close>
+
+text \<open>
+In this section we construct for every $d \in \nat$ a Turing machine that
+computes $n^d$. The following TMs expect a number $n$ on tape $j_1$ and output
+$n^d$ on tape $j_3$. Another tape, $j_2$, is used as scratch space to hold
+intermediate values. The TMs initialize tape $j_3$ with~1 and then multiply this
+value by $n$ for $d$ times using the TM @{const tm_mult}.
+\<close>
+
+fun tm_pow :: "nat \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_pow 0 j1 j2 j3 = tm_setn j3 1" |
+  "tm_pow (Suc d) j1 j2 j3 =
+     tm_pow d j1 j2 j3 ;; (tm_copyn j3 j2 ;; tm_setn j3 0 ;; tm_mult j1 j2 j3 ;; tm_setn j2 0)"
+
+lemma tm_pow_tm:
+  assumes "j1 \<noteq> j2" "j2 \<noteq> j3" "j3 \<noteq> j1"
+    and "0 < j2" "0 < j3" "0 < j1"
+  assumes "j1 < k" "j2 < k" "j3 < k"
+    and "k \<ge> 2"
+    and "G \<ge> 4"
+  shows "turing_machine k G (tm_pow d j1 j2 j3)"
+  using assms tm_copyn_tm tm_setn_tm tm_mult_tm by (induction d) simp_all
+
+locale turing_machine_pow =
+  fixes j1 j2 j3 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_copyn j3 j2 ;; tm_setn j3 0"
+definition "tm2 \<equiv> tm1 ;; tm_mult j1 j2 j3"
+definition "tm3 \<equiv> tm2 ;; tm_setn j2 0"
+
+fun tm4 :: "nat \<Rightarrow> machine" where
+  "tm4 0 = tm_setn j3 1" |
+  "tm4 (Suc d) = tm4 d ;; tm3"
+
+lemma tm4_eq_tm_pow: "tm4 d = tm_pow d j1 j2 j3"
+  using tm3_def tm2_def tm1_def by (induction d) simp_all
+
+context
+  fixes x y k :: nat and tps0 :: "tape list"
+  assumes jk: "k = length tps0" "j1 < k" "j2 < k" "j3 < k"
+      "j1 \<noteq> j2" "j2 \<noteq> j3" "j3 \<noteq> j1"
+      "0 < j2" "0 < j3" "0 < j1"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps0 ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! j3 = (\<lfloor>y\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j2 := (\<lfloor>y\<rfloor>\<^sub>N, 1), j3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 24 + 5 * nlength y"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: assms jk tps0 tps1_def)
+  show "ttt = 14 + 3 * (nlength y + nlength 0) + (10 + 2 * nlength y + 2 * nlength 0)"
+    using assms by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j2 := (\<lfloor>y\<rfloor>\<^sub>N, 1),
+   j3 := (\<lfloor>x * y\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 28 + 5 * nlength y + (26 * nlength x + 26 * nlength y) * (nlength x + nlength y)"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: jk tps1_def time: assms)
+  show "tps1 ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    using jk tps0 tps1_def by simp
+  show "tps2 = tps1[j3 := (\<lfloor>x * y\<rfloor>\<^sub>N, 1)]"
+    using tps2_def tps1_def by simp
+qed
+
+definition "tps3 \<equiv> tps0
+  [j3 := (\<lfloor>x * y\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3:
+  assumes "ttt = 38 + 7 * nlength y + (26 * nlength x + 26 * nlength y) * (nlength x + nlength y)"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: jk tps2_def time: assms)
+  show "tps3 = tps2[j2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    using tps3_def tps2_def jk by (metis list_update_id list_update_overwrite list_update_swap tps0(2))
+qed
+
+lemma tm3':
+  assumes "ttt = 38 + 33 * (nlength x + nlength y) ^ 2"
+  shows "transforms tm3 tps0 ttt tps3"
+proof -
+  have "38 + 7 * nlength y + (26 * nlength x + 26 * nlength y) * (nlength x + nlength y) =
+      38 + 7 * nlength y + 26 * (nlength x + nlength y) * (nlength x + nlength y)"
+    by simp
+  also have "... \<le> 38 + 33 * (nlength x + nlength y) * (nlength x + nlength y)"
+  proof -
+    have "nlength y \<le> (nlength x + nlength y) * (nlength x + nlength y)"
+      by (meson le_add2 le_square le_trans)
+    then show ?thesis
+      by linarith
+  qed
+  also have "... = 38 + 33 * (nlength x + nlength y) ^ 2"
+    by algebra
+  finally have "38 + 7 * nlength y + (26 * nlength x + 26 * nlength y) * (nlength x + nlength y) \<le> ttt"
+    using assms(1) by simp
+  then show ?thesis
+    using tm3 transforms_monotone assms by meson
+qed
+
+end  (* context x y k tps0 *)
+
+lemma tm3'' [transforms_intros]:
+  fixes x d k :: nat and tps0 :: "tape list"
+  assumes "k = length tps0"
+    and "j1 < k" "j2 < k" "j3 < k"
+  assumes j_neq [simp]: "j1 \<noteq> j2" "j2 \<noteq> j3" "j3 \<noteq> j1"
+    and j_gt [simp]: "0 < j2" "0 < j3" "0 < j1"
+    and "tps0 ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    and "tps0 ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    and "tps0 ! j3 = (\<lfloor>x ^ d\<rfloor>\<^sub>N, 1)"
+    and "ttt = 71 + 99 * (Suc d) ^ 2 * (nlength x) ^ 2"
+    and "tps' = tps0 [j3 := (\<lfloor>x ^ Suc d\<rfloor>\<^sub>N, 1)]"
+  shows "transforms tm3 tps0 ttt tps'"
+proof -
+  let ?l = "nlength x"
+  have "transforms tm3 tps0 (38 + 33 * (nlength x + nlength (x ^ d)) ^ 2) tps'"
+    using tm3' assms tps3_def by simp
+  moreover have "38 + 33 * (nlength x + nlength (x ^ d)) ^ 2 \<le> 71 + 99 * (Suc d) ^ 2 * ?l ^ 2"
+  proof -
+    have "38 + 33 * (nlength x + nlength (x ^ d)) ^ 2 \<le> 38 + 33 * (Suc (Suc d * ?l)) ^ 2"
+      using nlength_pow by simp
+    also have "... = 38 + 33 * ((Suc d * ?l)^2 + 2 * (Suc d * ?l) * 1 + 1^2)"
+      by (metis Suc_eq_plus1 add_Suc one_power2 power2_sum)
+    also have "... = 38 + 33 * ((Suc d * ?l)^2 + 2 * (Suc d * ?l) + 1)"
+      by simp
+    also have "... \<le> 38 + 33 * ((Suc d * ?l)^2 + 2 * (Suc d * ?l)^2 + 1)"
+    proof -
+      have "(Suc d * ?l) \<le> (Suc d * ?l) ^ 2"
+        by (simp add: le_square power2_eq_square)
+      then show ?thesis
+        by simp
+    qed
+    also have "... \<le> 38 + 33 * (3 * (Suc d * ?l)^2 + 1)"
+      by simp
+    also have "... = 38 + 33 * (3 * (Suc d) ^ 2 * ?l^2 + 1)"
+      by algebra
+    also have "... = 71 + 99 * (Suc d) ^ 2 * ?l ^ 2"
+      by simp
+    finally show ?thesis .
+  qed
+  ultimately show ?thesis
+    using transforms_monotone assms(14) by blast
+qed
+
+context
+  fixes x k :: nat and tps0 :: "tape list"
+  assumes jk: "j1 < k" "j2 < k" "j3 < k" "j1 \<noteq> j2" "j2 \<noteq> j3" "j3 \<noteq> j1" "0 < j2" "0 < j3" "0 < j1" "k = length tps0"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps0 ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+lemma tm4:
+  fixes d :: nat
+  assumes "tps' = tps0 [j3 := (\<lfloor>x ^ d\<rfloor>\<^sub>N, 1)]"
+    and "ttt = 12 + 71 * d + 99 * d ^ 3 * (nlength x) ^ 2"
+  shows "transforms (tm4 d) tps0 ttt tps'"
+  using assms
+proof (induction d arbitrary: tps' ttt)
+  case 0
+  have "tm4 0 = tm_setn j3 1"
+    by simp
+  let ?tps = "tps0 [j3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+  let ?t = "10 + 2 * nlength 1"
+  have "transforms (tm_setn j3 1) tps0 ?t ?tps"
+    using transforms_tm_setnI[of j3 tps0 0 ?t 1 ?tps] jk tps0 by simp
+  then have "transforms (tm_setn j3 1) tps0 ?t tps'"
+    using 0 by simp
+  then show ?case
+    using 0 nlength_1_simp by simp
+next
+  case (Suc d)
+  note Suc.IH [transforms_intros]
+
+  let ?l = "nlength x"
+  have "tm4 (Suc d) = tm4 d ;; tm3"
+    by simp
+  define t where
+    "t = 12 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + (71 + 99 * (Suc d)\<^sup>2 * (nlength x)\<^sup>2)"
+  have "transforms (tm4 d ;; tm3) tps0 t tps'"
+    by (tform tps: jk tps0 Suc.prems(1) time: t_def)
+  moreover have "t \<le> 12 + 71 * Suc d + 99 * Suc d ^ 3 * ?l\<^sup>2"
+  proof -
+    have "t = 12 + d * 71 + 99 * d ^ 3 * ?l\<^sup>2 + (71 + 99 * (Suc d)\<^sup>2 * ?l\<^sup>2)"
+      using t_def by simp
+    also have "... = 12 + Suc d * 71 + 99 * d ^ 3 * ?l\<^sup>2 + 99 * (Suc d)\<^sup>2 * ?l\<^sup>2"
+      by simp
+    also have "... = 12 + Suc d * 71 + 99 * ?l^2 * (d ^ 3 + (Suc d)\<^sup>2)"
+      by algebra
+    also have "... \<le> 12 + Suc d * 71 + 99 * ?l^2 * Suc d ^ 3"
+    proof -
+      have "Suc d ^ 3 = Suc d * Suc d ^ 2"
+        by algebra
+      also have "... = Suc d * (d ^ 2 + 2 * d + 1)"
+        by (metis (no_types, lifting) Suc_1 add.commute add_Suc mult_2 one_power2 plus_1_eq_Suc power2_sum)
+      also have "... = (d + 1) * (d ^ 2 + 2 * d + 1)"
+        by simp
+      also have "... = d ^ 3 + 2 * d ^ 2 + d + d ^ 2 + 2 * d + 1"
+        by algebra
+      also have "... = d ^ 3 + (d + 1) ^ 2 + 2 * d ^ 2 + d"
+        by algebra
+      also have "... \<ge> d ^ 3 + (d + 1) ^ 2"
+        by simp
+      finally have "Suc d ^ 3 \<ge> d ^ 3 + Suc d ^ 2"
+        by simp
+      then show ?thesis
+        by simp
+    qed
+    also have "... = 12 + 71 * Suc d + 99 * Suc d ^ 3 * ?l^2"
+      by simp
+    finally show ?thesis .
+  qed
+  ultimately show ?case
+    using transforms_monotone Suc by simp
+qed
+
+end  (* context x k tps0 *)
+
+end  (* locale turing_machine_power *)
+
+lemma transforms_tm_pow [transforms_intros]:
+  fixes d :: nat
+  assumes "j1 \<noteq> j2" "j2 \<noteq> j3" "j3 \<noteq> j1" "0 < j2" "0 < j3" "0 < j1" "j1 < k" "j2 < k" "j3 < k" "k = length tps"
+  assumes
+    "tps ! j1 = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 12 + 71 * d + 99 * d ^ 3 * (nlength x) ^ 2"
+  assumes "tps' = tps [j3 := (\<lfloor>x ^ d\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_pow d j1 j2 j3) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_pow j1 j2 j3 .
+  show ?thesis
+    using assms loc.tm4_eq_tm_pow loc.tm4 by metis
+qed
+
+
+subsection \<open>Monomials\<close>
+
+text \<open>
+A monomial is a power multiplied by a constant coefficient. The following Turing
+machines have parameters $c$ and $d$ and expect a number $x$ on tape $j$. They
+output $c\cdot x^d$ on tape $j + 3$. The tapes $j+1$ and $j+2$ are
+scratch space for use by @{const tm_pow} and @{const tm_mult}.
+\<close>
+
+definition tm_monomial :: "nat \<Rightarrow> nat \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_monomial c d j \<equiv>
+    tm_pow d j (j + 1) (j + 2) ;;
+    tm_setn (j + 1) c ;;
+    tm_mult (j + 1) (j + 2) (j + 3);;
+    tm_setn (j + 1) 0 ;;
+    tm_setn (j + 2) 0"
+
+lemma tm_monomial_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "j + 3 < k" and "0 < j"
+  shows "turing_machine k G (tm_monomial c d j)"
+  unfolding tm_monomial_def
+  using assms tm_setn_tm tm_mult_tm tm_pow_tm turing_machine_sequential_turing_machine
+  by simp
+
+locale turing_machine_monomial =
+  fixes c d :: nat and j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_pow d j (j + 1) (j + 2)"
+definition "tm2 \<equiv> tm1 ;; tm_setn (j + 1) c"
+definition "tm3 \<equiv> tm2 ;; tm_mult (j + 1) (j + 2) (j + 3)"
+definition "tm4 \<equiv> tm3 ;; tm_setn (j + 1) 0"
+definition "tm5 \<equiv> tm4 ;; tm_setn (j + 2) 0"
+
+lemma tm5_eq_tm_monomial: "tm5 = tm_monomial c d j"
+  unfolding tm1_def tm2_def tm3_def tm4_def tm5_def tm_monomial_def by simp
+
+context
+  fixes x k :: nat and tps0 :: "tape list"
+  assumes jk: "k = length tps0" "j + 3 < k" "0 < j"
+  assumes tps0:
+    "tps0 ! j = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0 [(j + 2) := (\<lfloor>x ^ d\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 12 + 71 * d + 99 * d ^ 3 * (nlength x) ^ 2"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def by (tform tps: assms tps0 jk tps1_def)
+
+definition "tps2 \<equiv> tps0
+  [j + 2 := (\<lfloor>x ^ d\<rfloor>\<^sub>N, 1),
+   j + 1 := (\<lfloor>c\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 22 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + 2 * nlength c"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: assms tps0 jk tps2_def tps1_def)
+  show "ttt = 12 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + (10 + 2 * nlength 0 + 2 * nlength c)"
+    using assms(1) by simp
+qed
+
+definition "tps3 \<equiv> tps0
+  [j + 2 := (\<lfloor>x ^ d\<rfloor>\<^sub>N, 1),
+   j + 1 := (\<lfloor>c\<rfloor>\<^sub>N, 1),
+   j + 3 := (\<lfloor>c * x ^ d\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 26 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + 2 * nlength c +
+    26 * (nlength c + nlength (x ^ d)) ^ 2"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps2_def tps3_def tps0 jk)
+  show "ttt = 22 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + 2 * nlength c +
+      (4 + 26 * (nlength c + nlength (x ^ d)) * (nlength c + nlength (x ^ d)))"
+    using assms by algebra
+qed
+
+definition "tps4 \<equiv> tps0
+  [j + 2 := (\<lfloor>x ^ d\<rfloor>\<^sub>N, 1),
+   j + 3 := (\<lfloor>c * x ^ d\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 36 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + 4 * nlength c +
+    26 * (nlength c + nlength (x ^ d))\<^sup>2"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: tps4_def tps3_def tps0 jk time: assms)
+  show "tps4 = tps3[j + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    unfolding tps4_def tps3_def
+    using jk tps0(2) list_update_id[of tps0 "Suc j"] by (simp add: list_update_swap)
+qed
+
+definition "tps5 \<equiv> tps0
+  [j + 3 := (\<lfloor>c * x ^ d\<rfloor>\<^sub>N, 1)]"
+
+lemma tm5:
+  assumes "ttt = 46 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + 4 * nlength c +
+    26 * (nlength c + nlength (x ^ d))\<^sup>2 +
+    (2 * nlength (x ^ d))"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def
+proof (tform tps: tps5_def tps4_def jk time: assms)
+  show "tps5 = tps4[j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    unfolding tps5_def tps4_def
+    using jk tps0 list_update_id[of tps0 "Suc (Suc j)"]
+    by (simp add: list_update_swap)
+qed
+
+lemma tm5':
+  assumes "ttt = 46 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + 32 * (nlength c + nlength (x ^ d))\<^sup>2"
+  shows "transforms tm5 tps0 ttt tps5"
+proof -
+  let ?t = "46 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + 4 * nlength c +
+    26 * (nlength c + nlength (x ^ d))\<^sup>2 + (2 * nlength (x ^ d))"
+  have "?t \<le> 46 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + 4 * nlength c +
+    28 * (nlength c + nlength (x ^ d))\<^sup>2"
+  proof -
+    have "2 * nlength (x ^ d) \<le> 2 * (nlength c + nlength (x ^ d))\<^sup>2"
+      by (meson add_leE eq_imp_le mult_le_mono2 power2_nat_le_imp_le)
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<le> 46 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + 32 * (nlength c + nlength (x ^ d))\<^sup>2"
+  proof -
+    have "4 * nlength c \<le> 4 * (nlength c + nlength (x ^ d))\<^sup>2"
+      by (simp add: power2_nat_le_eq_le power2_nat_le_imp_le)
+    then show ?thesis
+      by simp
+  qed
+  also have "... = ttt"
+    using assms(1) by simp
+  finally have "?t \<le> ttt" .
+  then show ?thesis
+    using assms transforms_monotone tm5 by blast
+qed
+
+end  (* context x k *)
+
+end  (* locale *)
+
+lemma transforms_tm_monomialI [transforms_intros]:
+  fixes ttt x k :: nat and tps tps' :: "tape list" and j :: tapeidx
+  assumes "j > 0" and "j + 3 < k" and "k = length tps"
+  assumes
+    "tps ! j = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 46 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 + 32 * (nlength c + nlength (x ^ d))\<^sup>2"
+  assumes "tps' = tps[j + 3 := (\<lfloor>c * x ^ d\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_monomial c d j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_monomial c d j .
+  show ?thesis
+    using loc.tm5_eq_tm_monomial loc.tm5' loc.tps5_def assms by simp
+qed
+
+
+subsection \<open>Polynomials\label{s:tm-arithmetic-poly}\<close>
+
+text \<open>
+A polynomial is a sum of monomials. In this section we construct for every
+polynomial function $p$ a Turing machine that on input $x\in\nat$ outputs
+$p(x)$.
+
+According to our definition of polynomials (see Section~\ref{s:tm-basic-bigoh}),
+we can represent each polynomial by a list of coefficients. The value of such a
+polynomial with coefficient list @{term cs} on input $x$ is given by the next
+function. In the following definition, the coefficients of the polynomial are in
+reverse order, which simplifies the Turing machine later.
+\<close>
+
+definition polyvalue :: "nat list \<Rightarrow> nat \<Rightarrow> nat" where
+  "polyvalue cs x \<equiv> (\<Sum>i\<leftarrow>[0..<length cs]. rev cs ! i * x ^ i)"
+
+lemma polyvalue_Nil: "polyvalue [] x = 0"
+  using polyvalue_def by simp
+
+lemma sum_upt_snoc: "(\<Sum>i\<leftarrow>[0..<length (zs @ [z])]. (zs @ [z]) ! i * x ^ i) =
+    (\<Sum>i\<leftarrow>[0..<length zs]. zs ! i * x ^ i) + z * x ^ (length zs)"
+  by (smt (z3) add.right_neutral atLeastLessThan_iff length_append_singleton list.map(1) list.map(2)
+    map_append map_eq_conv nth_append nth_append_length set_upt sum_list_append sum_list_simps(1)
+    sum_list_simps(2) upt.simps(2) zero_order(1))
+
+lemma polyvalue_Cons: "polyvalue (c # cs) x = c * x ^ (length cs) + polyvalue cs x"
+proof -
+  have "polyvalue (c # cs) x = (\<Sum>i\<leftarrow>[0..<Suc (length cs)]. (rev cs @ [c]) ! i * x ^ i)"
+    using polyvalue_def by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<length (rev cs @ [c])]. (rev cs @ [c]) ! i * x ^ i)"
+    by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<length (rev cs)]. (rev cs) ! i * x ^ i) + c * x ^ (length (rev cs))"
+    using sum_upt_snoc by blast
+  also have "... = (\<Sum>i\<leftarrow>[0..<length cs]. (rev cs) ! i * x ^ i) + c * x ^ (length cs)"
+    by simp
+  finally show ?thesis
+    using polyvalue_def by simp
+qed
+
+lemma polyvalue_Cons_ge: "polyvalue (c # cs) x \<ge> polyvalue cs x"
+  using polyvalue_Cons by simp
+
+lemma polyvalue_Cons_ge2: "polyvalue (c # cs) x \<ge> c * x ^ (length cs)"
+  using polyvalue_Cons by simp
+
+lemma sum_list_const: "(\<Sum>_\<leftarrow>ns. c) = c * length ns"
+  using sum_list_triv[of c ns] by simp
+
+lemma polyvalue_le: "polyvalue cs x \<le> Max (set cs) * length cs * Suc x ^ length cs"
+proof -
+  define cmax where "cmax = Max (set (rev cs))"
+  have "polyvalue cs x = (\<Sum>i\<leftarrow>[0..<length cs]. rev cs ! i * x ^ i)"
+    using polyvalue_def by simp
+  also have "... \<le> (\<Sum>i\<leftarrow>[0..<length cs]. cmax * x ^ i)"
+  proof -
+    have "rev cs ! i \<le> cmax" if "i < length cs" for i
+      using that cmax_def by (metis List.finite_set Max_ge length_rev nth_mem)
+    then show ?thesis
+      by (metis (no_types, lifting) atLeastLessThan_iff mult_le_mono1 set_upt sum_list_mono)
+  qed
+  also have "... = cmax * (\<Sum>i\<leftarrow>[0..<length cs]. x ^ i)"
+    using sum_list_const_mult by blast
+  also have "... \<le> cmax * (\<Sum>i\<leftarrow>[0..<length cs]. Suc x ^ i)"
+    by (simp add: power_mono sum_list_mono)
+  also have "... \<le> cmax * (\<Sum>i\<leftarrow>[0..<length cs]. Suc x ^ length cs)"
+  proof -
+    have "Suc x ^ i \<le> Suc x ^ length cs" if "i < length cs" for i
+      using that by (simp add: dual_order.strict_implies_order pow_mono)
+    then show ?thesis
+      by (metis atLeastLessThan_iff mult_le_mono2 set_upt sum_list_mono)
+  qed
+  also have "... = cmax * length cs * Suc x ^ length cs"
+    using sum_list_const[of _ "[0..<length cs]"] by simp
+  finally have "polyvalue cs x \<le> cmax * length cs * Suc x ^ length cs" .
+  moreover have "cmax = Max (set cs)"
+    using cmax_def by simp
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma nlength_polyvalue:
+ "nlength (polyvalue cs x) \<le> nlength (Max (set cs)) + nlength (length cs) + Suc (length cs * nlength (Suc x))"
+proof -
+  have "nlength (polyvalue cs x) \<le> nlength (Max (set cs) * length cs * Suc x ^ length cs)"
+    using polyvalue_le nlength_mono by simp
+  also have "... \<le> nlength (Max (set cs) * length cs) + nlength (Suc x ^ length cs)"
+    using nlength_prod by simp
+  also have "... \<le> nlength (Max (set cs)) + nlength(length cs) + Suc (length cs * nlength (Suc x))"
+    by (meson add_mono nlength_pow nlength_prod)
+  finally show ?thesis .
+qed
+
+text \<open>
+The following Turing machines compute polynomials given as lists of
+coefficients.  If the polynomial is given by coefficients @{term cs}, the TM
+@{term "tm_polycoef cs j"} expect a number $n$ on tape $j$ and writes $p(n)$ to
+tape $j + 4$. The tapes $j+1$, $j+2$, and $j + 3$ are auxiliary tapes for use by
+@{const tm_monomial}.
+\<close>
+
+fun tm_polycoef :: "nat list \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_polycoef [] j = []" |
+  "tm_polycoef (c # cs) j =
+     tm_polycoef cs j ;;
+     (tm_monomial c (length cs) j ;;
+      tm_add (j + 3) (j + 4) ;;
+      tm_setn (j + 3) 0)"
+
+lemma tm_polycoef_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "j + 4 < k" and "0 < j"
+  shows "turing_machine k G (tm_polycoef cs j)"
+proof (induction cs)
+  case Nil
+  then show ?case
+    by (simp add: assms(1) assms(2) turing_machine_def)
+next
+  case (Cons c cs)
+  moreover have
+    "turing_machine k G (tm_monomial c (length cs) j ;; tm_add (j + 3) (j + 4) ;; tm_setn (j + 3) 0)"
+    using tm_monomial_tm tm_add_tm tm_setn_tm assms
+    by simp
+  ultimately show ?case
+    by simp
+qed
+
+locale turing_machine_polycoef =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 c cs \<equiv> tm_monomial c (length cs) j"
+definition "tm2 c cs \<equiv> tm1 c cs ;; tm_add (j + 3) (j + 4)"
+definition "tm3 c cs \<equiv> tm2 c cs ;; tm_setn (j + 3) 0"
+
+fun tm4 :: "nat list \<Rightarrow> machine" where
+  "tm4 [] = []" |
+  "tm4 (c # cs) = tm4 cs ;; tm3 c cs"
+
+lemma tm4_eq_tm_polycoef: "tm4 zs = tm_polycoef zs j"
+proof (induction zs)
+  case Nil
+  then show ?case
+    by simp
+next
+  case (Cons z zs)
+  then show ?case
+    by (simp add: tm1_def tm2_def tm3_def)
+qed
+
+context
+  fixes x y k :: nat and tps0 :: "tape list"
+  fixes c :: nat and cs :: "nat list"
+  assumes jk: "0 < j" "j + 4 < k" "k = length tps0"
+  assumes tps0:
+    "tps0 ! j = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>y\<rfloor>\<^sub>N, 1)"
+begin
+
+abbreviation "d \<equiv> length cs"
+
+definition "tps1 \<equiv> tps0
+  [j + 3 := (\<lfloor>c * x ^ (length cs)\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 46 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 +
+      32 * (nlength c + nlength (x ^ d))\<^sup>2"
+  shows "transforms (tm1 c cs) tps0 ttt tps1"
+  unfolding tm1_def by (tform tps: assms jk tps0 tps1_def)
+
+definition "tps2 = tps0
+  [j + 3 := (\<lfloor>c * x ^ (length cs)\<rfloor>\<^sub>N, 1),
+   j + 4 := (\<lfloor>c * x ^ (length cs) + y\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 46 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 +
+    32 * (nlength c + nlength (x ^ d))\<^sup>2 +
+    (3 * max (nlength (c * x ^ d)) (nlength y) + 10)"
+  shows "transforms (tm2 c cs) tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: tps1_def tps2_def jk tps0 time: assms)
+
+definition "tps3 \<equiv> tps0
+  [j + 4 := (\<lfloor>c * x ^ d + y\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3:
+  assumes "ttt = 66 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 +
+      32 * (nlength c + nlength (x ^ d))\<^sup>2 +
+      3 * max (nlength (c * x ^ d)) (nlength y) +
+      2 * nlength (c * x ^ d)"
+  shows "transforms (tm3 c cs) tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps2_def tps3_def jk tps0 time: assms)
+  show "tps3 = tps2[j + 3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    using tps3_def tps2_def jk tps0
+    by (smt (z3) One_nat_def add_2_eq_Suc add_left_cancel lessI less_numeral_extra(4) list_update_id
+      list_update_overwrite list_update_swap numeral_3_eq_3 numeral_Bit0 plus_1_eq_Suc)
+qed
+
+definition "tps3' \<equiv> tps0
+  [j + 4 := (\<lfloor>c * x ^ length cs + y\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3':
+  assumes "ttt = 66 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 +
+      32 * (nlength c + nlength (x ^ d))\<^sup>2 +
+      5 * max (nlength (c * x ^ d)) (nlength y)"
+  shows "transforms (tm3 c cs) tps0 ttt tps3'"
+proof -
+  have "66 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 +
+      32 * (nlength c + nlength (x ^ d))\<^sup>2 +
+      3 * max (nlength (c * x ^ d)) (nlength y) +
+      2 * nlength (c * x ^ d) \<le>
+      66 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 +
+      32 * (nlength c + nlength (x ^ d))\<^sup>2 +
+      3 * max (nlength (c * x ^ d)) (nlength y) +
+      2 * max (nlength (c * x ^ d)) (nlength y)"
+    by simp
+  also have "... = 66 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 +
+      32 * (nlength c + nlength (x ^ d))\<^sup>2 +
+      5 * max (nlength (c * x ^ d)) (nlength y)"
+    by simp
+  finally have "66 + 71 * d + 99 * d ^ 3 * (nlength x)\<^sup>2 +
+      32 * (nlength c + nlength (x ^ d))\<^sup>2 +
+      3 * max (nlength (c * x ^ d)) (nlength y) +
+      2 * nlength (c * x ^ d) \<le> ttt"
+    using assms(1) by simp
+  moreover have "tps3' = tps3"
+    using tps3'_def tps3_def by simp
+  ultimately show ?thesis
+    using tm3 transforms_monotone by simp
+qed
+
+end  (* context x y k c cs tps0 *)
+
+lemma tm3'' [transforms_intros]:
+  fixes c :: nat and cs :: "nat list"
+  fixes x k :: nat and tps0 tps' :: "tape list"
+  assumes "k = length tps0" and "j + 4 < k" and "0 < j"
+  assumes
+    "tps0 ! j = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>polyvalue cs x\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 66 +
+      71 * (length cs) +
+      99 * (length cs) ^ 3 * (nlength x)\<^sup>2 +
+      32 * (nlength c + nlength (x ^ (length cs)))\<^sup>2 +
+      5 * max (nlength (c * x ^ (length cs))) (nlength (polyvalue cs x))"
+  assumes "tps' = tps0
+    [j + 4 := (\<lfloor>polyvalue (c # cs) x\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm3 c cs) tps0 ttt tps'"
+  using assms tm3'[where ?y="polyvalue cs x"] tps3'_def polyvalue_Cons by simp
+
+lemma pow_le_pow_Suc:
+  fixes a b :: nat
+  shows "a ^ b \<le> Suc a ^ Suc b"
+proof -
+  have "a ^ b \<le> Suc a ^ b"
+    by (simp add: power_mono)
+  then show ?thesis
+    by simp
+qed
+
+lemma tm4:
+  fixes x k :: nat and tps0 :: "tape list"
+  fixes cs :: "nat list"
+  assumes "k = length tps0" and "j + 4 < k" and "0 < j"
+  assumes
+    "tps0 ! j = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes ttt: "ttt = length cs *
+     (66 +
+      71 * (length cs) +
+      99 * (length cs) ^ 3 * (nlength x)\<^sup>2 +
+      32 * (Max (set (map nlength cs)) + nlength (Suc x ^ length cs))\<^sup>2 +
+      5 * nlength (polyvalue cs x))"
+  shows "transforms (tm4 cs) tps0 ttt (tps0[j + 4 := (\<lfloor>polyvalue cs x\<rfloor>\<^sub>N, 1)])"
+  using ttt
+proof (induction cs arbitrary: ttt)
+  case Nil
+  then show ?case
+    using polyvalue_Nil transforms_Nil assms by (metis list.size(3) list_update_id mult_is_0 tm4.simps(1))
+next
+  case (Cons c cs)
+  note Cons.IH [transforms_intros]
+
+  have tm4def: "tm4 (c # cs) = tm4 cs ;; tm3 c cs"
+    by simp
+
+  let ?t1 = "d cs *
+    (66 + 71 * d cs + 99 * d cs ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (nlength ` set cs) + nlength (Suc x ^ d cs))\<^sup>2 +
+     5 * nlength (polyvalue cs x))"
+  let ?t2 = "66 + 71 * d cs + 99 * d cs ^ 3 * (nlength x)\<^sup>2 +
+     32 * (nlength c + nlength (x ^ d cs))\<^sup>2 +
+     5 * max (nlength (c * x ^ d cs)) (nlength (polyvalue cs x))"
+  define t where "t = ?t1 + ?t2"
+  have tm4: "transforms (tm4 (c # cs)) tps0 t (tps0[j + 4 := (\<lfloor>polyvalue (c # cs) x\<rfloor>\<^sub>N, 1)])"
+    unfolding tm4def by (tform tps: assms t_def)
+
+  have "?t1 \<le> d cs *
+    (66 + 71 * d (c#cs) + 99 * d cs ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (nlength ` set cs) + nlength (Suc x ^d cs))\<^sup>2 +
+     5 * nlength (polyvalue cs x))"
+    by simp
+  also have "... \<le> d cs *
+    (66 + 71 * d (c#cs) + 99 * d (c#cs) ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (nlength ` set cs) + nlength (Suc x ^d cs))\<^sup>2 +
+     5 * nlength (polyvalue cs x))"
+    by simp
+  also have "... \<le> d cs *
+    (66 + 71 * d (c#cs) + 99 * d (c#cs) ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (nlength ` set (c#cs)) + nlength (Suc x ^d cs))\<^sup>2 +
+     5 * nlength (polyvalue cs x))"
+    by simp
+  also have "... \<le> d cs *
+    (66 + 71 * d (c#cs) + 99 * d (c#cs) ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (nlength ` set (c#cs)) + nlength (Suc x ^d (c#cs)))\<^sup>2 +
+     5 * nlength (polyvalue cs x))"
+    using nlength_mono by simp
+  also have "... \<le> d cs *
+    (66 + 71 * d (c#cs) + 99 * d (c#cs) ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (nlength ` set (c#cs)) + nlength (Suc x ^d (c#cs)))\<^sup>2 +
+     5 * nlength (polyvalue (c#cs) x))"
+    using nlength_mono polyvalue_Cons_ge by simp
+  finally have t1: "?t1 \<le> d cs *
+    (66 + 71 * d (c#cs) + 99 * d (c#cs) ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (nlength ` set (c#cs)) + nlength (Suc x ^d (c#cs)))\<^sup>2 +
+     5 * nlength (polyvalue (c#cs) x))"
+    (is "?t1 \<le> d cs * ?t3") .
+
+  have "?t2 \<le>
+    66 + 71 * d (c # cs) + 99 * d cs ^ 3 * (nlength x)\<^sup>2 +
+      32 * (nlength c + nlength (x ^ d cs))\<^sup>2 +
+      5 * max (nlength (c * x ^ d cs)) (nlength (polyvalue cs x))"
+    by simp
+  also have "... \<le> 66 + 71 * d (c # cs) + 99 * d (c # cs) ^ 3 * (nlength x)\<^sup>2 +
+      32 * (nlength c + nlength (x ^ d cs))\<^sup>2 +
+      5 * max (nlength (c * x ^ d cs)) (nlength (polyvalue cs x))"
+    by simp
+  also have "... \<le> 66 + 71 * d (c # cs) + 99 * d (c # cs) ^ 3 * (nlength x)\<^sup>2 +
+      32 * (Max (set (map nlength (c # cs))) + nlength (x ^ d cs))\<^sup>2 +
+      5 * max (nlength (c * x ^ d cs)) (nlength (polyvalue cs x))"
+    by simp
+  also have "... \<le> 66 + 71 * d (c # cs) + 99 * d (c # cs) ^ 3 * (nlength x)\<^sup>2 +
+      32 * (Max (set (map nlength (c # cs))) + nlength (Suc x ^ d (c#cs)))\<^sup>2 +
+      5 * max (nlength (c * x ^ d cs)) (nlength (polyvalue cs x))"
+    using nlength_mono pow_le_pow_Suc by simp
+  also have "... \<le> 66 + 71 * d (c # cs) + 99 * d (c # cs) ^ 3 * (nlength x)\<^sup>2 +
+      32 * (Max (set (map nlength (c # cs))) + nlength (Suc x ^ d (c#cs)))\<^sup>2 +
+      5 * max (nlength (c * x ^ d cs)) (nlength (polyvalue (c#cs) x))"
+  proof -
+    have "nlength (polyvalue cs x) \<le> nlength (polyvalue (c#cs) x)"
+      using polyvalue_Cons by (simp add: nlength_mono)
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<le> 66 + 71 * d (c # cs) + 99 * d (c # cs) ^ 3 * (nlength x)\<^sup>2 +
+      32 * (Max (set (map nlength (c # cs))) + nlength (Suc x ^ d (c#cs)))\<^sup>2 +
+      5 * max (nlength (polyvalue (c#cs) x)) (nlength (polyvalue (c#cs) x))"
+    using nlength_mono polyvalue_Cons_ge2 by simp
+  also have "... \<le> 66 + 71 * d (c # cs) + 99 * d (c # cs) ^ 3 * (nlength x)\<^sup>2 +
+      32 * (Max (set (map nlength (c # cs))) + nlength (Suc x ^ d (c#cs)))\<^sup>2 +
+      5 * nlength (polyvalue (c#cs) x)"
+    by simp
+  finally have t2: "?t2 \<le> ?t3"
+    by simp
+
+  have "t \<le> d cs * ?t3 + ?t3"
+    using t1 t2 t_def add_le_mono by blast
+  then have "t \<le> d (c#cs) * ?t3"
+    by simp
+  moreover have "ttt = d (c#cs) * ?t3"
+    using Cons by simp
+  ultimately have "t \<le> ttt"
+    by simp
+  then show ?case
+    using tm4 transforms_monotone by simp
+qed
+
+end  (* locale turing_machine_polycoef *)
+
+text \<open>
+The time bound in the previous lemma for @{const tm_polycoef} is a bit unwieldy.
+It depends not only on the length of the input $x$ but also on the list of
+coefficients of the polynomial $p$ and on the value $p(x)$.  Next we bound this
+time bound by a simpler expression of the form $d + d\cdot|x|^2$ where $d$
+depends only on the polynomial. This is accomplished by the next three lemmas.
+\<close>
+
+lemma tm_polycoef_time_1: "\<exists>d. \<forall>x. nlength (polyvalue cs x) \<le> d + d * nlength x"
+proof -
+  { fix x
+    have "nlength (polyvalue cs x) \<le> nlength (Max (set cs)) + nlength (length cs) + Suc (length cs * nlength (Suc x))"
+      using nlength_polyvalue by simp
+    also have "... = nlength (Max (set cs)) + nlength (length cs) + 1 + length cs * nlength (Suc x)"
+        (is "_ = ?a + length cs * nlength (Suc x)")
+      by simp
+    also have "... \<le> ?a + length cs * (Suc (nlength x))"
+      using nlength_Suc by (meson add_mono_thms_linordered_semiring(2) mult_le_mono2)
+    also have "... = ?a + length cs + length cs * nlength x"
+        (is "_ = ?b + length cs * nlength x")
+      by simp
+    also have "... \<le> ?b + ?b * nlength x"
+      by (meson add_left_mono le_add2 mult_le_mono1)
+    finally have "nlength (polyvalue cs x) \<le> ?b + ?b * nlength x" .
+  }
+  then show ?thesis
+    by blast
+qed
+
+lemma tm_polycoef_time_2: "\<exists>d. \<forall>x. (Max (set (map nlength cs)) + nlength (Suc x ^ length cs))\<^sup>2 \<le> d + d * nlength x ^ 2"
+proof -
+  { fix x
+    have "(Max (set (map nlength cs)) + nlength (Suc x ^ length cs))\<^sup>2 \<le>
+        (Max (set (map nlength cs)) + Suc (nlength (Suc x) * length cs))\<^sup>2"
+      using nlength_pow by (simp add: mult.commute)
+    also have "... = (Suc (Max (set (map nlength cs))) + nlength (Suc x) * length cs)\<^sup>2"
+        (is "_ = (?a + ?b)^2")
+      by simp
+    also have "... = ?a ^ 2 + 2 * ?a * ?b + ?b ^ 2"
+      by algebra
+    also have "... \<le> ?a ^ 2 + 2 * ?a * ?b ^ 2 + ?b ^ 2"
+      by (meson add_le_mono dual_order.eq_iff mult_le_mono2 power2_nat_le_imp_le)
+    also have "... \<le> ?a ^ 2 + (2 * ?a + 1) * ?b ^ 2"
+      by simp
+    also have "... = ?a ^ 2 + (2 * ?a + 1) * (length cs) ^ 2 * nlength (Suc x) ^ 2"
+      by algebra
+    also have "... \<le> ?a ^ 2 + (2 * ?a + 1) * (length cs) ^ 2 * Suc (nlength x) ^ 2"
+      using nlength_Suc by simp
+    also have "... = ?a ^ 2 + (2 * ?a + 1) * (length cs) ^ 2 * (nlength x ^ 2 + 2 * nlength x + 1)"
+      by (smt (z3) Suc_eq_plus1 add.assoc mult_2 nat_1_add_1 one_power2 plus_1_eq_Suc power2_sum)
+    also have "... \<le> ?a ^ 2 + (2 * ?a + 1) * (length cs) ^ 2 * (nlength x ^ 2 + 2 * nlength x ^ 2 + 1)"
+    proof -
+      have "nlength x ^ 2 + 2 * nlength x + 1 \<le> nlength x ^ 2 + 2 * nlength x ^ 2 + 1"
+        by (metis add_le_mono1 add_mono_thms_linordered_semiring(2) le_square mult.commute
+        mult_le_mono1 numerals(1) power_add_numeral power_one_right semiring_norm(2))
+      then show ?thesis
+        by simp
+    qed
+    also have "... = ?a ^ 2 + (2 * ?a + 1) * (length cs) ^ 2 * (3 * nlength x ^ 2 + 1)"
+      by simp
+    also have "... = ?a ^ 2 + (2 * ?a + 1) * (length cs) ^ 2 + (2 * ?a + 1) * (length cs) ^ 2 * 3 * nlength x ^ 2"
+        (is "_ = _ + ?c * nlength x ^ 2")
+      by simp
+    also have "... \<le> ?a ^ 2 + ?c + ?c * nlength x ^ 2"
+        (is "_ \<le> ?d + ?c * nlength x ^ 2")
+      by simp
+    also have "... \<le> ?d + ?d * nlength x ^ 2"
+      by simp
+    finally have "(Max (set (map nlength cs)) + nlength (Suc x ^ length cs))\<^sup>2 \<le> ?d + ?d * nlength x ^ 2" .
+  }
+  then show ?thesis
+    by auto
+qed
+
+lemma tm_polycoef_time_3:
+  "\<exists>d. \<forall>x. length cs *
+    (66 +
+     71 * length cs +
+     99 * length cs ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (set (map nlength cs)) + nlength (Suc x ^ length cs))\<^sup>2 +
+     5 * nlength (polyvalue cs x)) \<le> d + d * nlength x ^ 2"
+proof -
+  obtain d1 where d1: "\<forall>x. nlength (polyvalue cs x) \<le> d1 + d1 * nlength x"
+    using tm_polycoef_time_1 by auto
+  obtain d2 where d2: "\<forall>x. (Max (set (map nlength cs)) + nlength (Suc x ^ length cs))\<^sup>2 \<le> d2 + d2 * nlength x ^ 2"
+    using tm_polycoef_time_2 by auto
+  { fix x
+    let ?lhs = " length cs *
+      (66 +
+      71 * length cs +
+      99 * length cs ^ 3 * (nlength x)\<^sup>2 +
+      32 * (Max (set (map nlength cs)) + nlength (Suc x ^ length cs))\<^sup>2 +
+      5 * nlength (polyvalue cs x))"
+    let ?n = "nlength x"
+    have "?lhs \<le> length cs *
+        (66 + 71 * length cs + 99 * length cs ^ 3 * ?n ^ 2 +
+        32 * (d2 + d2 * ?n ^ 2) + 5 * (d1 + d1 * ?n))"
+      using d1 d2 add_le_mono mult_le_mono2 nat_add_left_cancel_le by presburger
+    also have "... \<le> length cs *
+        (66 + 71 * length cs + 99 * length cs ^ 3 * ?n ^ 2 +
+        32 * (d2 + d2 * ?n ^ 2) + 5 * (d1 + d1 * ?n ^ 2))"
+      by (simp add: le_square power2_eq_square)
+    also have "... = length cs *
+        (66 + 71 * length cs + 99 * length cs ^ 3 * ?n ^ 2 +
+        32 * d2 + 32 * d2 * ?n ^ 2 + 5 * d1 + 5 * d1 * ?n ^ 2)"
+      by simp
+    also have "... = length cs *
+        (66 + 71 * length cs + 32 * d2 + 5 * d1 +
+        (99 * length cs ^ 3 + 32 * d2 + 5 * d1) * ?n ^ 2)"
+      by algebra
+    also have "... = length cs * (66 + 71 * length cs + 32 * d2 + 5 * d1) +
+        length cs * (99 * length cs ^ 3 + 32 * d2 + 5 * d1) * ?n ^ 2"
+          (is "_ = ?a + ?b * ?n ^ 2")
+      by algebra
+    also have "... \<le> max ?a ?b + max ?a ?b * ?n ^ 2"
+      by (simp add: add_mono_thms_linordered_semiring(1))
+    finally have "?lhs \<le> max ?a ?b + max ?a ?b * ?n ^ 2" .
+  }
+  then show ?thesis
+    by auto
+qed
+
+text \<open>
+According to our definition of @{const polynomial} (see
+Section~\ref{s:tm-basic-bigoh}) every polynomial has a list of coefficients.
+Therefore the next definition is well-defined for polynomials $p$.
+\<close>
+
+definition coefficients :: "(nat \<Rightarrow> nat) \<Rightarrow> nat list" where
+  "coefficients p \<equiv> SOME cs. \<forall>n. p n = (\<Sum>i\<leftarrow>[0..<length cs]. cs ! i * n ^ i)"
+
+text \<open>
+The $d$ in our upper bound of the form $d + d\cdot|x|^2$ for the running time of
+@{const tm_polycoef} depends on the polynomial. It is given by the next
+function:
+\<close>
+
+definition d_polynomial :: "(nat \<Rightarrow> nat) \<Rightarrow> nat" where
+  "d_polynomial p \<equiv>
+   (let cs = rev (coefficients p)
+    in SOME d. \<forall>x. length cs *
+    (66 +
+     71 * length cs +
+     99 * length cs ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (set (map nlength cs)) + nlength (Suc x ^ length cs))\<^sup>2 +
+     5 * nlength (polyvalue cs x)) \<le> d + d * nlength x ^ 2)"
+
+text \<open>
+The Turing machine @{const tm_polycoef} has the coefficients of a polynomial
+as parameter. Next we devise a similar Turing machine that has the polynomial,
+as a function $\nat \to \nat$, as parameter.
+\<close>
+
+definition tm_polynomial :: "(nat \<Rightarrow> nat) \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_polynomial p j \<equiv> tm_polycoef (rev (coefficients p)) j"
+
+lemma tm_polynomial_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j" and "j + 4 < k"
+  shows "turing_machine k G (tm_polynomial p j)"
+  using assms tm_polynomial_def tm_polycoef_tm by simp
+
+lemma transforms_tm_polynomialI [transforms_intros]:
+  fixes p :: "nat \<Rightarrow> nat" and j :: tapeidx
+  fixes k x :: nat and tps tps' :: "tape list"
+  assumes "0 < j" and "k = length tps" and "j + 4 < k"
+    and "polynomial p"
+  assumes
+    "tps ! j = (\<lfloor>x\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = d_polynomial p + d_polynomial p * nlength x ^ 2"
+  assumes "tps' = tps
+    [j + 4 := (\<lfloor>p x\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_polynomial p j) tps ttt tps'"
+proof -
+  let ?P = "\<lambda>x. \<forall>n. p n = (\<Sum>i\<leftarrow>[0..<length x]. x ! i * n ^ i)"
+  define cs where "cs = (SOME x. ?P x)"
+  moreover have ex: "\<exists>cs. ?P cs"
+    using assms(4) polynomial_def by simp
+  ultimately have "?P cs"
+    using someI_ex[of ?P] by blast
+  then have 1: "polyvalue (rev cs) x = p x"
+    using polyvalue_def by simp
+
+  let ?cs = "rev cs"
+  have "d_polynomial p = (SOME d. \<forall>x. length ?cs *
+    (66 +
+     71 * length ?cs +
+     99 * length ?cs ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (set (map nlength ?cs)) + nlength (Suc x ^ length ?cs))\<^sup>2 +
+     5 * nlength (polyvalue ?cs x)) \<le> d + d * nlength x ^ 2)"
+    using cs_def coefficients_def d_polynomial_def by simp
+  then have *: "\<forall>x. length ?cs *
+    (66 +
+     71 * length ?cs +
+     99 * length ?cs ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (set (map nlength ?cs)) + nlength (Suc x ^ length ?cs))\<^sup>2 +
+     5 * nlength (polyvalue ?cs x)) \<le> (d_polynomial p) + (d_polynomial p) * nlength x ^ 2"
+    using tm_polycoef_time_3 someI_ex[OF tm_polycoef_time_3] by presburger
+
+  let ?ttt = "length ?cs *
+    (66 +
+     71 * length ?cs +
+     99 * length ?cs ^ 3 * (nlength x)\<^sup>2 +
+     32 * (Max (set (map nlength ?cs)) + nlength (Suc x ^ length ?cs))\<^sup>2 +
+     5 * nlength (polyvalue ?cs x))"
+
+  interpret loc: turing_machine_polycoef j .
+
+  have "transforms (loc.tm4 ?cs) tps ?ttt (tps[j + 4 := (\<lfloor>polyvalue ?cs x\<rfloor>\<^sub>N, 1)])"
+    using loc.tm4 assms * by blast
+  then have "transforms (loc.tm4 ?cs) tps ?ttt (tps[j + 4 := (\<lfloor>p x\<rfloor>\<^sub>N, 1)])"
+    using 1 by simp
+  then have "transforms (loc.tm4 ?cs) tps ?ttt tps'"
+    using assms(11) by simp
+  moreover have "loc.tm4 ?cs = tm_polynomial p j"
+    using tm_polynomial_def loc.tm4_eq_tm_polycoef coefficients_def cs_def by simp
+  ultimately have "transforms (tm_polynomial p j) tps ?ttt tps'"
+    by simp
+  then show "transforms (tm_polynomial p j) tps ttt tps'"
+    using * assms(10) transforms_monotone by simp
+qed
+
+
+subsection \<open>Division by two\<close>
+
+text \<open>
+In order to divide a number by two, a Turing machine can shift all symbols on
+the tape containing the number to the left, of course without overwriting
+the start symbol.
+
+The next command implements the left shift. It scans the tape $j$ from right to
+left and memorizes the current symbol on the last tape. It works very similar to
+@{const cmd_double} only in the opposite direction. Upon reaching the start
+symbol, it moves the head one cell to the right.
+\<close>
+
+definition cmd_halve :: "tapeidx \<Rightarrow> command" where
+  "cmd_halve j rs \<equiv>
+    (if rs ! j = 1 then 1 else 0,
+     (map (\<lambda>i.
+       if i = j then
+         if rs ! j = \<triangleright> then (rs ! i, Right)
+         else if last rs = \<triangleright> then (\<box>, Left)
+         else (tosym (todigit (last rs)), Left)
+       else if i = length rs - 1 then (tosym (todigit (rs ! j)), Stay)
+       else (rs ! i, Stay)) [0..<length rs]))"
+
+lemma turing_command_halve:
+  assumes "G \<ge> 4" and "0 < j" and "j < k"
+  shows "turing_command (Suc k) 1 G (cmd_halve j)"
+proof
+  show "\<And>gs. length gs = Suc k \<Longrightarrow> length ([!!] cmd_halve j gs) = length gs"
+    using cmd_halve_def by simp
+  moreover have "0 \<noteq> Suc k - 1"
+    using assms by simp
+  ultimately show "\<And>gs. length gs = Suc k \<Longrightarrow> 0 < Suc k \<Longrightarrow> cmd_halve j gs [.] 0 = gs ! 0"
+    using assms cmd_halve_def by (smt (verit) One_nat_def ab_semigroup_add_class.add_ac(1) diff_Suc_1
+      length_map neq0_conv nth_map nth_upt plus_1_eq_Suc prod.sel(1) prod.sel(2))
+  show "cmd_halve j gs [.] j' < G"
+    if "length gs = Suc k" "(\<And>i. i < length gs \<Longrightarrow> gs ! i < G)" "j' < length gs"
+    for gs j'
+  proof -
+    have "cmd_halve j gs [!] j' =
+      (if j' = j then
+         if gs ! j = \<triangleright> then (gs ! j', Right)
+         else if last gs = \<triangleright> then (\<box>, Left)
+         else (tosym (todigit (last gs)), Left)
+       else if j' = length gs - 1 then (tosym (todigit (gs ! j)), Stay)
+       else (gs ! j', Stay))"
+      using cmd_halve_def that(3) by simp
+    moreover consider "j' = j" | "j' = k" | "j' \<noteq> j \<and> j' \<noteq> k"
+      by auto
+    ultimately show ?thesis
+      using that assms by (cases) simp_all
+  qed
+  show "\<And>gs. length gs = Suc k \<Longrightarrow> [*] (cmd_halve j gs) \<le> 1"
+    using cmd_halve_def by simp
+qed
+
+lemma sem_cmd_halve_2:
+  assumes "j < k"
+    and "bit_symbols xs"
+    and "length tps = Suc k"
+    and "i \<le> length xs"
+    and "i > 0"
+    and "z = \<zero> \<or> z = \<one>"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, i)"
+    and "tps ! k = \<lceil>z\<rceil>"
+    and "tps' = tps[j := tps ! j |:=| z |-| 1, k := \<lceil>xs ! (i - 1)\<rceil>]"
+  shows "sem (cmd_halve j) (0, tps) = (0, tps')"
+proof (rule semI)
+  show "proper_command (Suc k) (cmd_halve j)"
+    using cmd_halve_def by simp
+  show "length tps = Suc k" "length tps' = Suc k"
+    using assms(3,9) by simp_all
+  define rs where "rs = read tps"
+  then have lenrs: "length rs = Suc k"
+    using assms(3) read_length by simp
+  have rsj: "rs ! j = xs ! (i - 1)"
+    using rs_def assms tapes_at_read' contents_inbounds
+    by (metis fst_conv le_imp_less_Suc less_imp_le_nat snd_conv)
+  then have rsj': "rs ! j > 1"
+    using assms Suc_1 Suc_diff_1 Suc_le_lessD by (metis eval_nat_numeral(3) less_Suc_eq)
+  then show "fst (cmd_halve j (read tps)) = 0"
+    using cmd_halve_def rs_def by simp
+  have lastrs: "last rs = z"
+    using assms rs_def onesie_read tapes_at_read'
+    by (metis diff_Suc_1 last_conv_nth length_0_conv lenrs lessI nat.simps(3))
+  show "act (cmd_halve j (read tps) [!] j') (tps ! j') = tps' ! j'" if "j' < Suc k" for j'
+  proof -
+    have "j' < length rs"
+      using that lenrs by simp
+    then have *: "cmd_halve j rs [!] j' =
+      (if j' = j then
+         if rs ! j = \<triangleright> then (rs ! j', Right)
+         else if last rs = \<triangleright> then (\<box>, Left)
+         else (tosym (todigit (last rs)), Left)
+       else if j' = length rs - 1 then (tosym (todigit (rs ! j)), Stay)
+       else (rs ! j', Stay))"
+      using cmd_halve_def by simp
+    consider "j' = j" | "j' = k" | "j' \<noteq> j \<and> j' \<noteq> k"
+      by auto
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "cmd_halve j (read tps) [!] j' = (tosym (todigit (last rs)), Left)"
+        using rs_def rsj' lastrs * assms(6) by auto
+      then have "cmd_halve j (read tps) [!] j' = (z, Left)"
+        using lastrs assms(6) by auto
+      moreover have "tps' ! j' = tps ! j |:=| z |-| 1"
+        using 1 assms(1,3,9) by simp
+      ultimately show ?thesis
+        using act_Left' 1 that rs_def by metis
+    next
+      case 2
+      then have "cmd_halve j (read tps) [!] j' = (tosym (todigit (rs ! j)), Stay)"
+        using rs_def * lenrs assms(1) by simp
+      moreover have "tps' ! j' = \<lceil>xs ! (i - 1)\<rceil>"
+        using assms 2 by simp
+      moreover have "tps ! j' = \<lceil>z\<rceil>"
+        using assms 2 by simp
+      moreover have "tosym (todigit (rs ! j)) = xs ! (i - 1)"
+      proof -
+        have "xs ! (i - 1) = \<zero> \<or> xs ! (i - 1) = \<one>"
+          using rsj rs_def assms by simp
+        then show ?thesis
+          using One_nat_def add_2_eq_Suc' numeral_3_eq_3 rsj by presburger
+      qed
+      ultimately show ?thesis
+        using act_onesie by simp
+    next
+      case 3
+      then show ?thesis
+        using * act_Stay that assms lenrs rs_def by simp
+    qed
+  qed
+qed
+
+lemma sem_cmd_halve_1:
+  assumes "j < k"
+    and "bit_symbols xs"
+    and "length tps = Suc k"
+    and "0 < length xs"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, length xs)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps' = tps[j := tps ! j |:=| \<box> |-| 1, k := \<lceil>xs ! (length xs - 1)\<rceil>]"
+  shows "sem (cmd_halve j) (0, tps) = (0, tps')"
+proof (rule semI)
+  show "proper_command (Suc k) (cmd_halve j)"
+    using cmd_halve_def by simp
+  show "length tps = Suc k" "length tps' = Suc k"
+    using assms(3,7) by simp_all
+  define rs where "rs = read tps"
+  then have lenrs: "length rs = Suc k"
+    using assms(3) read_length by simp
+  have rsj: "rs ! j = xs ! (length xs - 1)"
+    using rs_def assms tapes_at_read' contents_inbounds
+    by (metis One_nat_def fst_conv le_eq_less_or_eq le_imp_less_Suc snd_conv)
+  then have rsj': "rs ! j > 1"
+    using assms(2,4) by (metis One_nat_def Suc_1 diff_less lessI less_add_Suc2 numeral_3_eq_3 plus_1_eq_Suc)
+  then show "fst (cmd_halve j (read tps)) = \<box>"
+    using cmd_halve_def rs_def by simp
+  have lastrs: "last rs = \<triangleright>"
+    using assms rs_def onesie_read tapes_at_read'
+    by (metis diff_Suc_1 last_conv_nth length_0_conv lenrs lessI nat.simps(3))
+  show "act (cmd_halve j (read tps) [!] j') (tps ! j') = tps' ! j'" if "j' < Suc k" for j'
+  proof -
+    have "j' < length rs"
+      using that lenrs by simp
+    then have *: "cmd_halve j rs [!] j' =
+      (if j' = j then
+         if rs ! j = \<triangleright> then (rs ! j', Right)
+         else if last rs = \<triangleright> then (\<box>, Left)
+         else (tosym (todigit (last rs)), Left)
+       else if j' = length rs - 1 then (tosym (todigit (rs ! j)), Stay)
+       else (rs ! j', Stay))"
+      using cmd_halve_def by simp
+    consider "j' = j" | "j' = k" | "j' \<noteq> j \<and> j' \<noteq> k"
+      by auto
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "cmd_halve j (read tps) [!] j' = (\<box>, Left)"
+        using rs_def rsj' lastrs * by simp
+      then show ?thesis
+        using act_Left' 1 that rs_def assms(1,3,7) by simp
+    next
+      case 2
+      then have "cmd_halve j (read tps) [!] j' = (tosym (todigit (rs ! j)), Stay)"
+        using rs_def * lenrs assms(1) by simp
+      moreover have "tps' ! j' = \<lceil>xs ! (length xs - 1)\<rceil>"
+        using assms 2 by simp
+      moreover have "tps ! j' = \<lceil>\<triangleright>\<rceil>"
+        using assms 2 by simp
+      ultimately show ?thesis
+        using act_onesie assms 2 that rs_def rsj
+        by (smt (z3) One_nat_def Suc_1 add_2_eq_Suc' diff_less numeral_3_eq_3 zero_less_one)
+    next
+      case 3
+      then show ?thesis
+        using * act_Stay that assms lenrs rs_def by simp
+    qed
+  qed
+qed
+
+lemma sem_cmd_halve_0:
+  assumes "j < k"
+    and "length tps = Suc k"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, 0)"
+    and "tps ! k = \<lceil>z\<rceil>"
+    and "tps' = tps[j := tps ! j |+| 1, k := \<lceil>\<zero>\<rceil>]"
+  shows "sem (cmd_halve j) (0, tps) = (1, tps')"
+proof (rule semI)
+  show "proper_command (Suc k) (cmd_halve j)"
+    using cmd_halve_def by simp
+  show "length tps = Suc k" "length tps' = Suc k"
+    using assms(2,5) by simp_all
+  show "fst (cmd_halve j (read tps)) = 1"
+    using cmd_halve_def assms contents_at_0 tapes_at_read'
+    by (smt (verit) fst_conv le_eq_less_or_eq not_less not_less_eq snd_conv)
+  show "act (cmd_halve j (read tps) [!] j') (tps ! j') = tps' ! j'" if "j' < Suc k" for j'
+  proof -
+    define gs where "gs = read tps"
+    then have "length gs = Suc k"
+      using assms by (simp add: read_length)
+    then have "j' < length gs"
+      using that by simp
+    then have *: "cmd_halve j gs [!] j' =
+      (if j' = j then
+         if gs ! j = \<triangleright> then (gs ! j', Right)
+         else if last gs = \<triangleright> then (\<box>, Left)
+         else (tosym (todigit (last gs)), Left)
+       else if j' = length gs - 1 then (tosym (todigit (gs ! j)), Stay)
+       else (gs ! j', Stay))"
+      using cmd_halve_def by simp
+    have gsj: "gs ! j = \<triangleright>"
+      using gs_def assms(1,2,3) by (metis contents_at_0 fstI less_Suc_eq sndI tapes_at_read')
+    consider "j' = j" | "j' = k" | "j' \<noteq> j \<and> j' \<noteq> k"
+      by auto
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "cmd_halve j (read tps) [!] j' = (gs ! j', Right)"
+        using gs_def gsj * by simp
+      then show ?thesis
+        using act_Right assms 1 that gs_def by (metis length_list_update lessI nat_neq_iff nth_list_update)
+    next
+      case 2
+      then have "cmd_halve j (read tps) [!] j' = (tosym (todigit (gs ! j)), Stay)"
+        using gs_def * \<open>length gs = Suc k\<close> assms(1) by simp
+      moreover have "tps' ! j' = \<lceil>\<zero>\<rceil>"
+        using assms 2 by simp
+      moreover have "tps ! j' = \<lceil>z\<rceil>"
+        using assms 2 by simp
+      ultimately show ?thesis
+        using act_onesie assms 2 that gs_def gsj
+        by (smt (verit, best) One_nat_def Suc_1 add_2_eq_Suc' less_Suc_eq_0_disj less_numeral_extra(3) nat.inject numeral_3_eq_3)
+    next
+      case 3
+      then show ?thesis
+        using * act_Stay that assms(2,5) \<open>length gs = Suc k\<close> gs_def by simp
+    qed
+  qed
+qed
+
+definition tm_halve :: "tapeidx \<Rightarrow> machine" where
+  "tm_halve j \<equiv> [cmd_halve j]"
+
+lemma tm_halve_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j" and "j < k"
+  shows "turing_machine (Suc k) G (tm_halve j)"
+  using tm_halve_def turing_command_halve assms by auto
+
+lemma exe_cmd_halve_0:
+  assumes "j < k"
+    and "length tps = Suc k"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, 0)"
+    and "tps ! k = \<lceil>z\<rceil>"
+    and "tps' = tps[j := tps ! j |+| 1, k := \<lceil>\<zero>\<rceil>]"
+  shows "exe (tm_halve j) (0, tps) = (1, tps')"
+  using assms sem_cmd_halve_0 tm_halve_def exe_lt_length by simp
+
+lemma execute_cmd_halve_0:
+  assumes "j < k"
+    and "length tps = Suc k"
+    and "tps ! j = (\<lfloor>[]\<rfloor>, 0)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps' = tps[j := tps ! j |+| 1, k := \<lceil>\<zero>\<rceil>]"
+  shows "execute (tm_halve j) (0, tps) 1 = (1, tps')"
+  using tm_halve_def exe_lt_length sem_cmd_halve_0 assms by simp
+
+definition shift :: "tape \<Rightarrow> nat \<Rightarrow> tape" where
+  "shift tp y \<equiv> (\<lambda>x. if x \<le> y then (fst tp) x else (fst tp) (Suc x), y)"
+
+lemma shift_update: "y > 0 \<Longrightarrow> shift tp y |:=| (fst tp) (Suc y) |-| 1 = shift tp (y - 1)"
+  unfolding shift_def by fastforce
+
+lemma shift_contents_0:
+  assumes "length xs > 0"
+  shows "shift (\<lfloor>xs\<rfloor>, length xs) 0 = (\<lfloor>tl xs\<rfloor>, 0)"
+proof -
+  have "shift (\<lfloor>xs\<rfloor>, length xs) 0 = (\<lfloor>drop 1 xs\<rfloor>, 0)"
+    using shift_def contents_def by fastforce
+  then show ?thesis
+    by (simp add: drop_Suc)
+qed
+
+lemma proper_bit_symbols: "bit_symbols ws \<Longrightarrow> proper_symbols ws"
+  by auto
+
+lemma bit_symbols_shift:
+  assumes "t < length ws" and "bit_symbols ws"
+  shows "|.| (shift (\<lfloor>ws\<rfloor>, length ws) (length ws - t)) \<noteq> 1"
+  using assms shift_def contents_def nat_neq_iff proper_bit_symbols by simp
+
+lemma exe_cmd_halve_1:
+  assumes "j < k"
+    and "length tps = Suc k"
+    and "bit_symbols xs"
+    and "length xs > 0"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, length xs)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps' = tps[j := tps ! j |:=| \<box> |-| 1, k := \<lceil>xs ! (length xs - 1)\<rceil>]"
+  shows "exe (tm_halve j) (0, tps) = (0, tps')"
+  using tm_halve_def exe_lt_length sem_cmd_halve_1 assms by simp
+
+lemma shift_contents_eq_take_drop:
+  assumes "length xs > 0"
+    and "ys = take i xs @ drop (Suc i) xs"
+    and "i > 0"
+    and "i < length xs"
+  shows "shift (\<lfloor>xs\<rfloor>, length xs) i = (\<lfloor>ys\<rfloor>, i)"
+proof -
+  have "shift (\<lfloor>xs\<rfloor>, length xs) i = (\<lambda>x. if x \<le> i then \<lfloor>xs\<rfloor> x else \<lfloor>xs\<rfloor> (Suc x), i)"
+    using shift_def by auto
+  moreover have "(\<lambda>x. if x \<le> i then \<lfloor>xs\<rfloor> x else \<lfloor>xs\<rfloor> (Suc x)) = \<lfloor>take i xs @ drop (Suc i) xs\<rfloor>"
+    (is "?l = ?r")
+  proof
+    fix x
+    consider "x = 0" | "0 < x \<and> x \<le> i" | "i < x \<and> x \<le> length xs - 1" | "length xs - 1 < x"
+      by linarith
+    then show "?l x = ?r x"
+    proof (cases)
+      case 1
+      then show ?thesis
+        using assms contents_def by simp
+    next
+      case 2
+      then have "?l x = \<lfloor>xs\<rfloor> x"
+        by simp
+      then have lhs: "?l x = xs ! (x - 1)"
+        using assms 2 by simp
+      have "?r x = (take i xs @ drop (Suc i) xs) ! (x - 1)"
+        using assms 2 by auto
+      then have "?r x = xs ! (x - 1)"
+        using assms(4) 2
+        by (metis diff_less le_eq_less_or_eq length_take less_trans min_absorb2 nth_append nth_take zero_less_one)
+      then show ?thesis
+        using lhs by simp
+    next
+      case 3
+      then have "?l x = \<lfloor>xs\<rfloor> (Suc x)"
+        by simp
+      then have lhs: "?l x = xs ! x"
+        using 3 assms by auto
+      have "?r x = (take i xs @ drop (Suc i) xs) ! (x - 1)"
+        using assms 3 by auto
+      then have "?r x = drop (Suc i) xs ! (x - 1 - i)"
+        using assms(3,4) 3
+        by (smt (z3) Suc_diff_1 dual_order.strict_trans length_take less_Suc_eq min_absorb2 nat_less_le nth_append)
+      then have "?r x = xs ! x"
+        using assms 3 by simp
+      then show ?thesis
+        using lhs by simp
+    next
+      case 4
+      then show ?thesis
+        using contents_def by auto
+    qed
+  qed
+  ultimately show ?thesis
+    using assms(2) by simp
+qed
+
+lemma exe_cmd_halve_2:
+  assumes "j < k"
+    and "bit_symbols xs"
+    and "length tps = Suc k"
+    and "i \<le> length xs"
+    and "i > 0"
+    and "z = \<zero> \<or> z = \<one>"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, i)"
+    and "tps ! k = \<lceil>z\<rceil>"
+    and "tps' = tps[j := tps ! j |:=| z |-| 1, k := \<lceil>xs ! (i - 1)\<rceil>]"
+  shows "exe (tm_halve j) (0, tps) = (0, tps')"
+  using tm_halve_def exe_lt_length sem_cmd_halve_2 assms by simp
+
+lemma shift_contents_length_minus_1:
+  assumes "length xs > 0"
+  shows "shift (\<lfloor>xs\<rfloor>, length xs) (length xs - 1) = (\<lfloor>xs\<rfloor>, length xs) |:=| \<box> |-| 1"
+  using contents_def shift_def assms by fastforce
+
+lemma execute_tm_halve_1_less:
+  assumes "j < k"
+    and "length tps = Suc k"
+    and "bit_symbols xs"
+    and "length xs > 0"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, length xs)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "t \<ge> 1"
+    and "t \<le> length xs"
+  shows "execute (tm_halve j) (0, tps) t = (0, tps
+      [j := shift (tps ! j) (length xs - t),
+       k := \<lceil>xs ! (length xs - t)\<rceil>])"
+  using assms(7,8)
+proof (induction t rule: nat_induct_at_least)
+  case base
+  have "execute (tm_halve j) (0, tps) 1 = exe (tm_halve j) (0, tps)"
+    by simp
+  also have "... = (0, tps[j := tps ! j |:=| \<box> |-| 1, k := \<lceil>xs ! (length xs - 1)\<rceil>])"
+    using assms exe_cmd_halve_1 by simp
+  also have "... = (0, tps[j := shift (tps ! j) (length xs - 1), k := \<lceil>xs ! (length xs - 1)\<rceil>])"
+    using shift_contents_length_minus_1 assms(4,5) by simp
+  finally show ?case .
+next
+  case (Suc t)
+  then have "t < length xs"
+    by simp
+  let ?ys = "take (length xs - t) xs @ drop (Suc (length xs - t)) xs"
+  have "execute (tm_halve j) (0, tps) (Suc t) = exe (tm_halve j) (execute (tm_halve j) (0, tps) t)"
+    by simp
+  also have "... = exe (tm_halve j) (0, tps
+      [j := shift (tps ! j) (length xs - t),
+       k := \<lceil>xs ! (length xs - t)\<rceil>])"
+    using Suc by simp
+  also have "... = exe (tm_halve j) (0, tps
+      [j := shift (\<lfloor>xs\<rfloor>, length xs) (length xs - t),
+       k := \<lceil>xs ! (length xs - t)\<rceil>])"
+    using assms(5) by simp
+  also have "... = exe (tm_halve j) (0, tps
+      [j := (\<lfloor>?ys\<rfloor>, length xs - t),
+       k := \<lceil>xs ! (length xs - t)\<rceil>])"
+      (is "_ = exe _ (0, ?tps)")
+    using shift_contents_eq_take_drop Suc assms by simp
+  also have "... = (0, ?tps
+      [j := ?tps ! j |:=| (xs ! (length xs - t)) |-| 1,
+       k := \<lceil>?ys ! (length xs - t - 1)\<rceil>])"
+  proof -
+    let ?i = "length xs - t"
+    let ?z = "xs ! ?i"
+    have 1: "bit_symbols ?ys"
+      using assms(3) by (intro bit_symbols_append) simp_all
+    have 2: "length ?tps = Suc k"
+      using assms(2) by simp
+    have 3: "?i \<le> length ?ys"
+      using Suc assms by simp
+    have 4: "?i > 0"
+      using Suc assms by simp
+    have 5: "?z = 2 \<or> ?z = 3"
+      using assms(3,4) Suc by simp
+    have 6: "?tps ! j = (\<lfloor>?ys\<rfloor>, ?i)"
+      using assms(1,2) by simp
+    have 7: "?tps ! k = \<lceil>?z\<rceil>"
+      using assms(2) by simp
+    then show ?thesis
+      using exe_cmd_halve_2[OF assms(1) 1 2 3 4 5 6 7] by simp
+  qed
+  also have "... = (0, tps
+      [j := ?tps ! j |:=| (xs ! (length xs - t)) |-| 1,
+       k := \<lceil>?ys ! (length xs - t - 1)\<rceil>])"
+    using assms by (smt (z3) list_update_overwrite list_update_swap)
+  also have "... = (0, tps
+      [j := (\<lfloor>?ys\<rfloor>, length xs - t) |:=| (xs ! (length xs - t)) |-| 1,
+       k := \<lceil>?ys ! (length xs - t - 1)\<rceil>])"
+    using assms(1,2) by simp
+  also have "... = (0, tps
+      [j := shift (\<lfloor>xs\<rfloor>, length xs) (length xs - Suc t),
+       k := \<lceil>xs ! (length xs - (Suc t))\<rceil>])"
+  proof -
+    have "(\<lfloor>?ys\<rfloor>, length xs - t) |:=| xs ! (length xs - t) |-| 1 =
+        shift (\<lfloor>xs\<rfloor>, length xs) (length xs - t) |:=| (xs ! (length xs - t)) |-| 1"
+      using shift_contents_eq_take_drop One_nat_def Suc Suc_le_lessD \<open>t < length xs\<close> assms(4) diff_less zero_less_diff
+      by presburger
+    also have "... = shift (\<lfloor>xs\<rfloor>, length xs) (length xs - Suc t)"
+      using shift_update[of "length xs - t" "(\<lfloor>xs\<rfloor>, length xs)"] assms Suc by simp
+    finally have "(\<lfloor>?ys\<rfloor>, length xs - t) |:=| xs ! (length xs - t) |-| 1 =
+        shift (\<lfloor>xs\<rfloor>, length xs) (length xs - Suc t)" .
+    moreover have "?ys ! (length xs - t - 1) = xs ! (length xs - Suc t)"
+      using Suc assms \<open>t < length xs\<close>
+      by (metis (no_types, lifting) diff_Suc_eq_diff_pred diff_Suc_less diff_commute diff_less
+        length_take min_less_iff_conj nth_append nth_take zero_less_diff zero_less_one)
+    ultimately show ?thesis
+      by simp
+  qed
+  also have "... = (0, tps
+      [j := shift (tps ! j) (length xs - (Suc t)),
+       k := \<lceil>xs ! (length xs - (Suc t))\<rceil>])"
+    using assms(5) by simp
+  finally show ?case .
+qed
+
+lemma execute_tm_halve_1:
+  assumes "j < k"
+    and "length tps = Suc k"
+    and "bit_symbols xs"
+    and "length xs > 0"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, length xs)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps' = tps[j := (\<lfloor>tl xs\<rfloor>, 1), k := \<lceil>\<zero>\<rceil>]"
+  shows "execute (tm_halve j) (0, tps) (Suc (length xs)) = (1, tps')"
+proof -
+  have "execute (tm_halve j) (0, tps) (length xs) = (0, tps[j := shift (tps ! j) 0, k := \<lceil>xs ! 0\<rceil>])"
+    using execute_tm_halve_1_less[OF assms(1-6), where ?t="length xs"] assms(4) by simp
+  also have "... = (0, tps[j := shift (\<lfloor>xs\<rfloor>, length xs) 0, k := \<lceil>xs ! 0\<rceil>])"
+    using assms(5) by simp
+  also have "... = (0, tps[j := (\<lfloor>tl xs\<rfloor>, 0), k := \<lceil>xs ! 0\<rceil>])"
+    using shift_contents_0 assms(4) by simp
+  finally have "execute (tm_halve j) (0, tps) (length xs) = (0, tps[j := (\<lfloor>tl xs\<rfloor>, 0), k := \<lceil>xs ! 0\<rceil>])" .
+  then have "execute (tm_halve j) (0, tps) (Suc (length xs)) =
+      exe (tm_halve j) (0, tps[j := (\<lfloor>tl xs\<rfloor>, 0), k := \<lceil>xs ! 0\<rceil>])"
+      (is "_ = exe _ (0, ?tps)")
+    by simp
+  also have "... = (1, ?tps[j := (\<lfloor>tl xs\<rfloor>, 0) |+| 1, k := \<lceil>\<zero>\<rceil>])"
+    using assms(1,2) exe_cmd_halve_0 by simp
+  also have "... = (1, tps[j := (\<lfloor>tl xs\<rfloor>, 0) |+| 1, k := \<lceil>\<zero>\<rceil>])"
+    using assms(1,2) by (metis (no_types, opaque_lifting) list_update_overwrite list_update_swap)
+  also have "... = (1, tps[j := (\<lfloor>tl xs\<rfloor>, 1), k := \<lceil>\<zero>\<rceil>])"
+    by simp
+  finally show ?thesis
+    using assms(7) by simp
+qed
+
+lemma execute_tm_halve:
+  assumes "j < k"
+    and "length tps = Suc k"
+    and "bit_symbols xs"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, length xs)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps' = tps[j := (\<lfloor>tl xs\<rfloor>, 1), k := \<lceil>\<zero>\<rceil>]"
+  shows "execute (tm_halve j) (0, tps) (Suc (length xs)) = (1, tps')"
+  using execute_cmd_halve_0 execute_tm_halve_1 assms by (cases "length xs = 0") simp_all
+
+lemma transforms_tm_halve:
+  assumes "j < k"
+    and "length tps = Suc k"
+    and "bit_symbols xs"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, length xs)"
+    and "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps' = tps[j := (\<lfloor>tl xs\<rfloor>, 1), k := \<lceil>\<zero>\<rceil>]"
+  shows "transforms (tm_halve j) tps (Suc (length xs)) tps'"
+  using execute_tm_halve assms tm_halve_def transforms_def transits_def by auto
+
+lemma transforms_tm_halve2:
+  assumes "j < k"
+    and "length tps = k"
+    and "bit_symbols xs"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, length xs)"
+    and "tps' = tps[j := (\<lfloor>tl xs\<rfloor>, 1)]"
+  shows "transforms (tm_halve j) (tps @ [\<lceil>\<triangleright>\<rceil>]) (Suc (length xs)) (tps' @ [\<lceil>\<zero>\<rceil>])"
+proof -
+  let ?tps = "tps @ [\<lceil>\<triangleright>\<rceil>]"
+  let ?tps' = "tps' @ [\<lceil>\<zero>\<rceil>]"
+  have "?tps ! j = (\<lfloor>xs\<rfloor>, length xs)" "?tps ! k = \<lceil>\<triangleright>\<rceil>"
+    using assms by (simp_all add: nth_append)
+  moreover have "?tps' ! j = (\<lfloor>tl xs\<rfloor>, 1)" "?tps' ! k = \<lceil>\<zero>\<rceil>"
+    using assms by (simp_all add: nth_append)
+  moreover have "length ?tps = Suc k"
+    using assms(2) by simp
+  ultimately show ?thesis
+    using assms transforms_tm_halve[OF assms(1), where ?tps="?tps" and ?tps'="?tps'" and ?xs=xs]
+    by (metis length_list_update list_update_append1 list_update_length)
+qed
+
+text \<open>
+The next Turing machine removes the memorization tape from @{const tm_halve}.
+\<close>
+
+definition tm_halve' :: "tapeidx \<Rightarrow> machine" where
+  "tm_halve' j \<equiv> cartesian (tm_halve j) 4"
+
+lemma bounded_write_tm_halve:
+  assumes "j < k"
+  shows "bounded_write (tm_halve j) k 4"
+  unfolding bounded_write_def
+proof standard+
+  fix q :: nat and rs :: "symbol list"
+  assume q: "q < length (tm_halve j)" and lenrs: "length rs = Suc k"
+  have "k < length rs"
+    using lenrs by simp
+  then have "cmd_halve j rs [!] k =
+    (if k = j then
+        if rs ! j = \<triangleright> then (rs ! k, Right)
+        else if last rs = \<triangleright> then (\<box>, Left)
+        else (tosym (todigit (last rs)), Left)
+      else if k = length rs - 1 then (tosym (todigit (rs ! j)), Stay)
+      else (rs ! k, Stay))"
+    using cmd_halve_def by simp
+  then have "cmd_halve j rs [!] k = (tosym (todigit (rs ! j)), Stay)"
+    using assms lenrs by simp
+  then have "cmd_halve j rs [.] k = tosym (todigit (rs ! j))"
+    by simp
+  moreover have "(tm_halve j ! q) rs [.] k = cmd_halve j rs [.] k"
+    using tm_halve_def q by simp
+  ultimately show "(tm_halve j ! q) rs [.] k < 4"
+    by simp
+qed
+
+lemma immobile_tm_halve:
+  assumes "j < k"
+  shows "immobile (tm_halve j) k (Suc k)"
+proof standard+
+  fix q :: nat and rs :: "symbol list"
+  assume q: "q < length (tm_halve j)" and lenrs: "length rs = Suc k"
+  have "k < length rs"
+    using lenrs by simp
+  then have "cmd_halve j rs [!] k =
+    (if k = j then
+        if rs ! j = \<triangleright> then (rs ! k, Right)
+        else if last rs = \<triangleright> then (\<box>, Left)
+        else (tosym (todigit (last rs)), Left)
+      else if k = length rs - 1 then (tosym (todigit (rs ! j)), Stay)
+      else (rs ! k, Stay))"
+    using cmd_halve_def by simp
+  then have "cmd_halve j rs [!] k = (tosym (todigit (rs ! j)), Stay)"
+    using assms lenrs by simp
+  then have "cmd_halve j rs [~] k = Stay"
+    by simp
+  moreover have "(tm_halve j ! q) rs [~] k = cmd_halve j rs [~] k"
+    using tm_halve_def q by simp
+  ultimately show "(tm_halve j ! q) rs [~] k = Stay"
+    by simp
+qed
+
+lemma tm_halve'_tm:
+  assumes "G \<ge> 4" and "0 < j" and "j < k"
+  shows "turing_machine k G (tm_halve' j)"
+  using tm_halve'_def tm_halve_tm assms cartesian_tm by simp
+
+lemma transforms_tm_halve' [transforms_intros]:
+  assumes "j > 0" and "j < k"
+    and "length tps = k"
+    and "bit_symbols xs"
+    and "tps ! j = (\<lfloor>xs\<rfloor>, length xs)"
+    and "tps' = tps[j := (\<lfloor>tl xs\<rfloor>, 1)]"
+  shows "transforms (tm_halve' j) tps (Suc (length xs)) tps'"
+  unfolding tm_halve'_def
+proof (rule cartesian_transforms_onesie[OF tm_halve_tm immobile_tm_halve _ _ bounded_write_tm_halve assms(3), where ?G=4];
+    (simp add: assms)?)
+  show "2 \<le> k" and "2 \<le> k"
+    using assms(1,2) by simp_all
+  show "transforms (tm_halve j) (tps @ [\<lceil>Suc 0\<rceil>]) (Suc (length xs))
+     (tps[j := (\<lfloor>tl xs\<rfloor>, Suc 0)] @ [\<lceil>\<zero>\<rceil>])"
+    using transforms_tm_halve2 assms by simp
+qed
+
+lemma num_tl_div_2: "num (tl xs) = num xs div 2"
+proof (cases "xs = []")
+  case True
+  then show ?thesis
+    by (simp add: num_def)
+next
+  case False
+  then have *: "xs = hd xs # tl xs"
+    by simp
+  then have "num xs = todigit (hd xs) + 2 * num (tl xs)"
+    using num_Cons by metis
+  then show ?thesis
+    by simp
+qed
+
+lemma canrepr_div_2: "canrepr (n div 2) = tl (canrepr n)"
+  using canreprI canrepr canonical_canrepr num_tl_div_2 canonical_tl
+  by (metis hd_Cons_tl list.sel(2))
+
+corollary nlength_times2: "nlength (2 * n) \<le> Suc (nlength n)"
+  using canrepr_div_2[of "2 * n"] by simp
+
+corollary nlength_times2plus1: "nlength (2 * n + 1) \<le> Suc (nlength n)"
+  using canrepr_div_2[of "2 * n + 1"] by simp
+
+text \<open>
+The next Turing machine is the one we actually use to divide a number by two.
+First it moves to the end of the symbol sequence representing the number, then
+it applies @{const tm_halve'}.
+\<close>
+
+definition tm_div2 :: "tapeidx \<Rightarrow> machine" where
+  "tm_div2 j \<equiv> tm_right_until j {\<box>} ;; tm_left j ;; tm_halve' j"
+
+lemma tm_div2_tm:
+  assumes "G \<ge> 4" and "0 < j" and "j < k"
+  shows "turing_machine k G (tm_div2 j)"
+  unfolding tm_div2_def using tm_right_until_tm tm_left_tm tm_halve'_tm assms by simp
+
+locale turing_machine_div2 =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_right_until j {\<box>}"
+definition "tm2 \<equiv> tm1 ;; tm_left j"
+definition "tm3 \<equiv> tm2 ;; tm_halve' j"
+
+lemma tm3_eq_tm_div2: "tm3 = tm_div2 j"
+  unfolding tm3_def tm2_def tm1_def tm_div2_def by simp
+
+context
+  fixes tps0 :: "tape list" and k n :: nat
+  assumes jk: "0 < j" "j < k" "length tps0 = k"
+    and tps0: "tps0 ! j = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j := (\<lfloor>n\<rfloor>\<^sub>N, Suc (nlength n))]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = Suc (nlength n)"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps1_def jk tps0 time: assms)
+  have "rneigh (\<lfloor>n\<rfloor>\<^sub>N, Suc 0) {\<box>} (nlength n)"
+  proof (intro rneighI)
+    show "fst (\<lfloor>n\<rfloor>\<^sub>N, Suc 0) (snd (\<lfloor>n\<rfloor>\<^sub>N, Suc 0) + nlength n) \<in> {\<box>}"
+      using contents_def by simp
+    show "\<And>n'. n' < nlength n \<Longrightarrow> fst (\<lfloor>n\<rfloor>\<^sub>N, Suc 0) (snd (\<lfloor>n\<rfloor>\<^sub>N, Suc 0) + n') \<notin> {\<box>}"
+      using bit_symbols_canrepr contents_def contents_outofbounds proper_symbols_canrepr
+      by (metis One_nat_def Suc_leI add_diff_cancel_left' fst_eqD less_Suc_eq_0_disj less_nat_zero_code
+        plus_1_eq_Suc singletonD snd_conv)
+  qed
+  then show "rneigh (tps0 ! j) {\<box>} (nlength n)"
+    using tps0 by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j := (\<lfloor>n\<rfloor>\<^sub>N, nlength n)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 2 + nlength n"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: tps1_def tps2_def jk assms)
+
+definition "tps3 \<equiv> tps0
+  [j := (\<lfloor>n div 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3:
+  assumes "ttt = 2 * nlength n + 3"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps3_def tps2_def tps0 jk time: assms)
+  show "bit_symbols (canrepr n)"
+    using bit_symbols_canrepr .
+  show "tps3 = tps2[j := (\<lfloor>tl (canrepr n)\<rfloor>, 1)]"
+    using tps3_def tps2_def jk tps0 canrepr_div_2 by simp
+qed
+
+end
+
+end  (* locale turing_machine_div2 *)
+
+lemma transforms_tm_div2I [transforms_intros]:
+  fixes tps tps' :: "tape list" and ttt k n :: nat and j :: tapeidx
+  assumes "0 < j" "j < k"
+    and "length tps = k"
+    and "tps ! j = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 2 * nlength n + 3"
+  assumes "tps' = tps[j := (\<lfloor>n div 2\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_div2 j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_div2 j .
+  show ?thesis
+    using loc.tm3_eq_tm_div2 loc.tm3 loc.tps3_def assms by simp
+qed
+
+
+subsection \<open>Modulo two\<close>
+
+text \<open>
+In this section we construct a Turing machine that writes to tape $j_2$ the
+symbol @{text \<one>} or @{text \<box>} depending on whether the number on tape $j_1$ is
+odd or even. If initially tape $j_2$ contained at most one symbol, it will
+contain the numbers~1 or~0.
+\<close>
+
+lemma canrepr_odd: "odd n \<Longrightarrow> canrepr n ! 0 = \<one>"
+proof -
+  assume "odd n"
+  then have "0 < n"
+    by presburger
+  then have len: "length (canrepr n) > 0"
+    using nlength_0 by simp
+  then have "canrepr n ! 0 = \<zero> \<or> canrepr n ! 0 = \<one>"
+    using bit_symbols_canrepr by fastforce
+  then show "canrepr n ! 0 = \<one>"
+    using prepend_2_even len canrepr `odd n` `0 < n`
+    by (metis gr0_implies_Suc length_Suc_conv nth_Cons_0)
+qed
+
+lemma canrepr_even: "even n \<Longrightarrow> 0 < n \<Longrightarrow> canrepr n ! 0 = \<zero>"
+proof -
+  assume "even n" "0 < n"
+  then have len: "length (canrepr n) > 0"
+    using nlength_0 by simp
+  then have "canrepr n ! 0 = \<zero> \<or> canrepr n ! 0 = \<one>"
+    using bit_symbols_canrepr by fastforce
+  then show "canrepr n ! 0 = \<zero>"
+    using prepend_3_odd len canrepr `even n` `0 < n`
+    by (metis gr0_implies_Suc length_Suc_conv nth_Cons_0)
+qed
+
+definition "tm_mod2 j1 j2 \<equiv> tm_trans2 j1 j2 (\<lambda>z. if z = \<one> then \<one> else \<box>)"
+
+lemma tm_mod2_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j2" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_mod2 j1 j2)"
+  unfolding tm_mod2_def using assms tm_trans2_tm by simp
+
+lemma transforms_tm_mod2I [transforms_intros]:
+  assumes "j1 < length tps" and "0 < j2" and "j2 < length tps"
+    and "b \<le> 1"
+  assumes "tps ! j1 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    and "tps ! j2 = (\<lfloor>b\<rfloor>\<^sub>N, 1)"
+  assumes "tps' = tps[j2 := (\<lfloor>n mod 2\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_mod2 j1 j2) tps 1 tps'"
+proof -
+  let ?f = "\<lambda>z::symbol. if z = \<one> then \<one> else \<box>"
+  let ?tps = "tps[j2 := tps ! j2 |:=| (?f (tps :.: j1))]"
+  have *: "transforms (tm_mod2 j1 j2) tps 1 ?tps"
+    using transforms_tm_trans2I assms tm_mod2_def by metis
+
+  have "tps :.: j1 = \<one>" if "odd n"
+    using that canrepr_odd assms(5) contents_def
+    by (metis One_nat_def diff_Suc_1 fst_conv gr_implies_not0 ncontents_1_blank_iff_zero odd_pos snd_conv)
+  moreover have "tps :.: j1 = \<zero>" if "even n" and "n > 0"
+    using that canrepr_even assms(5) contents_def
+    by (metis One_nat_def diff_Suc_1 fst_conv gr_implies_not0 ncontents_1_blank_iff_zero snd_conv)
+  moreover have "tps :.: j1 = \<box>" if "n = 0"
+    using that canrepr_even assms(5) contents_def
+    by simp
+  ultimately have "tps :.: j1 = \<one> \<longleftrightarrow> odd n"
+    by linarith
+  then have f: "?f (tps :.: j1) = \<one> \<longleftrightarrow> odd n"
+    by simp
+
+  have tps_j2: "tps ! j2 |:=| (?f (tps :.: j1)) = ((\<lfloor>b\<rfloor>\<^sub>N)(1 := (?f (tps :.: j1))), 1)"
+    using assms by simp
+
+  have "tps ! j2 |:=| (?f (tps :.: j1)) = (\<lfloor>n mod 2\<rfloor>\<^sub>N, 1)"
+  proof (cases "even n")
+    case True
+    then have "tps ! j2 |:=| (?f (tps :.: j1)) = ((\<lfloor>b\<rfloor>\<^sub>N)(1 := 0), 1)"
+      using f tps_j2 by auto
+    also have "... = (\<lfloor>[]\<rfloor>, 1)"
+    proof (cases "b = 0")
+      case True
+      then have "\<lfloor>b\<rfloor>\<^sub>N = \<lfloor>[]\<rfloor>"
+        using canrepr_0 by simp
+      then show ?thesis
+        by auto
+    next
+      case False
+      then have "\<lfloor>b\<rfloor>\<^sub>N = \<lfloor>[\<one>]\<rfloor>"
+        using canrepr_1 assms(4) by (metis One_nat_def bot_nat_0.extremum_uniqueI le_Suc_eq)
+      then show ?thesis
+        by (metis One_nat_def append.simps(1) append_Nil2 contents_append_update contents_blank_0 list.size(3))
+    qed
+    also have "... = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      using canrepr_0 by simp
+    finally show ?thesis
+      using True by auto
+  next
+    case False
+    then have "tps ! j2 |:=| (?f (tps :.: j1)) = ((\<lfloor>b\<rfloor>\<^sub>N)(1 := \<one>), 1)"
+      using f tps_j2 by auto
+    also have "... = (\<lfloor>[\<one>]\<rfloor>, 1)"
+    proof (cases "b = 0")
+      case True
+      then have "\<lfloor>b\<rfloor>\<^sub>N = \<lfloor>[]\<rfloor>"
+        using canrepr_0 by simp
+      then show ?thesis
+        by (metis One_nat_def append.simps(1) contents_snoc list.size(3))
+    next
+      case False
+      then have "\<lfloor>b\<rfloor>\<^sub>N = \<lfloor>[\<one>]\<rfloor>"
+        using canrepr_1 assms(4) by (metis One_nat_def bot_nat_0.extremum_uniqueI le_Suc_eq)
+      then show ?thesis
+        by auto
+    qed
+    also have "... = (\<lfloor>1\<rfloor>\<^sub>N, 1)"
+      using canrepr_1 by simp
+    also have "... = (\<lfloor>n mod 2\<rfloor>\<^sub>N, 1)"
+      using False by (simp add: mod2_eq_if)
+    finally show ?thesis
+      by auto
+  qed
+  then show ?thesis
+    using * assms(7) by auto
+qed
+
+
+subsection \<open>Boolean operations\<close>
+
+text \<open>
+In order to support Boolean operations, we represent the value True by the
+number~1 and False by~0.
+\<close>
+
+abbreviation bcontents :: "bool \<Rightarrow> (nat \<Rightarrow> symbol)" ("\<lfloor>_\<rfloor>\<^sub>B") where
+  "\<lfloor>b\<rfloor>\<^sub>B \<equiv> \<lfloor>if b then 1 else 0\<rfloor>\<^sub>N"
+
+text \<open>
+A tape containing a number contains the number~0 iff.\ there is a blank in cell
+number~1.
+\<close>
+
+lemma read_ncontents_eq_0:
+  assumes "tps ! j = (\<lfloor>n\<rfloor>\<^sub>N, 1)" and "j < length tps"
+  shows "(read tps) ! j = \<box> \<longleftrightarrow> n = 0"
+  using assms tapes_at_read'[of j tps] ncontents_1_blank_iff_zero by (metis prod.sel(1) prod.sel(2))
+
+
+subsubsection \<open>And\<close>
+
+text \<open>
+The next Turing machine, when given two numbers $a, b \in \{0, 1\}$ on tapes
+$j_1$ and $j_2$, writes to tape $j_1$ the number~1 if $a = b = 1$; otherwise it
+writes the number~0. In other words, it overwrites tape $j_1$ with the logical
+AND of the two tapes.
+\<close>
+
+definition tm_and :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_and j1 j2 \<equiv> IF \<lambda>rs. rs ! j1 = \<one> \<and> rs ! j2 = \<box> THEN tm_write j1 \<box> ELSE [] ENDIF"
+
+lemma tm_and_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j1" and "j1 < k"
+  shows "turing_machine k G (tm_and j1 j2)"
+  using tm_and_def tm_write_tm Nil_tm assms turing_machine_branch_turing_machine by simp
+
+locale turing_machine_and =
+  fixes j1 j2 :: tapeidx
+begin
+
+context
+  fixes tps0 :: "tape list" and k :: nat and a b :: nat
+  assumes ab: "a < 2" "b < 2"
+  assumes jk: "j1 < k" "j2 < k" "j1 \<noteq> j2" "0 < j1" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>a\<rfloor>\<^sub>N, 1)"
+    "tps0 ! j2 = (\<lfloor>b\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j1 := (\<lfloor>a = 1 \<and> b = 1\<rfloor>\<^sub>B, 1)]"
+
+lemma tm: "transforms (tm_and j1 j2) tps0 3 tps1"
+  unfolding tm_and_def
+proof (tform)
+  have "read tps0 ! j1 = \<lfloor>canrepr a\<rfloor> 1"
+    using jk tps0 tapes_at_read'[of j1 tps0] by simp
+  then have 1: "read tps0 ! j1 = \<one> \<longleftrightarrow> a = 1"
+    using ab canrepr_odd contents_def ncontents_1_blank_iff_zero
+    by (metis (mono_tags, lifting) One_nat_def diff_Suc_1 less_2_cases_iff odd_one)
+  have "read tps0 ! j2 = \<lfloor>canrepr b\<rfloor> 1"
+    using jk tps0 tapes_at_read'[of j2 tps0] by simp
+  then have 2: "read tps0 ! j2 = \<one> \<longleftrightarrow> b = 1"
+    using ab canrepr_odd contents_def ncontents_1_blank_iff_zero
+    by (metis (mono_tags, lifting) One_nat_def diff_Suc_1 less_2_cases_iff odd_one)
+
+  show "tps1 = tps0" if "\<not> (read tps0 ! j1 = \<one> \<and> read tps0 ! j2 = \<box>)"
+  proof -
+    have "a = (if a = 1 \<and> b = 1 then 1 else 0)"
+      using that 1 2 ab jk by (metis One_nat_def less_2_cases_iff read_ncontents_eq_0 tps0(2))
+    then have "tps0 ! j1 = (\<lfloor>a = 1 \<and> b = 1\<rfloor>\<^sub>B, 1)"
+      using tps0 by simp
+    then show ?thesis
+      unfolding tps1_def using list_update_id[of tps0 j1] by simp
+  qed
+  show "tps1 = tps0[j1 := tps0 ! j1 |:=| \<box>]" if "read tps0 ! j1 = \<one> \<and> read tps0 ! j2 = \<box>"
+  proof -
+    have "(if a = 1 \<and> b = 1 then 1 else 0) = 0"
+      using that 1 2 by simp
+    moreover have "tps0 ! j1 |:=| \<box> = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    proof (cases "a = 0")
+      case True
+      then show ?thesis
+        using tps0 jk by auto
+    next
+      case False
+      then have "a = 1"
+        using ab by simp
+      then have "\<lfloor>a\<rfloor>\<^sub>N = \<lfloor>[\<one>]\<rfloor>"
+        using canrepr_1 by simp
+      moreover have "(\<lfloor>[\<one>]\<rfloor>, 1) |:=| \<box> = (\<lfloor>[]\<rfloor>, 1)"
+        using contents_def by auto
+      ultimately have "(\<lfloor>a\<rfloor>\<^sub>N, 1) |:=| \<box> = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+        using ncontents_0 by presburger
+      then show ?thesis
+        using tps0 jk by simp
+    qed
+    ultimately have "tps0 ! j1 |:=| \<box> = (\<lfloor>a = 1 \<and> b = 1\<rfloor>\<^sub>B, 1)"
+      by (smt (verit, best))
+    then show ?thesis
+      unfolding tps1_def by auto
+  qed
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_andI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps :: "tape list" and k :: nat and a b :: nat
+  assumes "a < 2" "b < 2"
+  assumes "length tps = k"
+  assumes "j1 < k" "j2 < k" "j1 \<noteq> j2" "0 < j1"
+  assumes
+    "tps ! j1 = (\<lfloor>a\<rfloor>\<^sub>N, 1)"
+    "tps ! j2 = (\<lfloor>b\<rfloor>\<^sub>N, 1)"
+  assumes "tps' = tps
+    [j1 := (\<lfloor>a = 1 \<and> b = 1\<rfloor>\<^sub>B, 1)]"
+  shows "transforms (tm_and j1 j2) tps 3 tps'"
+proof -
+  interpret loc: turing_machine_and j1 j2 .
+  show ?thesis
+    using assms loc.tps1_def loc.tm by simp
+qed
+
+
+subsubsection \<open>Not\<close>
+
+text \<open>
+The next Turing machine turns the number~1 into~0 and vice versa.
+\<close>
+
+definition tm_not :: "tapeidx \<Rightarrow> machine" where
+  "tm_not j \<equiv> IF \<lambda>rs. rs ! j = \<box> THEN tm_write j \<one> ELSE tm_write j \<box> ENDIF"
+
+lemma tm_not_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j" and "j < k"
+  shows "turing_machine k G (tm_not j)"
+  using tm_not_def tm_write_tm assms turing_machine_branch_turing_machine by simp
+
+locale turing_machine_not =
+  fixes j :: tapeidx
+begin
+
+context
+  fixes tps0 :: "tape list" and k :: nat and a :: nat
+  assumes a: "a < 2"
+  assumes jk: "j < k" "length tps0 = k"
+  assumes tps0: "tps0 ! j = (\<lfloor>a\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j := (\<lfloor>a \<noteq> 1\<rfloor>\<^sub>B, 1)]"
+
+lemma tm: "transforms (tm_not j) tps0 3 tps1"
+  unfolding tm_not_def
+proof (tform)
+  have *: "read tps0 ! j = \<box> \<longleftrightarrow> a = 0"
+    using read_ncontents_eq_0 jk tps0 by simp
+  show "tps1 = tps0[j := tps0 ! j |:=| \<one>]" if "read tps0 ! j = \<box>"
+  proof -
+    have "a = 0"
+      using a that * by simp
+    then have "(\<lfloor>if a = 1 then 0 else 1\<rfloor>\<^sub>N, 1) = (\<lfloor>1\<rfloor>\<^sub>N, 1)"
+      by simp
+    moreover have "tps0 ! j |:=| \<one> = (\<lfloor>1\<rfloor>\<^sub>N, 1)"
+      using tps0 canrepr_0 canrepr_1 `a = 0` contents_snoc
+      by (metis One_nat_def append.simps(1) fst_conv list.size(3) snd_conv)
+    ultimately have "tps0[j := tps0 ! j |:=| \<one>] = tps0[j := (\<lfloor>a \<noteq> 1\<rfloor>\<^sub>B, 1)]"
+      by auto
+    then show ?thesis
+      using tps1_def by simp
+  qed
+  show "tps1 = tps0[j := tps0 ! j |:=| \<box>]" if "read tps0 ! j \<noteq> \<box>"
+  proof -
+    have "a = 1"
+      using a that * by simp
+    then have "(\<lfloor>if a = 1 then 0 else 1\<rfloor>\<^sub>N, 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      by simp
+    moreover have "tps0 ! j |:=| \<box> = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      using tps0 canrepr_0 canrepr_1 `a = 1` contents_snoc
+      by (metis Suc_1 append_self_conv2 contents_blank_0 fst_eqD fun_upd_upd nat.inject nlength_0_simp numeral_2_eq_2 snd_eqD)
+    ultimately have "tps0[j := tps0 ! j |:=| \<box>] = tps0[j := (\<lfloor>a \<noteq> 1\<rfloor>\<^sub>B, 1)]"
+      by auto
+    then show ?thesis
+      using tps1_def by simp
+  qed
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_notI [transforms_intros]:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and k :: nat and a :: nat
+  assumes "j < k" "length tps = k"
+    and "a < 2"
+  assumes "tps ! j = (\<lfloor>a\<rfloor>\<^sub>N, 1)"
+  assumes "tps' = tps
+    [j := (\<lfloor>a \<noteq> 1\<rfloor>\<^sub>B, 1)]"
+  shows "transforms (tm_not j) tps 3 tps'"
+proof -
+  interpret loc: turing_machine_not j .
+  show ?thesis
+    using assms loc.tps1_def loc.tm by simp
+qed
+
+end
\ No newline at end of file
diff --git a/thys/Cook_Levin/Aux_TM_Reducing.thy b/thys/Cook_Levin/Aux_TM_Reducing.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Aux_TM_Reducing.thy
@@ -0,0 +1,4253 @@
+chapter \<open>Auxiliary Turing machines for reducing $\NP$ languages to \SAT{}\label{s:Aux_TM}\<close>
+
+theory Aux_TM_Reducing
+  imports Reducing
+begin
+
+text \<open>
+In the previous chapter we have seen how to reduce a language $L\in\NP$ to
+\SAT{} by constructing for every string $x$ a CNF formula $\Phi$ that is
+satisfiable iff.\ $x\in L$. To complete the Cook-Levin theorem it remains to
+show that there is a polynomial-time Turing machine that on input $x$ outputs
+$\Phi$.  Constructing such a TM will be the subject of the rest of this article
+and conclude in the next chapter. This chapter introduces several TMs used in
+the construction.
+\<close>
+
+
+section \<open>Generating literals\<close>
+
+text \<open>
+Our representation of CNF formulas as lists of lists of numbers is based on a
+representation of literals as numbers. Our function @{const literal_n} encodes
+the positive literal $v_i$ as the number $2i + 1$ and the negative literal $\bar
+v_i$ as $2i$. We already have the Turing machine @{const tm_times2} to cover the
+second case. Now we build a TM for the first case, that is, for doubling and
+incrementing.
+
+\null
+\<close>
+
+definition tm_times2incr :: "tapeidx \<Rightarrow> machine" where
+  "tm_times2incr j \<equiv> tm_times2 j ;; tm_incr j"
+
+lemma tm_times2incr_tm:
+  assumes "0 < j" and "j < k" and "G \<ge> 4"
+  shows "turing_machine k G (tm_times2incr j)"
+  unfolding tm_times2incr_def using tm_times2_tm tm_incr_tm assms by simp
+
+lemma transforms_tm_times2incrI [transforms_intros]:
+  fixes j :: tapeidx
+  fixes k :: nat and tps tps' :: "tape list"
+  assumes "k \<ge> 2" and "j > 0" and "j < k" and "length tps = k"
+  assumes "tps ! j = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+  assumes "t = 12 + 4 * nlength n"
+  assumes "tps' = tps[j := (\<lfloor>Suc (2 * n)\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_times2incr j) tps t tps'"
+proof -
+  define tt where "tt = 10 + (2 * nlength n + 2 * nlength (2 * n))"
+  have "transforms (tm_times2incr j) tps tt tps'"
+    unfolding tm_times2incr_def by (tform tps: tt_def assms)
+  moreover have "tt \<le> t"
+  proof -
+    have "tt = 10 + 2 * nlength n + 2 * nlength (2 * n)"
+      using tt_def by simp
+    also have "... \<le> 10 + 2 * nlength n + 2 * (Suc (nlength n))"
+    proof -
+      have "nlength (2 * n) \<le> Suc (nlength n)"
+        by (metis eq_imp_le gr0I le_SucI nat_0_less_mult_iff nlength_even_le)
+      then show ?thesis
+        by simp
+    qed
+    also have "... = 12 + 4 * nlength n"
+      by simp
+    finally show ?thesis
+      using assms(6) by simp
+  qed
+  ultimately show ?thesis
+    using transforms_monotone by simp
+qed
+
+lemma literal_n_rename:
+  assumes "v div 2 < length \<sigma>"
+  shows "2 * \<sigma> ! (v div 2) + v mod 2 = (literal_n \<circ> rename \<sigma>) (n_literal v)"
+proof (cases "even v")
+  case True
+  then show ?thesis
+    using n_literal_def assms by simp
+next
+  case False
+  then show ?thesis
+    using n_literal_def assms by simp presburger
+qed
+
+text \<open>
+Combining @{const tm_times2} and @{const tm_times2incr}, the next Turing machine
+accepts a variable index $i$ on tape $j_1$ and a flag $b$ on tape $j_2$ and
+outputs on tape $j_1$ the encoding of the positive literal $v_i$ or the negative
+literal $\bar v_i$ if $b$ is positive or zero, respectively.
+\<close>
+
+definition tm_to_literal :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_to_literal j1 j2 \<equiv>
+    IF \<lambda>rs. rs ! j2 = \<box> THEN
+      tm_times2 j1
+    ELSE
+      tm_times2incr j1
+    ENDIF"
+
+lemma tm_to_literal_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j1" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_to_literal j1 j2)"
+  unfolding tm_to_literal_def
+  using assms tm_times2_tm tm_times2incr_tm turing_machine_branch_turing_machine
+  by simp
+
+lemma transforms_tm_to_literalI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k i b :: nat
+  assumes "0 < j1" "j1 < k" "j2 < k" "2 \<le> k" "length tps = k"
+  assumes
+    "tps ! j1 = (\<lfloor>i\<rfloor>\<^sub>N, 1)"
+    "tps ! j2 = (\<lfloor>b\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 13 + 4 * nlength i"
+  assumes "tps' = tps
+    [j1 := (\<lfloor>2 * i + (if b = 0 then 0 else 1)\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_to_literal j1 j2) tps ttt tps'"
+  unfolding tm_to_literal_def
+proof (tform tps: assms read_ncontents_eq_0)
+  show "5 + 2 * nlength i + 2 \<le> ttt" and "12 + 4 * nlength i + 1 \<le> ttt"
+    using assms(8) by simp_all
+qed
+
+
+section \<open>A Turing machine for relabeling formulas\<close>
+
+text \<open>
+In order to construct $\Phi_9$, we must construct CNF formulas $\chi_t$, which
+have the form $\rho(\psi)$ or $\rho'(\psi')$. So we need a Turing machine for
+relabeling formulas. In this section we devise a Turing machine that gets a
+substitution $\sigma$ and a CNF formula $\phi$ and outputs $\sigma(\phi)$. In
+order to bound its running time we first prove some bounds on the length of
+relabeled formulas.
+\<close>
+
+
+subsection \<open>The length of relabeled formulas\<close>
+
+text \<open>
+First we bound the length of the representation of a single relabeled clause.
+In the following lemma the assumption ensures that the substitution $\sigma$ has
+a value for every variable in the clause.
+\<close>
+
+lemma nllength_rename:
+  assumes "\<forall>v\<in>set clause. v div 2 < length \<sigma>"
+  shows "nllength (map (literal_n \<circ> rename \<sigma>) (n_clause clause)) \<le> length clause * Suc (nllength \<sigma>)"
+proof (cases "\<sigma> = []")
+  case True
+  then show ?thesis
+    using assms n_clause_def by simp
+next
+  case False
+  let ?f = "literal_n \<circ> rename \<sigma> \<circ> n_literal"
+  have *: "map (literal_n \<circ> rename \<sigma>) (n_clause clause) = map ?f clause"
+    using n_clause_def by simp
+
+  have "nlength (2 * n + 1) \<le> Suc (nlength n)" for n
+    using nlength_times2plus1 by simp
+  then have "nlength (2 * Max (set \<sigma>) + 1) \<le> Suc (nlength (Max (set \<sigma>)))"
+    by simp
+  moreover have "nlength (Max (set \<sigma>)) \<le> nllength \<sigma> - 1"
+    using False member_le_nllength_1 by simp
+  ultimately have "nlength (2 * Max (set \<sigma>) + 1) \<le> Suc (nllength \<sigma> - 1)"
+    by simp
+  then have **: "nlength (2 * Max (set \<sigma>) + 1) \<le> nllength \<sigma>"
+    using nllength_gr_0 False by simp
+
+  have "?f n \<le> 2 * (\<sigma> ! (n div 2)) + 1" if "n div 2 < length \<sigma>" for n
+    using n_literal_def by (cases "even n") simp_all
+  then have "?f v \<le> 2 * (\<sigma> ! (v div 2)) + 1" if "v \<in> set clause" for v
+    using assms that by simp
+  moreover have "\<sigma> ! (v div 2) \<le> Max (set \<sigma>)" if "v \<in> set clause" for v
+    using that assms by simp
+  ultimately have "?f v \<le> 2 * Max (set \<sigma>) + 1" if "v \<in> set clause" for v
+    using that by fastforce
+  then have "n \<le> 2 * Max (set \<sigma>) + 1" if "n \<in> set (map ?f clause)" for n
+    using that by auto
+  then have "nllength (map ?f clause) \<le> Suc (nlength (2 * Max (set \<sigma>) + 1)) * length (map ?f clause)"
+    using nllength_le_len_mult_max by blast
+  also have "... = Suc (nlength (2 * Max (set \<sigma>) + 1)) * length clause"
+    by simp
+  also have "... \<le> Suc (nllength \<sigma>) * length clause"
+    using ** by simp
+  finally have "nllength (map ?f clause) \<le> Suc (nllength \<sigma>) * length clause" .
+  then show ?thesis
+    using * by (metis mult.commute)
+qed
+
+text \<open>
+Our upper bound for the length of the symbol representation of a relabeled
+formula is fairly crude. It is basically the length of the string resulting from
+replacing every symbol of the original formula by the entire substitution.
+\<close>
+
+lemma nlllength_relabel:
+  assumes "\<forall>clause\<in>set \<phi>. \<forall>v\<in>set (clause_n clause). v div 2 < length \<sigma>"
+  shows "nlllength (formula_n (relabel \<sigma> \<phi>)) \<le> Suc (nllength \<sigma>) * nlllength (formula_n \<phi>)"
+  using assms
+proof (induction \<phi>)
+  case Nil
+  then show ?case
+    by (simp add: relabel_def)
+next
+  case (Cons clause \<phi>)
+  let ?nclause = "clause_n clause"
+  have "\<forall>v\<in>set ?nclause. v div 2 < length \<sigma>"
+    using Cons.prems by simp
+  then have "nllength (map (literal_n \<circ> rename \<sigma>) (n_clause ?nclause)) \<le> length ?nclause * Suc (nllength \<sigma>)"
+    using nllength_rename by simp
+  then have "nllength (map (literal_n \<circ> rename \<sigma>) clause) \<le> length clause * Suc (nllength \<sigma>)"
+    using clause_n_def n_clause_n by simp
+  moreover have "map (literal_n \<circ> rename \<sigma>) clause = clause_n (map (rename \<sigma>) clause)"
+    using clause_n_def by simp
+  ultimately have *: "nllength (clause_n (map (rename \<sigma>) clause)) \<le> length clause * Suc (nllength \<sigma>)"
+    by simp
+
+  have "formula_n (relabel \<sigma> (clause # \<phi>)) = clause_n (map (rename \<sigma>) clause) # formula_n (relabel \<sigma> \<phi>)"
+    by (simp add: formula_n_def relabel_def)
+  then have "nlllength (formula_n (relabel \<sigma> (clause # \<phi>))) =
+      nllength (clause_n (map (rename \<sigma>) clause)) + 1 + nlllength (formula_n (relabel \<sigma> \<phi>))"
+    using nlllength_Cons by simp
+  also have "... \<le> length clause * Suc (nllength \<sigma>) + 1 + nlllength (formula_n (relabel \<sigma> \<phi>))"
+    using * by simp
+  also have "... \<le> length clause * Suc (nllength \<sigma>) + 1 + Suc (nllength \<sigma>) * nlllength (formula_n \<phi>)"
+    using Cons by (metis add_mono_thms_linordered_semiring(2) insert_iff list.set(2))
+  also have "... = 1 + Suc (nllength \<sigma>) * (length clause + nlllength (formula_n \<phi>))"
+    by algebra
+  also have "... \<le> Suc (nllength \<sigma>) * (1 + length clause + nlllength (formula_n \<phi>))"
+    by simp
+  also have "... \<le> Suc (nllength \<sigma>) * (1 + nllength (clause_n clause) + nlllength (formula_n \<phi>))"
+    using length_le_nllength n_clause_def n_clause_n
+    by (metis add_Suc_shift add_le_cancel_right length_map mult_le_mono2 plus_1_eq_Suc)
+  also have "... = Suc (nllength \<sigma>) * (nlllength (formula_n (clause # \<phi>)))"
+    using formula_n_def nlllength_Cons by simp
+  finally show ?case .
+qed
+
+text \<open>
+A simple sufficient condition for the assumption in the previous lemma.
+\<close>
+
+lemma variables_\<sigma>:
+  assumes "variables \<phi> \<subseteq> {..<length \<sigma>}"
+  shows "\<forall>clause\<in>set \<phi>.\<forall>v\<in>set (clause_n clause). v div 2 < length \<sigma>"
+proof standard+
+  fix clause :: clause and v :: nat
+  assume clause: "clause \<in> set \<phi>" and v: "v \<in> set (clause_n clause)"
+
+  obtain i where i: "i < length clause" "v = literal_n (clause ! i)"
+    using v clause_n_def by (metis in_set_conv_nth length_map nth_map)
+  then have clause_i: "clause ! i = n_literal v"
+    using n_literal_n by simp
+
+  show "v div 2 < length \<sigma>"
+  proof (cases "even v")
+    case True
+    then have "clause ! i = Neg (v div 2)"
+      using clause_i n_literal_def by simp
+    then have "\<exists>c\<in>set \<phi>. Neg (v div 2) \<in> set c"
+      using clause i(1) by (metis nth_mem)
+    then have "v div 2 \<in> variables \<phi>"
+      using variables_def by auto
+    then show ?thesis
+      using assms by auto
+  next
+    case False
+    then have "clause ! i = Pos (v div 2)"
+      using clause_i n_literal_def by simp
+    then have "\<exists>c\<in>set \<phi>. Pos (v div 2) \<in> set c"
+      using clause i(1) by (metis nth_mem)
+    then have "v div 2 \<in> variables \<phi>"
+      using variables_def by auto
+    then show ?thesis
+      using assms by auto
+  qed
+qed
+
+text \<open>
+Combining the previous two lemmas yields this upper bound:
+\<close>
+
+lemma nlllength_relabel_variables:
+  assumes "variables \<phi> \<subseteq> {..<length \<sigma>}"
+  shows "nlllength (formula_n (relabel \<sigma> \<phi>)) \<le> Suc (nllength \<sigma>) * nlllength (formula_n \<phi>)"
+  using assms variables_\<sigma> nlllength_relabel by blast
+
+
+subsection \<open>Relabeling clauses\<close>
+
+text \<open>
+Relabeling a CNF formula is accomplished by relabeling each of its clauses. In
+this section we devise a Turing machine for relabeling clauses. The TM accepts
+on tape $j$ a list of numbers representing a substitution $\sigma$ and on tape
+$j + 1$ a clause represented as a list of numbers. It outputs on tape $j + 2$
+the relabeled clause, consuming the original clause on tape $j + 1$ in the
+process.
+\<close>
+
+definition tm_relabel_clause :: "tapeidx \<Rightarrow> machine" where
+  "tm_relabel_clause j \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! (j + 1) \<noteq> \<box> DO
+      tm_nextract \<bar> (j + 1) (j + 3) ;;
+      tm_mod2 (j + 3) (j + 4) ;;
+      tm_div2 (j + 3) ;;
+      tm_nth_inplace j (j + 3) \<bar> ;;
+      tm_to_literal (j + 3) (j + 4) ;;
+      tm_append (j + 2) (j + 3) ;;
+      tm_setn (j + 3) 0 ;;
+      tm_setn (j + 4) 0
+    DONE ;;
+    tm_cr (j + 2) ;;
+    tm_erase_cr (j + 1)"
+
+lemma tm_relabel_clause_tm:
+  assumes "G \<ge> 5" and "j + 4 < k" and "0 < j"
+  shows "turing_machine k G (tm_relabel_clause j)"
+  unfolding tm_relabel_clause_def
+  using assms tm_nextract_tm tm_mod2_tm tm_div2_tm tm_nth_inplace_tm tm_to_literal_tm tm_append_tm tm_setn_tm
+    tm_cr_tm tm_erase_cr_tm Nil_tm turing_machine_loop_turing_machine
+  by simp
+
+locale turing_machine_relabel_clause =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_nextract \<bar> (j + 1) (j + 3)"
+definition "tm2 \<equiv> tm1 ;; tm_mod2 (j + 3) (j + 4)"
+definition "tm3 \<equiv> tm2 ;; tm_div2 (j + 3)"
+definition "tm4 \<equiv> tm3 ;; tm_nth_inplace j (j + 3) \<bar>"
+definition "tm5 \<equiv> tm4 ;; tm_to_literal (j + 3) (j + 4)"
+definition "tm6 \<equiv> tm5 ;; tm_append (j + 2) (j + 3)"
+definition "tm7 = tm6 ;; tm_setn (j + 3) 0"
+definition "tm8 \<equiv> tm7 ;; tm_setn (j + 4) 0"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! (j + 1) \<noteq> \<box> DO tm8 DONE"
+definition "tm9 \<equiv> tmL ;; tm_cr (j + 2)"
+definition "tm10 \<equiv> tm9 ;; tm_erase_cr (j + 1)"
+
+lemma tm10_eq_tm_relabel_clause: "tm10 = tm_relabel_clause j"
+  unfolding tm_relabel_clause_def tm3_def tmL_def tm5_def tm4_def tm1_def tm2_def tm6_def tm7_def tm8_def tm9_def tm10_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and \<sigma> clause :: "nat list"
+  assumes clause: "\<forall>v\<in>set clause. v div 2 < length \<sigma>"
+  assumes jk: "0 < j" "j + 4 < k" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j = (\<lfloor>\<sigma>\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>clause\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tpsL t \<equiv> tps0
+  [j + 1 := nltape' clause t,
+   j + 2 := nltape (take t (map literal_n (map (rename \<sigma>) (n_clause clause))))]"
+
+lemma tpsL_eq_tps0: "tpsL 0 = tps0"
+  using tpsL_def tps0 jk nllength_Nil by (metis One_nat_def list_update_id take0)
+
+definition "tps1 t \<equiv> tps0
+  [j + 1 := nltape' clause (Suc t),
+   j + 2 := nltape (take t (map literal_n (map (rename \<sigma>) (n_clause clause)))),
+   j + 3 := (\<lfloor>clause ! t\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "t < length clause"
+    and "ttt = 12 + 2 * nlength (clause ! t)"
+  shows "transforms tm1 (tpsL t) ttt (tps1 t)"
+  unfolding tm1_def
+proof (tform tps: assms(1) tpsL_def tps1_def tps0 jk)
+  show "ttt = 12 + 2 * nlength 0 + 2 * nlength (clause ! t)"
+    using assms(2) by simp
+qed
+
+definition "tps2 t \<equiv> tps0
+  [j + 1 := nltape' clause (Suc t),
+   j + 2 := nltape (take t (map literal_n (map (rename \<sigma>) (n_clause clause)))),
+   j + 3 := (\<lfloor>clause ! t\<rfloor>\<^sub>N, 1),
+   j + 4 := (\<lfloor>(clause ! t) mod 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "t < length clause"
+    and "ttt = 13 + 2 * nlength (clause ! t)"
+  shows "transforms tm2 (tpsL t) ttt (tps2 t)"
+  unfolding tm2_def by (tform tps: assms tps1_def tps2_def tps0 jk)
+
+definition "tps3 t \<equiv> tps0
+  [j + 1 := nltape' clause (Suc t),
+   j + 2 := nltape (take t (map literal_n (map (rename \<sigma>) (n_clause clause)))),
+   j + 3 := (\<lfloor>clause ! t div 2\<rfloor>\<^sub>N, 1),
+   j + 4 := (\<lfloor>clause ! t mod 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "t < length clause"
+    and "ttt = 16 + 4 * nlength (clause ! t)"
+  shows "transforms tm3 (tpsL t) ttt (tps3 t)"
+  unfolding tm3_def by (tform tps: assms(1) tps2_def tps3_def jk time: assms(2))
+
+definition "tps4 t \<equiv> tps0
+  [j + 1 := nltape' clause (Suc t),
+   j + 2 := nltape (take t (map literal_n (map (rename \<sigma>) (n_clause clause)))),
+   j + 3 := (\<lfloor>\<sigma> ! (clause ! t div 2)\<rfloor>\<^sub>N, 1),
+   j + 4 := (\<lfloor>clause ! t mod 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4 [transforms_intros]:
+  assumes "t < length clause"
+    and "ttt = 28 + 4 * nlength (clause ! t) + 18 * (nllength \<sigma>)\<^sup>2"
+  shows "transforms tm4 (tpsL t) ttt (tps4 t)"
+  unfolding tm4_def
+proof (tform tps: assms(1) tps0 tps3_def tps4_def jk clause time: assms(2))
+  show "tps4 t = (tps3 t)[j + 3 := (\<lfloor>\<sigma> ! (clause ! t div 2)\<rfloor>\<^sub>N, 1)]"
+    unfolding tps4_def tps3_def by (simp add: list_update_swap[of "j + 3"])
+qed
+
+definition "tps5 t \<equiv> tps0
+  [j + 1 := nltape' clause (Suc t),
+   j + 2 := nltape (take t (map literal_n (map (rename \<sigma>) (n_clause clause)))),
+   j + 3 := (\<lfloor>2 * (\<sigma> ! (clause ! t div 2)) + clause ! t mod 2\<rfloor>\<^sub>N, 1),
+   j + 4 := (\<lfloor>clause ! t mod 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "t < length clause"
+   and "ttt = 41 + 4 * nlength (clause ! t) + 18 * (nllength \<sigma>)\<^sup>2 +
+      4 * nlength (\<sigma> ! (clause ! t div 2))"
+  shows "transforms tm5 (tpsL t) ttt (tps5 t)"
+  unfolding tm5_def by (tform tps: assms(1) tps0 tps4_def tps5_def jk time: assms(2))
+
+definition "tps6 t \<equiv> tps0
+  [j + 1 := nltape' clause (Suc t),
+   j + 2 := nltape (take (Suc t) (map literal_n (map (rename \<sigma>) (n_clause clause)))),
+   j + 3 := (\<lfloor>2 * (\<sigma> ! (clause ! t div 2)) + clause ! t mod 2\<rfloor>\<^sub>N, 1),
+   j + 4 := (\<lfloor>clause ! t mod 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm6:
+  assumes "t < length clause"
+   and "ttt = 47 + 4 * nlength (clause ! t) + 18 * (nllength \<sigma>)\<^sup>2 +
+      4 * nlength (\<sigma> ! (clause ! t div 2)) +
+      2 * nlength (2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2)"
+  shows "transforms tm6 (tpsL t) ttt (tps6 t)"
+  unfolding tm6_def
+proof (tform tps: assms(1) tps0 tps5_def tps6_def jk)
+  have "2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2 =
+      (literal_n \<circ> rename \<sigma>) (n_literal (clause ! t))"
+    using clause assms(1) literal_n_rename by simp
+  then have "2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2 =
+      (map (literal_n \<circ> rename \<sigma>) (n_clause clause)) ! t"
+    using assms(1) by (simp add: n_clause_def)
+  then have "take t (map (literal_n \<circ> rename \<sigma>) (n_clause clause)) @
+        [2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2] =
+      take (Suc t) (map (literal_n \<circ> rename \<sigma>) (n_clause clause))"
+    by (simp add: assms(1) n_clause_def take_Suc_conv_app_nth)
+  then show "tps6 t = (tps5 t)
+      [j + 2 := nltape
+        (take t (map (literal_n \<circ> rename \<sigma>) (n_clause clause)) @
+         [2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2])]"
+    unfolding tps5_def tps6_def
+    by (simp only: list_update_overwrite list_update_swap_less[of "j + 2"]) simp
+  show "ttt = 41 + 4 * nlength (clause ! t) + 18 * (nllength \<sigma>)\<^sup>2 +
+      4 * nlength (\<sigma> ! (clause ! t div 2)) +
+      (7 + nllength (take t (map (literal_n \<circ> rename \<sigma>) (n_clause clause))) -
+       Suc (nllength (take t (map (literal_n \<circ> rename \<sigma>) (n_clause clause)))) +
+       2 * nlength (2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2))"
+    using assms(2) by simp
+qed
+
+lemma nlength_\<sigma>1:
+  assumes "t < length clause"
+  shows "nlength (clause ! t) \<le> nllength \<sigma>"
+proof -
+  have "clause ! t div 2 < length \<sigma>"
+    using clause assms(1) by simp
+  then have "nlength (clause ! t div 2) < length \<sigma>"
+    using nlength_le_n by (meson leD le_less_linear order.trans)
+  then have "nlength (clause ! t) \<le> length \<sigma>"
+    using canrepr_div_2 by simp
+  then show "nlength (clause ! t) \<le> nllength \<sigma>"
+    using length_le_nllength by (meson dual_order.trans mult_le_mono2)
+qed
+
+lemma nlength_\<sigma>2:
+  assumes "t < length clause"
+  shows "nlength (\<sigma> ! (clause ! t div 2)) \<le> nllength \<sigma>"
+  using assms clause member_le_nllength nth_mem by simp
+
+lemma nlength_\<sigma>3:
+  assumes "t < length clause"
+  shows "nlength (2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2) \<le> Suc (nllength \<sigma>)"
+proof -
+  have "nlength (2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2) \<le> nlength (2 * \<sigma> ! (clause ! t div 2) + 1)"
+    using nlength_mono by simp
+  also have "... \<le> Suc (nlength (\<sigma> ! (clause ! t div 2)))"
+    using nlength_times2plus1 by (meson dual_order.trans)
+  finally show ?thesis
+    using nlength_\<sigma>2 assms by fastforce
+qed
+
+lemma tm6' [transforms_intros]:
+  assumes "t < length clause"
+   and "ttt = 49 + 28 * nllength \<sigma> ^ 2"
+  shows "transforms tm6 (tpsL t) ttt (tps6 t)"
+proof -
+  let ?ttt = "47 + 4 * nlength (clause ! t) + 18 * (nllength \<sigma>)\<^sup>2 +
+      4 * nlength (\<sigma> ! (clause ! t div 2)) +
+      2 * nlength (2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2)"
+
+  have "?ttt \<le> 47 + 4 * nllength \<sigma> + 18 * (nllength \<sigma>)\<^sup>2 +
+      4 * nllength \<sigma> + 2 * Suc (nllength \<sigma>)"
+    using nlength_\<sigma>1 nlength_\<sigma>3 nlength_\<sigma>2 assms(1) by fastforce
+  also have "... = 49 + 10 * nllength \<sigma> + 18 * (nllength \<sigma>)\<^sup>2"
+    by simp
+  also have "... \<le> 49 + 10 * nllength \<sigma> ^ 2 + 18 * (nllength \<sigma>)\<^sup>2"
+    using linear_le_pow by simp
+  also have "... = 49 + 28 * nllength \<sigma> ^ 2"
+    by simp
+  finally have "?ttt \<le> 49 + 28 * nllength \<sigma> ^ 2" .
+  then show ?thesis
+    using tm6 assms transforms_monotone by blast
+qed
+
+definition "tps7 t \<equiv> tps0
+  [j + 1 := nltape' clause (Suc t),
+   j + 2 := nltape (take (Suc t) (map literal_n (map (rename \<sigma>) (n_clause clause)))),
+   j + 4 := (\<lfloor>clause ! t mod 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm7:
+  assumes "t < length clause"
+   and "ttt = 59 + 28 * nllength \<sigma> ^ 2 +
+      2 * nlength (2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2)"
+  shows "transforms tm7 (tpsL t) ttt (tps7 t)"
+  unfolding tm7_def
+proof (tform tps: assms(1) tps0 tps6_def tps7_def jk time: assms(2))
+  show "tps7 t = (tps6 t)[j + 3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    using tps6_def tps7_def tps0 jk
+    by (smt (z3) add_left_cancel list_update_id list_update_overwrite list_update_swap num.simps(8)
+      numeral_eq_iff one_eq_numeral_iff semiring_norm(84))
+qed
+
+lemma tm7' [transforms_intros]:
+  assumes "t < length clause"
+   and "ttt = 61 + 30 * nllength \<sigma> ^ 2"
+  shows "transforms tm7 (tpsL t) ttt (tps7 t)"
+proof -
+  let ?ttt = "59 + 28 * nllength \<sigma> ^ 2 +
+      2 * nlength (2 * \<sigma> ! (clause ! t div 2) + clause ! t mod 2)"
+  have "?ttt \<le> 59 + 28 * nllength \<sigma> ^ 2 + 2 * Suc (nllength \<sigma>)"
+    using nlength_\<sigma>3 assms(1) by fastforce
+  also have "... = 61 + 28 * nllength \<sigma> ^ 2 + 2 * nllength \<sigma>"
+    by simp
+  also have "... \<le> 61 + 30 * nllength \<sigma> ^ 2"
+    using linear_le_pow by simp
+  finally have "?ttt \<le> 61 + 30 * nllength \<sigma> ^ 2" .
+  then show ?thesis
+    using assms tm7 transforms_monotone by blast
+qed
+
+definition "tps8 t \<equiv> tps0
+  [j + 1 := nltape' clause (Suc t),
+   j + 2 := nltape (take (Suc t) (map literal_n (map (rename \<sigma>) (n_clause clause))))]"
+
+lemma tm8:
+  assumes "t < length clause"
+    and "ttt = 61 + 30 * (nllength \<sigma>)\<^sup>2 + (10 + 2 * nlength (clause ! t mod 2))"
+  shows "transforms tm8 (tpsL t) ttt (tps8 t)"
+  unfolding tm8_def
+proof (tform tps: assms(1) tps0 tps7_def tps8_def jk time: assms(2))
+  show "tps8 t = (tps7 t)[j + 4 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    using tps7_def tps8_def tps0 jk
+    by (smt (z3) add_left_imp_eq list_update_id list_update_overwrite list_update_swap numeral_eq_iff
+      numeral_eq_one_iff semiring_norm(85) semiring_norm(87))
+qed
+
+lemma tm8' [transforms_intros]:
+  assumes "t < length clause"
+    and "ttt = 71 + 32 * (nllength \<sigma>)\<^sup>2"
+  shows "transforms tm8 (tpsL t) ttt (tpsL (Suc t))"
+proof -
+  have "nlength (clause ! t mod 2) \<le> nllength \<sigma>"
+    using assms(1) nlength_\<sigma>1 by (meson mod_less_eq_dividend nlength_mono order.trans)
+  then have "nlength (clause ! t mod 2) \<le> nllength \<sigma> ^ 2"
+    using linear_le_pow by (metis nat_le_linear power2_nat_le_imp_le verit_la_disequality)
+  then have "61 + 30 * (nllength \<sigma>)\<^sup>2 + (10 + 2 * nlength (clause ! t mod 2)) \<le> ttt"
+    using assms(2) by simp
+  then have "transforms tm8 (tpsL t) ttt (tps8 t)"
+    using assms(1) tm8 transforms_monotone by blast
+  moreover have "tps8 t = tpsL (Suc t)"
+    using tps8_def tpsL_def by simp
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma tmL [transforms_intros]:
+  assumes "ttt = length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (length clause))"
+  unfolding tmL_def
+proof (tform)
+  let ?t = "71 + 32 * (nllength \<sigma>)\<^sup>2"
+  show "read (tpsL t) ! (j + 1) \<noteq> \<box>" if "t < length clause" for t
+  proof -
+    have "tpsL t ! (j + 1) = nltape' clause t"
+      using tpsL_def jk by simp
+    then show ?thesis
+      using nltape'_tape_read that tapes_at_read' tpsL_def jk
+      by (smt (z3) Suc_eq_plus1 leD length_list_update less_add_same_cancel1 less_trans_Suc zero_less_numeral)
+  qed
+  show "\<not> read (tpsL (length clause)) ! (j + 1) \<noteq> \<box>"
+  proof -
+    have "tpsL (length clause) ! (j + 1) = nltape' clause (length clause)"
+      using tpsL_def jk by simp
+    then show ?thesis
+      using nltape'_tape_read tapes_at_read' tpsL_def jk
+      by (smt (z3) Suc_eq_plus1 length_list_update less_add_same_cancel1 less_or_eq_imp_le less_trans_Suc zero_less_numeral)
+  qed
+  show "length clause * (71 + 32 * (nllength \<sigma>)\<^sup>2 + 2) + 1 \<le> ttt"
+    using assms(1) by simp
+qed
+
+lemma tpsL_length: "tpsL (length clause) = tps0
+  [j + 1 := nltape' clause (length clause),
+   j + 2 := nltape (map literal_n (map (rename \<sigma>) (n_clause clause)))]"
+  using tpsL_def by (simp add: n_clause_def)
+
+definition "tps9 \<equiv> tps0
+  [j + 1 := nltape' clause (length clause),
+   j + 2 := (\<lfloor>map literal_n (map (rename \<sigma>) (n_clause clause))\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm9:
+  assumes "ttt = 4 + length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) +
+      nllength (map (literal_n \<circ> rename \<sigma>) (n_clause clause))"
+  shows "transforms tm9 (tpsL 0) ttt tps9"
+  unfolding tm9_def
+proof (tform tps: tps0 tps9_def tpsL_def jk tpsL_length)
+  show "clean_tape (tpsL (length clause) ! (j + 2))"
+    using tpsL_def jk clean_tape_nlcontents tps0(3) by simp
+  show "ttt = length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) + 1 +
+    (tpsL (length clause) :#: (j + 2) + 2)"
+    using n_clause_def assms jk tpsL_length by fastforce
+qed
+
+lemma tm9' [transforms_intros]:
+  assumes "ttt = 4 + 2 * length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2)"
+  shows "transforms tm9 tps0 ttt tps9"
+proof -
+  let ?ttt = "4 + length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) +
+    nllength (map (literal_n \<circ> rename \<sigma>) (n_clause clause))"
+  have "?ttt \<le> 4 + length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) +
+      length clause * Suc (nllength \<sigma>)"
+    using clause nllength_rename by simp
+  also have "... \<le> 4 + length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) +
+      length clause * (Suc (nllength \<sigma> ^ 2))"
+    by (simp add: linear_le_pow)
+  also have "... \<le> 4 + length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) +
+      length clause * (73 + nllength \<sigma> ^ 2)"
+    by (metis One_nat_def Suc_eq_plus1 Suc_leI add.commute add_left_mono mult_le_mono2 zero_less_numeral)
+  also have "... \<le> 4 + length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) +
+      length clause * (73 + 32 * nllength \<sigma> ^ 2)"
+    by simp
+  also have "... = 4 + 2 * length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2)"
+    by simp
+  finally have "?ttt \<le> 4 + 2 * length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2)" .
+  then show ?thesis
+    using tm9 assms transforms_monotone tpsL_eq_tps0 by fastforce
+qed
+
+definition "tps10 \<equiv> tps0
+  [j + 1 := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+   j + 2 := (\<lfloor>map literal_n (map (rename \<sigma>) (n_clause clause))\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm10:
+  assumes "ttt = 11 + 2 * length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) + 3 * nllength clause"
+  shows "transforms tm10 tps0 ttt tps10"
+  unfolding tm10_def
+proof (tform tps: tps0 tps9_def jk)
+  show "tps9 ::: (j + 1) = \<lfloor>numlist clause\<rfloor>"
+    using tps9_def jk tps0(2) nlcontents_def by simp
+  show "proper_symbols (numlist clause)"
+    using proper_symbols_numlist by simp
+  show "tps10 = tps9[j + 1 := (\<lfloor>[]\<rfloor>, 1)]"
+    by (simp add: jk nlcontents_def tps0 tps10_def tps9_def list_update_swap numlist_Nil)
+  show "ttt = 4 + 2 * length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) +
+      (tps9 :#: (j + 1) + 2 * length (numlist clause) + 6)"
+    using assms tps9_def jk nllength_def by simp
+qed
+
+lemma tm10':
+  assumes "ttt = 11 + 64 * nllength clause * (3 + (nllength \<sigma>)\<^sup>2)"
+  shows "transforms tm10 tps0 ttt tps10"
+proof -
+  let ?ttt = "11 + 2 * length clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) + 3 * nllength clause"
+  have "?ttt \<le> 11 + 2 * nllength clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) + 3 * nllength clause"
+    by (simp add: length_le_nllength)
+  also have "... \<le> 11 + 2 * nllength clause * (73 + 32 * (nllength \<sigma>)\<^sup>2) + 2 * 2 * nllength clause"
+    by simp
+  also have "... = 11 + 2 * nllength clause * (75 + 32 * (nllength \<sigma>)\<^sup>2)"
+    by algebra
+  also have "... \<le> 11 + 2 * nllength clause * (96 + 32 * (nllength \<sigma>)\<^sup>2)"
+    by simp
+  also have "... = 11 + 2 * 32 * nllength clause * (3 + (nllength \<sigma>)\<^sup>2)"
+    by simp
+  also have "... = 11 + 64 * nllength clause * (3 + (nllength \<sigma>)\<^sup>2)"
+    by simp
+  finally have "?ttt \<le> 11 + 64 * nllength clause * (3 + (nllength \<sigma>)\<^sup>2)" .
+  then show ?thesis
+    using tm10 assms transforms_monotone by blast
+qed
+
+end
+
+end  (* locale turing_machine_relabel-clause *)
+
+lemma transforms_tm_relabel_clauseI [transforms_intros]:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k :: nat and \<sigma> clause :: "nat list"
+  assumes "0 < j" "j + 4 < k" "length tps = k"
+    and "\<forall>v\<in>set clause. v div 2 < length \<sigma>"
+  assumes
+    "tps ! j = (\<lfloor>\<sigma>\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! (j + 1) = (\<lfloor>clause\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 11 + 64 * nllength clause * (3 + (nllength \<sigma>)\<^sup>2)"
+  assumes "tps' = tps
+    [j + 1 := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+     j + 2 := (\<lfloor>clause_n (map (rename \<sigma>) (n_clause clause))\<rfloor>\<^sub>N\<^sub>L, 1)]"
+  shows "transforms (tm_relabel_clause j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_relabel_clause j .
+  show ?thesis
+    using assms loc.tm10_eq_tm_relabel_clause loc.tps10_def loc.tm10' clause_n_def by simp
+qed
+
+
+subsection \<open>Relabeling CNF formulas\<close>
+
+text \<open>
+A Turing machine can relabel a CNF formula by relabeling each clause using the
+TM @{const tm_relabel_clause}. The next TM accepts a CNF formula as a list of
+lists of literals on tape $j_1$ and a substitution $\sigma$ as a list of numbers
+on tape $j_2 + 1$. It outputs the relabeled formula on tape $j_2$, which
+initially must be empty.
+\<close>
+
+definition tm_relabel :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_relabel j1 j2 \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO
+      tm_nextract \<sharp> j1 (j2 + 2) ;;
+      tm_relabel_clause (j2 + 1) ;;
+      tm_appendl j2 (j2 + 3) ;;
+      tm_erase_cr (j2 + 3)
+    DONE ;;
+    tm_cr j1 ;;
+    tm_cr j2"
+
+lemma tm_relabel_tm:
+  assumes "G \<ge> 6" and "j2 + 5 < k" and "0 < j1" and "j1 < j2"
+  shows "turing_machine k G (tm_relabel j1 j2)"
+  unfolding tm_relabel_def
+  using assms tm_cr_tm tm_nextract_tm tm_appendl_tm tm_relabel_clause_tm Nil_tm tm_erase_cr_tm turing_machine_loop_turing_machine
+  by simp
+
+locale turing_machine_relabel =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tmL1 \<equiv> tm_nextract \<sharp> j1 (j2 + 2)"
+definition "tmL2 \<equiv> tmL1 ;; tm_relabel_clause (j2 + 1)"
+definition "tmL3 \<equiv> tmL2 ;; tm_appendl j2 (j2 + 3)"
+definition "tmL4 \<equiv> tmL3 ;; tm_erase_cr (j2 + 3)"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO tmL4 DONE"
+definition "tm2 \<equiv> tmL ;; tm_cr j1"
+definition "tm3 \<equiv> tm2 ;; tm_cr j2"
+
+lemma tm3_eq_tm_relabel: "tm3 = tm_relabel j1 j2"
+  unfolding tm_relabel_def tm2_def tmL_def tmL4_def tmL3_def tmL2_def tmL1_def tm3_def by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and \<sigma> :: "nat list" and \<phi> :: formula
+  assumes variables: "variables \<phi> \<subseteq> {..<length \<sigma>}"
+  assumes jk: "0 < j1" "j1 < j2" "j2 + 5 < k" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>formula_n \<phi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps0 ! j2 = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps0 ! (j2 + 1) = (\<lfloor>\<sigma>\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! (j2 + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! (j2 + 3) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! (j2 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j2 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+abbreviation n\<phi> :: "nat list list" where
+  "n\<phi> \<equiv> formula_n \<phi>"
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+     [j1 := nlltape' n\<phi> t,
+      j2 := nlltape (formula_n (take t (relabel \<sigma> \<phi>)))]"
+
+lemma tpsL_eq_tps0: "tpsL 0 = tps0"
+  using tps0 tpsL_def formula_n_def nlllength_def numlist_Nil numlist_def numlistlist_def
+  by (metis One_nat_def list.map(1) list.size(3) list_update_id take0)
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+  "tpsL1 t \<equiv> tps0
+     [j1 := nlltape' n\<phi> (Suc t),
+      j2 := nlltape (formula_n (take t (relabel \<sigma> \<phi>))),
+      j2 + 2 := (\<lfloor>n\<phi> ! t\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tmL1 [transforms_intros]:
+  assumes "ttt = 12 + 2 * nllength (n\<phi> ! t)"
+    and "t < length \<phi>"
+  shows "transforms tmL1 (tpsL t) ttt (tpsL1 t)"
+  unfolding tmL1_def
+proof (tform tps: tps0 tpsL_def tpsL1_def jk)
+  show "t < length n\<phi>"
+    using assms(2) formula_n_def by simp
+  show "tpsL1 t = (tpsL t)
+      [j1 := nlltape' n\<phi> (Suc t),
+       j2 + 2 := (\<lfloor>n\<phi> ! t\<rfloor>\<^sub>N\<^sub>L, 1)]"
+    using tpsL1_def tpsL_def by (simp add: jk list_update_swap_less)
+  show "ttt = 12 + 2 * nllength [] + 2 * nllength (n\<phi> ! t)"
+    using assms(1) by simp
+qed
+
+definition tpsL2 :: "nat \<Rightarrow> tape list" where
+  "tpsL2 t \<equiv> tps0
+     [j1 := nlltape' n\<phi> (Suc t),
+      j2 := nlltape (formula_n (take t (relabel \<sigma> \<phi>))),
+      j2 + 2 := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+      j2 + 3 := (\<lfloor>clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tmL2 [transforms_intros]:
+  assumes "ttt = 23 + 2 * nllength (n\<phi> ! t) + 64 * nllength (n\<phi> ! t) * (3 + (nllength \<sigma>)\<^sup>2)"
+    and "t < length \<phi>"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL2 t)"
+  unfolding tmL2_def
+proof (tform tps: assms(2) tps0 tpsL1_def jk)
+  show "\<forall>v\<in>set (n\<phi> ! t). v div 2 < length \<sigma>"
+    using variables_\<sigma> variables assms(2) by (metis formula_n_def nth_map nth_mem)
+  have "tpsL1 t ! (j2 + (1 + 2)) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tpsL1_def jk tps0 by (simp add: numeral_3_eq_3)
+  then show "tpsL1 t ! (j2 + 1 + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    by (metis add.assoc)
+  have "tpsL1 t ! (j2 + (1 + 3)) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL1_def jk tps0 by simp
+  then show "tpsL1 t ! (j2 + 1 + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    by (metis add.assoc)
+  have "tpsL1 t ! (j2 + (1 + 4)) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL1_def jk tps0 by simp
+  then show "tpsL1 t ! (j2 + 1 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    by (metis add.assoc)
+  have "tpsL2 t = (tpsL1 t)
+    [j2 + (1 + 1) := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+     j2 + (1 + 2) := (\<lfloor>clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))\<rfloor>\<^sub>N\<^sub>L, 1)]"
+    using jk tps0 tpsL1_def tpsL2_def by (simp add: numeral_3_eq_3)
+  then show "tpsL2 t = (tpsL1 t)
+    [j2 + 1 + 1 := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+     j2 + 1 + 2 := (\<lfloor>clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))\<rfloor>\<^sub>N\<^sub>L, 1)]"
+    by (metis add.assoc)
+  show "ttt = 12 + 2 * nllength (n\<phi> ! t) +
+      (11 + 64 * nllength (n\<phi> ! t) * (3 + (nllength \<sigma>)\<^sup>2))"
+    using assms(1) by simp
+qed
+
+definition tpsL3 :: "nat \<Rightarrow> tape list" where
+  "tpsL3 t \<equiv> tps0
+     [j1 := nlltape' n\<phi> (Suc t),
+      j2 := nlltape
+        (formula_n (take t (relabel \<sigma> \<phi>)) @ [clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))]),
+      j2 + 2 := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+      j2 + 3 := (\<lfloor>clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tmL3 [transforms_intros]:
+  assumes "ttt = 29 + 2 * nllength (n\<phi> ! t) +
+      64 * nllength (n\<phi> ! t) * (3 + (nllength \<sigma>)\<^sup>2) +
+      2 * nllength (clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t))))"
+    and "t < length \<phi>"
+  shows "transforms tmL3 (tpsL t) ttt (tpsL3 t)"
+  unfolding tmL3_def
+proof (tform tps: assms(2) tps0 tpsL2_def jk)
+  show "tpsL3 t = (tpsL2 t)
+      [j2 := nlltape (formula_n (take t (relabel \<sigma> \<phi>)) @ [clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))])]"
+    unfolding tpsL3_def tpsL2_def by (simp add: list_update_swap_less[of j2])
+  show "ttt = 23 + 2 * nllength (n\<phi> ! t) + 64 * nllength (n\<phi> ! t) * (3 + (nllength \<sigma>)\<^sup>2) +
+      (7 + nlllength (formula_n (take t (relabel \<sigma> \<phi>))) - Suc (nlllength (formula_n (take t (relabel \<sigma> \<phi>)))) +
+       2 * nllength (clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))))"
+    using assms(1) by simp
+qed
+
+definition tpsL4 :: "nat \<Rightarrow> tape list" where
+  "tpsL4 t \<equiv> tps0
+     [j1 := nlltape' n\<phi> (Suc t),
+      j2 := nlltape
+        (formula_n (take t (relabel \<sigma> \<phi>)) @ [clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))]),
+      j2 + 2 := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tmL4:
+  assumes "ttt = 36 + 2 * nllength (n\<phi> ! t) +
+      64 * nllength (n\<phi> ! t) * (3 + (nllength \<sigma>)\<^sup>2) +
+      4 * nllength (clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t))))"
+    and "t < length \<phi>"
+  shows "transforms tmL4 (tpsL t) ttt (tpsL4 t)"
+  unfolding tmL4_def
+proof (tform tps: assms(2) tps0 tpsL3_def jk)
+  let ?zs = "numlist (clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t))))"
+  show "tpsL3 t ::: (j2 + 3) = \<lfloor>?zs\<rfloor>"
+    using tpsL3_def nlcontents_def jk by simp
+  show "proper_symbols ?zs"
+    using proper_symbols_numlist by simp
+  have *: "j1 \<noteq> j2 + 3"
+    using jk by simp
+  have "\<lfloor>[]\<rfloor> = \<lfloor>[]\<rfloor>\<^sub>N\<^sub>L"
+    using nlcontents_def numlist_Nil by simp
+  then show "tpsL4 t = (tpsL3 t)[j2 + 3 := (\<lfloor>[]\<rfloor>, 1)]"
+    using tpsL3_def tpsL4_def tps0 jk list_update_id[of tps0 "j2+3"]
+    by (simp add: list_update_swap[OF *] list_update_swap[of _ "j2 + 3"])
+  show "ttt = 29 + 2 * nllength (n\<phi> ! t) + 64 * nllength (n\<phi> ! t) * (3 + (nllength \<sigma>)\<^sup>2) +
+      2 * nllength (clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))) +
+      (tpsL3 t :#: (j2 + 3) + 2 * length (numlist (clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t))))) + 6)"
+    using assms(1) tpsL3_def jk nllength_def by simp
+qed
+
+lemma nllength_1:
+  assumes "t < length \<phi>"
+  shows "nllength (n\<phi> ! t) \<le> nlllength n\<phi>"
+  using assms formula_n_def nlllength_take by (metis le_less_linear length_map less_trans not_add_less2)
+
+lemma nllength_2:
+  assumes "t < length \<phi>"
+  shows "nllength (clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))) \<le> nlllength (formula_n (relabel \<sigma> \<phi>))"
+    (is "?l \<le> ?r")
+proof -
+  have "?l = nllength (clause_n (map (rename \<sigma>) (\<phi> ! t)))"
+    using assms by (simp add: formula_n_def n_clause_n)
+  moreover have "clause_n (map (rename \<sigma>) (\<phi> ! t)) \<in> set (formula_n (relabel \<sigma> \<phi>))"
+    using assms formula_n_def relabel_def by simp
+  ultimately show ?thesis
+    using member_le_nlllength_1 by fastforce
+qed
+
+definition "tpsL4' t \<equiv> tps0
+     [j1 := nlltape' n\<phi> (Suc t),
+      j2 := nlltape (formula_n (take (Suc t) (relabel \<sigma> \<phi>)))]"
+
+lemma tpsL4:
+  assumes "t < length \<phi>"
+  shows "tpsL4 t = tpsL4' t"
+proof -
+  have "formula_n (take t (relabel \<sigma> \<phi>)) @ [clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t)))] =
+      formula_n (take (Suc t) (relabel \<sigma> \<phi>))"
+    using assms formula_n_def relabel_def by (simp add: n_clause_n take_Suc_conv_app_nth)
+  then show ?thesis
+    using tpsL4_def tpsL4'_def jk tps0
+    by (smt (verit, del_insts) Suc_1 add_Suc_right add_cancel_left_right less_SucI
+      list_update_id list_update_swap not_less_eq numeral_1_eq_Suc_0 numeral_One)
+qed
+
+lemma tpsL4'_eq_tpsL: "tpsL4' t = tpsL (Suc t)"
+  using tpsL_def tpsL4'_def by simp
+
+lemma tmL4' [transforms_intros]:
+  assumes "ttt = 36 + 65 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) + 4 * nlllength (formula_n (relabel \<sigma> \<phi>))"
+    and "t < length \<phi>"
+  shows "transforms tmL4 (tpsL t) ttt (tpsL (Suc t))"
+proof -
+  let ?ttt = "36 + 2 * nllength (n\<phi> ! t) +
+      64 * nllength (n\<phi> ! t) * (3 + (nllength \<sigma>)\<^sup>2) +
+      4 * nllength (clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t))))"
+  have "?ttt \<le> 36 + 2 * nlllength n\<phi> +
+      64 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) +
+      4 * nllength (clause_n (map (rename \<sigma>) (n_clause (n\<phi> ! t))))"
+    using nllength_1 assms(2) add_le_mono add_le_mono1 mult_le_mono1 mult_le_mono2 nat_add_left_cancel_le
+    by metis
+  also have "... \<le> 36 + 2 * nlllength n\<phi> +
+      64 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) +
+      4 * nlllength (formula_n (relabel \<sigma> \<phi>))"
+    using nllength_2 assms(2) by simp
+  also have "... \<le> 36 + 65 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) + 4 * nlllength (formula_n (relabel \<sigma> \<phi>))"
+    by simp
+  finally have "?ttt \<le> 36 + 65 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) + 4 * nlllength (formula_n (relabel \<sigma> \<phi>))" .
+  then have "transforms tmL4 (tpsL t) ttt (tpsL4 t)"
+    using assms tmL4 transforms_monotone by blast
+  then show ?thesis
+    using assms(2) tpsL4'_eq_tpsL tpsL4 by simp
+qed
+
+lemma tmL:
+  assumes "ttt = length \<phi> * (38 + 65 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) + 4 * nlllength (formula_n (relabel \<sigma> \<phi>))) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (length \<phi>))"
+  unfolding tmL_def
+proof (tform)
+  let ?t = "36 + 65 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) + 4 * nlllength (formula_n (relabel \<sigma> \<phi>))"
+  show "\<not> read (tpsL (length \<phi>)) ! j1 \<noteq> \<box>"
+  proof -
+    have "tpsL (length \<phi>) ! j1 = nlltape' n\<phi> (length n\<phi>)"
+      using tpsL_def jk formula_n_def by simp
+    then show ?thesis
+      using nlltape'_tape_read[of n\<phi> "length n\<phi>"] tapes_at_read'[of j1 "tpsL (length \<phi>)"] tpsL_def jk
+      by simp
+  qed
+  show "read (tpsL t) ! j1 \<noteq> \<box>" if "t < length \<phi>" for t
+  proof -
+    have "tpsL t ! j1 = nlltape' n\<phi> t"
+      using tpsL_def jk by simp
+    then show ?thesis
+      using that formula_n_def nlltape'_tape_read[of n\<phi> t] tapes_at_read'[of j1 "tpsL t"] tpsL_def jk
+      by simp
+  qed
+  show "length \<phi> * (?t + 2) + 1 \<le> ttt"
+    using assms(1) by simp
+qed
+
+lemma tmL' [transforms_intros]:
+  assumes "ttt = 107 * nlllength n\<phi> ^ 2 * (3 + nllength \<sigma> ^ 2) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (length \<phi>))"
+proof -
+  let ?ttt = "length \<phi> * (38 + 65 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) + 4 * nlllength (formula_n (relabel \<sigma> \<phi>))) + 1"
+  have "?ttt \<le> length \<phi> * (38 + 65 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) + 4 * (Suc (nllength \<sigma>) * nlllength n\<phi>)) + 1"
+    using nlllength_relabel_variables variables by fastforce
+  also have "... \<le> length \<phi> * (38 + 65 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) + 4 * ((3 + nllength \<sigma>) * nlllength n\<phi>)) + 1"
+  proof -
+    have "Suc (nllength \<sigma>) \<le> 3 + nllength \<sigma>"
+      by simp
+    then show ?thesis
+      using add_le_mono le_refl mult_le_mono by presburger
+  qed
+  also have "... \<le> length \<phi> * (38 + 65 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2) + 4 * ((3 + nllength \<sigma> ^ 2) * nlllength n\<phi>)) + 1"
+    using linear_le_pow by simp
+  also have "... = length \<phi> * (38 + 69 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2)) + 1"
+    by simp
+  also have "... \<le> nlllength n\<phi> * (38 + 69 * nlllength n\<phi> * (3 + (nllength \<sigma>)\<^sup>2)) + 1"
+    using length_le_nlllength formula_n_def by (metis add_mono_thms_linordered_semiring(3) length_map mult_le_mono1)
+  also have "... = 38 * nlllength n\<phi> + (69 * nlllength n\<phi> ^ 2 * (3 + (nllength \<sigma>)\<^sup>2)) + 1"
+    by algebra
+  also have "... \<le> 38 * nlllength n\<phi> ^ 2 * (3 + nllength \<sigma> ^ 2) + (69 * nlllength n\<phi> ^ 2 * (3 + (nllength \<sigma>)\<^sup>2)) + 1"
+  proof -
+    have "nlllength n\<phi> \<le> nlllength n\<phi> ^ 2 * (3 + nllength \<sigma> ^ 2)"
+      using linear_le_pow by (metis One_nat_def Suc_leI add_gr_0 mult_le_mono nat_mult_1_right zero_less_numeral)
+    then show ?thesis
+      by simp
+  qed
+  also have "... = 107 * nlllength n\<phi> ^ 2 * (3 + nllength \<sigma> ^ 2) + 1"
+    by simp
+  finally have "?ttt \<le> 107 * nlllength n\<phi> ^ 2 * (3 + nllength \<sigma> ^ 2) + 1" .
+  then show ?thesis
+    using tmL assms transforms_monotone by blast
+qed
+
+definition tps1 :: "tape list" where
+  "tps1 \<equiv> tps0
+     [j1 := nlltape' n\<phi> (length \<phi>),
+      j2 := nlltape (formula_n (relabel \<sigma> \<phi>))]"
+
+lemma tps1_eq_tpsL: "tps1 = tpsL (length \<phi>)"
+  using tps1_def tpsL_def jk tps0 relabel_def by simp
+
+definition "tps2 \<equiv> tps0
+    [j2 := nlltape (formula_n (relabel \<sigma> \<phi>))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = Suc (107 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)) +
+      Suc (Suc (Suc (nlllength n\<phi>)))"
+  shows "transforms tm2 (tpsL 0) ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps0 tpsL_def tps1_def jk)
+  have *: "tpsL (length \<phi>) ! j1 = nlltape' n\<phi> (length \<phi>)"
+    using tpsL_def jk by simp
+  then show "clean_tape (tpsL (length \<phi>) ! j1)"
+    using clean_tape_nllcontents by simp
+  have "tpsL (length \<phi>) ! j1 |#=| 1 = nlltape' n\<phi> 0"
+    using * by simp
+  then show "tps2 = (tpsL (length \<phi>))[j1 := tpsL (length \<phi>) ! j1 |#=| 1]"
+    using tps0 jk tps2_def tps1_eq_tpsL tps1_def
+    by (metis (no_types, lifting) One_nat_def list_update_id list_update_overwrite list_update_swap_less nlllength_Nil take0)
+  show "ttt = 107 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2) + 1 +
+      (tpsL (length \<phi>) :#: j1 + 2)"
+    using assms tpsL_def jk formula_n_def by simp
+qed
+
+definition "tps3 \<equiv> tps0
+    [j2 := nlltape' (formula_n (relabel \<sigma> \<phi>)) 0]"
+
+lemma tm3:
+  assumes "ttt = 7 + (107 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)) +
+      nlllength n\<phi> + nlllength (formula_n (relabel \<sigma> \<phi>))"
+  shows "transforms tm3 (tpsL 0) ttt tps3"
+  unfolding tm3_def
+proof (tform tps: assms tps0 tps2_def tps3_def jk)
+  show "clean_tape (tps2 ! j2)"
+    using tps2_def jk clean_tape_nllcontents by simp
+qed
+
+lemma tm3' [transforms_intros]:
+  assumes "ttt = 7 + (108 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2))"
+  shows "transforms tm3 tps0 ttt tps3"
+proof -
+  let ?ttt = "7 + (107 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)) +
+      nlllength n\<phi> + nlllength (formula_n (relabel \<sigma> \<phi>))"
+  have "?ttt \<le> 7 + (107 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)) +
+      nlllength n\<phi> + Suc (nllength \<sigma>) * nlllength n\<phi>"
+    using variables nlllength_relabel_variables by simp
+  also have "... = 7 + (107 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)) +
+      (2 + nllength \<sigma>) * nlllength n\<phi>"
+    by simp
+  also have "... \<le> 7 + (107 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)) +
+      (2 + nllength \<sigma> ^ 2) * nlllength n\<phi>"
+    using linear_le_pow by simp
+  also have "... \<le> 7 + (107 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)) + (3 + nllength \<sigma> ^ 2) * nlllength n\<phi>"
+    by (metis add_2_eq_Suc add_Suc_shift add_mono_thms_linordered_semiring(2) le_add2 mult.commute mult_le_mono2 numeral_3_eq_3)
+  also have "... \<le> 7 + (107 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)) +
+      (3 + nllength \<sigma> ^ 2) * nlllength n\<phi> ^ 2"
+    using linear_le_pow by simp
+  also have "... = 7 + (108 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2))"
+    by simp
+  finally have "?ttt \<le> 7 + (108 * (nlllength n\<phi>)\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2))" .
+  then show ?thesis
+    using tm3 assms tpsL_eq_tps0 transforms_monotone by simp
+qed
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_relabel *)
+
+lemma transforms_tm_relabelI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k :: nat and \<sigma> :: "nat list" and \<phi> :: formula
+  assumes "0 < j1" and "j1 < j2" and "j2 + 5 < k" and "length tps = k"
+    and "variables \<phi> \<subseteq> {..<length \<sigma>}"
+  assumes
+    "tps ! j1 = (\<lfloor>formula_n \<phi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps ! j2 = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps ! (j2 + 1) = (\<lfloor>\<sigma>\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! (j2 + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! (j2 + 3) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! (j2 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j2 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "tps' = tps
+    [j2 := nlltape' (formula_n (relabel \<sigma> \<phi>)) 0]"
+  assumes "ttt = 7 + (108 * (nlllength (formula_n \<phi>))\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2))"
+  shows "transforms (tm_relabel j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_relabel j1 j2 .
+  show ?thesis
+    using assms loc.tm3_eq_tm_relabel loc.tm3' loc.tps3_def by simp
+qed
+
+
+section \<open>Listing the head positions of a Turing machine\<close>
+
+text \<open>
+The formulas $\chi_t$ used for $\Phi_9$ require the functions $\inputpos$ and
+$\prev$, or more precisely the substitutions $\rho_t$ and $\rho'_t$ do.
+
+In this section we build a TM that simulates a two-tape TM $M$ on some input
+until it halts. During the simulation it creates two lists: one with the
+sequence of head positions on $M$'s input tape and one with the sequence of head
+positions on $M$'s output tape. The first list directly provides $\inputpos$;
+the second list allows the computation of $\prev$ using the TM @{const tm_prev}.
+\<close>
+
+
+subsection \<open>Simulating and logging head movements\<close>
+
+text \<open>
+At the core of the simulation is the following Turing command. It interprets the
+tapes $j + 7$ and $j + 8$ as input tape and output tape of a two-tape Turing
+machine $M$ and the symbol in the first cell of tape $j + 6$ as the state of
+$M$. It then applies the actions of $M$ in this configuration to the tapes $j +
+7$ and $j + 8$ and adapts the state on tape $j + 6$ accordingly. On top of that
+it writes (``logs'') to tape $j$ the direction in which $M$'s input tape head
+has moved and to tape $j + 3$ the direction in which $M$'s work tape head has
+moved.
+
+The head movement directions are encoded by the symbols $\Box$,
+$\triangleright$, and \textbf{0} for Left, Stay, and Right, respectively.
+
+The command is parameterized by the TM $M$ and its alphabet size $G$ (and as
+usual the tape index $j$). The command does nothing if the state on tape $j + 6$
+is the halting state or if the symbol read from the simulated tape $j + 7$ or $j
++ 8$ is outside the alphabet $G$.
+
+\null
+\<close>
+
+definition direction_to_symbol :: "direction \<Rightarrow> symbol" where
+  "direction_to_symbol d \<equiv> (case d of Left \<Rightarrow> \<box> | Stay \<Rightarrow> \<triangleright> | Right \<Rightarrow> \<zero>)"
+
+lemma direction_to_symbol_less: "direction_to_symbol d < 3"
+  using direction_to_symbol_def by (cases d) simp_all
+
+definition cmd_simulog :: "nat \<Rightarrow> machine \<Rightarrow> tapeidx \<Rightarrow> command" where
+  "cmd_simulog G M j rs \<equiv>
+   (1,
+    if rs ! (j + 6) \<ge> length M \<or> rs ! (j + 7) \<ge> G \<or> rs ! (j + 8) \<ge> G
+    then map (\<lambda>z. (z, Stay)) rs
+    else
+      map (\<lambda>i. let sas = (M ! (rs ! (j + 6))) [rs ! (j + 7), rs ! (j + 8)] in
+          if i = j then (direction_to_symbol (sas [~] 0), Stay)
+          else if i = j + 3 then (direction_to_symbol (sas [~] 1), Stay)
+          else if i = j + 6 then (fst sas, Stay)
+          else if i = j + 7 then sas [!] 0
+          else if i = j + 8 then sas [!] 1
+          else (rs ! i, Stay))
+        [0..<length rs])"
+
+lemma turing_command_cmd_simulog:
+  fixes G H :: nat
+  assumes "turing_machine 2 G M" and "k \<ge> j + 9" and "j > 0" and "H \<ge> Suc (length M)" and "H \<ge> G"
+  shows "turing_command k 1 H (cmd_simulog G M j)"
+proof
+  show "\<And>gs. length gs = k \<Longrightarrow> length ([!!] cmd_simulog G M j gs) = length gs"
+    using cmd_simulog_def by simp
+  have G: "H \<ge> 4"
+    using assms(1,5) turing_machine_def by simp
+  show "cmd_simulog G M j rs [.] i < H"
+    if "length rs = k" and "(\<And>i. i < length rs \<Longrightarrow> rs ! i < H)" and "i < length rs"
+    for rs i
+  proof (cases "rs ! (j + 6) \<ge> length M \<or> rs ! (j + 7) \<ge> G \<or> rs ! (j + 8) \<ge> G")
+    case True
+    then show ?thesis
+      using assms that cmd_simulog_def by simp
+  next
+    case False
+    then have inbounds: "rs ! (j + 6) < length M"
+      by simp
+    let ?cmd = "M ! (rs ! (j + 6))"
+    let ?gs = "[rs ! (j + 7), rs ! (j + 8)]"
+    let ?sas = "?cmd ?gs"
+    have lensas: "length (snd ?sas) = 2"
+      using assms(1) inbounds turing_commandD(1)
+      by (metis length_Cons list.size(3) numeral_2_eq_2 turing_machineD(3))
+    consider
+        "i = j"
+      | "i = j + 3"
+      | "i = j + 6"
+      | "i = j + 7"
+      | "i = j + 8"
+      | "i \<noteq> j \<and> i \<noteq> j + 3 \<and> i \<noteq> j + 6 \<and> i \<noteq> j + 7 \<and> i \<noteq> j + 8"
+      by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "cmd_simulog G M j rs [!] i = (direction_to_symbol (?sas [~] 0), Stay)"
+        using cmd_simulog_def False that by simp
+      then have "cmd_simulog G M j rs [.] i < 3"
+        using direction_to_symbol_less by simp
+      then show ?thesis
+        using G by simp
+    next
+      case 2
+      then have "cmd_simulog G M j rs [!] i = (direction_to_symbol (?sas [~] 1), Stay)"
+        using cmd_simulog_def False that by simp
+      then have "cmd_simulog G M j rs [.] i < 3"
+        using direction_to_symbol_less by simp
+      then show ?thesis
+        using G by simp
+    next
+      case 3
+      then have "cmd_simulog G M j rs [!] i = (fst ?sas, Stay)"
+        using cmd_simulog_def False that by simp
+      then have "cmd_simulog G M j rs [.] i \<le> length M"
+        using assms inbounds turing_commandD(4) turing_machineD(3)
+        by (metis One_nat_def Suc_1 fst_conv length_Cons list.size(3))
+      then show ?thesis
+        using assms(4) by simp
+    next
+      case 4
+      then have "cmd_simulog G M j rs [!] i = ?sas [!] 0"
+        using cmd_simulog_def False that by simp
+      then show ?thesis
+        using 4 assms inbounds turing_machine_def that lensas turing_commandD(3)
+        by (metis One_nat_def Suc_1 length_Cons list.size(3) nth_Cons_0 nth_mem zero_less_numeral)
+    next
+      case 5
+      then have *: "cmd_simulog G M j rs [!] i = ?sas [!] 1"
+        using cmd_simulog_def False that by simp
+      have "turing_command 2 (length M) G ?cmd"
+        using assms(1) inbounds turing_machine_def by simp
+      moreover have "symbols_lt G ?gs"
+        using False less_2_cases_iff numeral_2_eq_2 by simp
+      ultimately have "?sas [.] 1 < G"
+        using turing_commandD(2) by simp
+      then show ?thesis
+        using assms * by simp
+    next
+      case 6
+      then have "cmd_simulog G M j rs [!] i = (rs ! i, Stay)"
+        using cmd_simulog_def False that(3) by simp
+      then show ?thesis
+        using that by simp
+    qed
+  qed
+  show "cmd_simulog G M j rs [.] 0 = rs ! 0" if "length rs = k" and "0 < k" for rs
+  proof (cases "rs ! (j + 6) \<ge> length M \<or> rs ! (j + 7) \<ge> G \<or> rs ! (j + 8) \<ge> G")
+    case True
+    then show ?thesis
+      using assms that cmd_simulog_def by simp
+  next
+    case False
+    then show ?thesis
+      using assms that cmd_simulog_def by simp
+  qed
+  show "\<And>gs. length gs = k \<Longrightarrow> [*] (cmd_simulog G M j gs) \<le> 1"
+    using cmd_simulog_def by simp
+qed
+
+text \<open>
+The logging Turing machine consists only of the logging command.
+\<close>
+
+definition tm_simulog :: "nat \<Rightarrow> machine \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_simulog G M j \<equiv> [cmd_simulog G M j]"
+
+lemma tm_simulog_tm:
+  fixes H :: nat
+  assumes "turing_machine 2 G M" and "k \<ge> j + 9" and "j > 0" and "H \<ge> Suc (length M)" and "H \<ge> G"
+  shows "turing_machine k H (tm_simulog G M j)"
+  using turing_command_cmd_simulog tm_simulog_def assms turing_machine_def by simp
+
+lemma transforms_tm_simulogI [transforms_intros]:
+  fixes G :: nat and M :: machine and j :: tapeidx
+  fixes k :: nat and tps tps' :: "tape list" and xs :: "symbol list"
+  assumes "turing_machine 2 G M" and "k \<ge> j + 9" and "j > 0"
+    and "symbols_lt G xs"
+    and "cfg = execute M (start_config 2 xs) t" and "fst cfg < length M"
+    and "length tps = k"
+  assumes
+    "tps ! j = \<lceil>dummy1\<rceil>"
+    "tps ! (j + 3) = \<lceil>dummy2\<rceil>"
+    "tps ! (j + 6) = \<lceil>fst cfg\<rceil>"
+    "tps ! (j + 7) = cfg <!> 0"
+    "tps ! (j + 8) = cfg <!> 1"
+  assumes "tps' = tps
+     [j := \<lceil>direction_to_symbol ((M ! (fst cfg)) (config_read cfg) [~] 0)\<rceil>,
+      j + 3 := \<lceil>direction_to_symbol ((M ! (fst cfg)) (config_read cfg) [~] 1)\<rceil>,
+      j + 6 := \<lceil>fst (execute M (start_config 2 xs) (Suc t))\<rceil>,
+      j + 7 := execute M (start_config 2 xs) (Suc t) <!> 0,
+      j + 8 := execute M (start_config 2 xs) (Suc t) <!> 1]"
+  shows "transforms (tm_simulog G M j) tps 1 tps'"
+proof -
+  have "sem (cmd_simulog G M j) (0, tps) = (1, tps')"
+  proof (rule semI)
+    define H where "H = max G (Suc (length M))"
+    then have "H \<ge> Suc (length M)" "H \<ge> G"
+      by simp_all
+    then show "proper_command k (cmd_simulog G M j)"
+      using assms cmd_simulog_def by simp
+    show "length tps = k" and "length tps' = k"
+      using assms by simp_all
+    show "fst (cmd_simulog G M j (read tps)) = 1"
+      using cmd_simulog_def sem' by simp
+
+    define rs where "rs = read tps"
+    then have lenrs: "length rs = k"
+      by (simp add: assms rs_def read_length)
+    have rs6: "rs ! (j + 6) = fst cfg"
+      using rs_def tapes_at_read'[of "j + 6" tps] assms by simp
+    then have inbounds: "rs ! (j + 6) < length M"
+      using assms by simp
+    have rs7: "rs ! (j + 7) = cfg <.> 0"
+      using rs_def tapes_at_read'[of "j + 7" tps] assms by simp
+    then have rs7_less: "rs ! (j + 7) < G"
+      using assms tape_alphabet[OF assms(1,4)] by simp
+    have rs8: "rs ! (j + 8) = cfg <.> 1"
+      using rs_def tapes_at_read'[of "j + 8" tps] assms by simp
+    then have rs8_less: "rs ! (j + 8) < G"
+      using assms tape_alphabet[OF assms(1,4)] by simp
+    let ?gs = "[rs ! (j + 7), rs ! (j + 8)]"
+    have gs: "?gs = config_read cfg"
+    proof (rule nth_equalityI)
+      show "length [rs ! (j + 7), rs ! (j + 8)] = length (config_read cfg)"
+        using assms execute_num_tapes start_config_length read_length by simp
+      then show "[rs ! (j + 7), rs ! (j + 8)] ! i = config_read cfg ! i"
+          if "i < length [rs ! (j + 7), rs ! (j + 8)]" for i
+        using assms that rs7 rs8 read_length tapes_at_read'
+        by (metis One_nat_def length_Cons less_2_cases_iff list.size(3) nth_Cons_0 nth_Cons_Suc numeral_2_eq_2)
+    qed
+    let ?cmd = "M ! (rs ! (j + 6))"
+    let ?sas = "?cmd ?gs"
+    have lensas: "length (snd ?sas) = 2"
+      using assms(1) inbounds turing_commandD(1) turing_machine_def
+      by (metis One_nat_def Suc_1 canrepr_1 list.size(4) nlength_1_simp nth_mem plus_1_eq_Suc)
+    have sas: "?sas = (M ! (fst cfg)) (config_read cfg)"
+      using rs6 gs by simp
+    have "act (cmd_simulog G M j rs [!] i) (tps ! i) = tps' ! i" if "i < k" for i
+    proof -
+      have "cmd_simulog G M j rs =
+      (1, map (\<lambda>i. let sas = (M ! (rs ! (j + 6))) [rs ! (j + 7), rs ! (j + 8)] in
+              if i = j then (direction_to_symbol (sas [~] 0), Stay)
+              else if i = j + 3 then (direction_to_symbol (sas [~] 1), Stay)
+              else if i = j + 6 then (fst sas, Stay)
+              else if i = j + 7 then sas [!] 0
+              else if i = j + 8 then sas [!] 1
+              else (rs ! i, Stay))
+            [0..<length rs])"
+        using inbounds rs7_less rs8_less assms cmd_simulog_def by simp
+      then have *: "cmd_simulog G M j rs [!] i =
+         (if i = j then (direction_to_symbol (?sas [~] 0), Stay)
+          else if i = j + 3 then (direction_to_symbol (?sas [~] 1), Stay)
+          else if i = j + 6 then (fst ?sas, Stay)
+          else if i = j + 7 then ?sas [!] 0
+          else if i = j + 8 then ?sas [!] 1
+          else (rs ! i, Stay))"
+        using that lenrs by simp
+      consider
+          "i = j"
+        | "i = j + 3"
+        | "i = j + 6"
+        | "i = j + 7"
+        | "i = j + 8"
+        | "i \<noteq> j \<and> i \<noteq> j + 3 \<and> i \<noteq> j + 6 \<and> i \<noteq> j + 7 \<and> i \<noteq> j + 8"
+        by linarith
+      then show ?thesis
+      proof (cases)
+        case 1
+        then have "cmd_simulog G M j rs [!] i = (direction_to_symbol (?sas [~] 0), Stay)"
+          using * by simp
+        moreover have "tps' ! i = \<lceil>direction_to_symbol (?sas [~] 0)\<rceil>"
+          using 1 assms sas by simp
+        ultimately show ?thesis
+          using 1 act_onesie assms(8) by simp
+      next
+        case 2
+        then have "cmd_simulog G M j rs [!] i = (direction_to_symbol (?sas [~] 1), Stay)"
+          using * by simp
+        moreover have "tps' ! i = \<lceil>direction_to_symbol (?sas [~] 1)\<rceil>"
+          using 2 assms sas by simp
+        ultimately show ?thesis
+          using 2 act_onesie assms by simp
+      next
+        case 3
+        then have "cmd_simulog G M j rs [!] i = (fst ?sas, Stay)"
+          using * by simp
+        moreover have "tps' ! i = \<lceil>fst (execute M (start_config 2 xs) (Suc t))\<rceil>"
+          using 3 assms by simp
+        ultimately show ?thesis
+          using 3 act_onesie assms by (metis exe_lt_length execute.simps(2) sas sem_fst)
+      next
+        case 4
+        then have "cmd_simulog G M j rs [!] i = ?sas [!] 0"
+          using * by simp
+        moreover have "tps' ! i = execute M (start_config 2 xs) (Suc t) <!> 0"
+          using 4 assms by simp
+        moreover have "proper_command 2 (M ! (rs ! (j + 6)))"
+          using assms(1,6) rs6 turing_machine_def turing_commandD(1) turing_machineD by metis
+        ultimately show ?thesis
+          using 4 assms(1,11,5,6) exe_lt_length gs read_length rs6 sem_snd turing_machine_def
+          by (metis execute.simps(2) length_Cons list.size(3) numeral_2_eq_2 zero_less_numeral)
+      next
+        case 5
+        then have "cmd_simulog G M j rs [!] i = ?sas [!] 1"
+          using * by simp
+        moreover have "tps' ! i = execute M (start_config 2 xs) (Suc t) <!> 1"
+          using 5 assms by simp
+        moreover have "proper_command 2 (M ! (rs ! (j + 6)))"
+          using assms(1,6) rs6 turing_machineD turing_commandD(1) by metis
+        ultimately show ?thesis
+          using 5 assms(1,12,5,6) exe_lt_length gs read_length rs6 sem_snd turing_machine_def
+          by (metis One_nat_def execute.simps(2) length_Cons less_2_cases_iff list.size(3) numeral_2_eq_2)
+      next
+        case 6
+        then have "cmd_simulog G M j rs [!] i = (rs ! i, Stay)"
+          using * by simp
+        moreover have "tps' ! i = tps ! i"
+          using 6 assms(13) by simp
+        ultimately show ?thesis
+          using 6 assms act_Stay rs_def that by metis
+      qed
+    qed
+    then show "act (cmd_simulog G M j (read tps) [!] i) (tps ! i) = tps' ! i" if "i < k" for i
+      using that rs_def by simp
+  qed
+  moreover have "execute (tm_simulog G M j) (0, tps) 1 = sem (cmd_simulog G M j) (0, tps)"
+    using tm_simulog_def by (simp add: exe_lt_length)
+  ultimately have "execute (tm_simulog G M j) (0, tps) 1 = (1, tps')"
+    by simp
+  then show ?thesis
+    using transforms_def transits_def tm_simulog_def by auto
+qed
+
+
+subsection \<open>Adjusting head position counters\<close>
+
+text \<open>
+The Turing machine @{const tm_simulog} logs the head movements, but what we need
+is a list of all the head positions during the execution of $M$. The next TM
+maintains a number for a head position and adjusts it based on a head movement
+symbol as provided by @{const tm_simulog}.
+
+More precisely, the next Turing machine accepts on tape $j$ a symbol encoding a
+direction, on tape $j + 1$ a number representing a head position, and on tape $j
++ 2$ a list of numbers.  Depending on the symbol on tape $j$ it decreases,
+increases or leaves unchanged the number on tape $j + 1$. Then it appends this
+adjusted number to the list on tape $j + 2$.
+\<close>
+
+definition tm_adjust_headpos :: "nat \<Rightarrow> machine" where
+  "tm_adjust_headpos j \<equiv>
+    IF \<lambda>rs. rs ! j = \<box> THEN
+      tm_decr (j + 1)
+    ELSE
+      IF \<lambda>rs. rs ! j = \<zero> THEN
+        tm_incr (j + 1)
+      ELSE
+        []
+      ENDIF
+    ENDIF ;;
+    tm_append (j + 2) (j + 1)"
+
+lemma tm_adjust_headpos_tm:
+  assumes "G \<ge> 5" and "j + 2 < k"
+  shows "turing_machine k G (tm_adjust_headpos j)"
+  unfolding tm_adjust_headpos_def
+  using assms turing_machine_branch_turing_machine tm_decr_tm tm_incr_tm tm_append_tm Nil_tm turing_machine_sequential_turing_machine
+  by simp
+
+locale turing_machine_adjust_headpos =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> IF \<lambda>rs. rs ! j = \<zero> THEN tm_incr (j + 1) ELSE [] ENDIF"
+definition "tm2 \<equiv> IF \<lambda>rs. rs ! j = \<box> THEN tm_decr (j + 1) ELSE tm1 ENDIF"
+definition "tm3 \<equiv> tm2 ;; tm_append (j + 2) (j + 1)"
+
+lemma tm3_eq_tm_adjust_headpos: "tm3 = tm_adjust_headpos j"
+  unfolding tm1_def tm2_def tm3_def tm_adjust_headpos_def by simp
+
+context
+  fixes tps :: "tape list" and jj :: tapeidx and k t :: nat and xs :: "symbol list"
+  fixes M :: machine
+  fixes G cfg
+  assumes jk: "length tps = k" "k \<ge> j + 3" "jj < 2"
+  assumes M: "turing_machine 2 G M"
+  assumes xs: "symbols_lt G xs"
+  assumes cfg: "cfg = execute M (start_config 2 xs) t" "fst cfg < length M"
+  assumes tps0:
+    "tps ! j = \<lceil>direction_to_symbol ((M ! (fst cfg)) (config_read cfg) [~] jj)\<rceil>"
+    "tps ! (j + 1) = (\<lfloor>cfg <#> jj\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = nltape (map (\<lambda>t. (execute M (start_config 2 xs) t <#> jj)) [0..<Suc t])"
+begin
+
+lemma k_ge_2: "2 \<le> k"
+  using jk by simp
+
+abbreviation exc :: "symbol list \<Rightarrow> nat \<Rightarrow> config" where
+  "exc y tt \<equiv> execute M (start_config 2 y) tt"
+
+lemma read_tps_j: "read tps ! j = direction_to_symbol ((M ! (fst cfg)) (config_read cfg) [~] jj)"
+  using tps0 onesie_read jk tapes_at_read'
+  by (metis less_add_same_cancel1 less_le_trans zero_less_numeral)
+
+lemma write_symbol:
+  "\<exists>v. execute M (start_config 2 xs) (Suc t) <!> jj = act (v, (M ! (fst cfg)) (config_read cfg) [~] jj) (cfg <!> jj)"
+proof -
+  let ?d = "(M ! (fst cfg)) (config_read cfg) [~] jj"
+  obtain v where v: "(M ! (fst cfg)) (config_read cfg) [!] jj = (v, ?d)"
+    by (simp add: prod_eq_iff)
+  have "execute M (start_config 2 xs) (Suc t) <!> jj = exe M cfg <!> jj"
+    using cfg(1) by simp
+  also have "... = sem (M ! (fst cfg)) cfg <!> jj"
+    by (simp add: cfg(2) exe_lt_length)
+  also have "... = act ((M ! (fst cfg)) (config_read cfg) [!] jj) (cfg <!> jj)"
+    using sem_snd_tm M cfg execute_num_tapes start_config_length jk
+    by (metis (no_types, lifting) numeral_2_eq_2 prod.exhaust_sel zero_less_Suc)
+  also have "... = act (v, ?d) (cfg <!> jj)"
+    using v by simp
+  finally have *: "execute M (start_config 2 xs) (Suc t) <!> jj = act (v, ?d) (cfg <!> jj)" .
+  then show ?thesis
+    by auto
+qed
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 7 + 2 * nlength (cfg <#> jj)"
+    and "(M ! (fst cfg)) (config_read cfg) [~] jj \<noteq> Left"
+    and "tps' = tps[j + 1 := (\<lfloor>execute M (start_config 2 xs) (Suc t) <#> jj\<rfloor>\<^sub>N, 1)]"
+  shows "transforms tm1 tps ttt tps'"
+  unfolding tm1_def
+proof (tform)
+  let ?d = "(M ! (fst cfg)) (config_read cfg) [~] jj"
+  obtain v where v: "execute M (start_config 2 xs) (Suc t) <!> jj = act (v, ?d) (cfg <!> jj)"
+    using write_symbol by auto
+
+  { assume "read tps ! j = 2"
+    then have "?d = Right"
+      using read_tps_j assms(2) direction_to_symbol_def by (cases ?d) simp_all
+    show "j + 1 < length tps"
+      using jk by simp
+    show "tps ! (j + 1) = (\<lfloor>cfg <#> jj\<rfloor>\<^sub>N, 1)"
+      using tps0 by simp_all
+    show "tps' = tps[j + 1 := (\<lfloor>Suc (cfg <#> jj)\<rfloor>\<^sub>N, 1)]"
+    proof -
+      have "execute M (start_config 2 xs) (Suc t) <!> jj = cfg <!> jj |:=| v |+| 1"
+        using v `?d = Right` act_Right' by simp
+      then have "execute M (start_config 2 xs) (Suc t) <#> jj = cfg <#> jj + 1"
+        by simp
+      then show ?thesis
+        using assms(3) by simp
+    qed
+  }
+  { assume "read tps ! j \<noteq> 2"
+    then have "?d = Stay"
+      using read_tps_j assms(2) direction_to_symbol_def by (cases ?d) simp_all
+    then have "execute M (start_config 2 xs) (Suc t) <!> jj = cfg <!> jj |:=| v"
+      using v act_Stay' by simp
+    then have "execute M (start_config 2 xs) (Suc t) <#> jj = cfg <#> jj"
+      by simp
+    then show "tps' = tps"
+      using assms(3) tps0 by (metis list_update_id)
+  }
+  show "(5 + 2 * nlength (cfg <#> jj)) + 2 \<le> ttt" "0 + 1 \<le> ttt"
+    using assms(1) by simp_all
+qed
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 10 + 2 * nlength (cfg <#> jj)"
+    and "tps' = tps[j + 1 := (\<lfloor>execute M (start_config 2 xs) (Suc t) <#> jj\<rfloor>\<^sub>N, 1)]"
+  shows "transforms tm2 tps ttt tps'"
+  unfolding tm2_def
+proof (tform tps: k_ge_2 jk assms)
+  let ?d = "(M ! (fst cfg)) (config_read cfg) [~] jj"
+  show "8 + 2 * nlength (cfg <#> jj) + 2 \<le> ttt"
+    using assms(1) by simp
+  show "read tps ! j \<noteq> \<box> \<Longrightarrow> ?d \<noteq> Left"
+    using read_tps_j direction_to_symbol_def by (cases ?d) simp_all
+  { assume 0: "read tps ! j = \<box>"
+    show "tps ! (j + 1) = (\<lfloor>cfg <#> jj\<rfloor>\<^sub>N, 1)"
+      using tps0 by simp
+    show "tps' = tps[j + 1 := (\<lfloor>cfg <#> jj - 1\<rfloor>\<^sub>N, 1)]"
+    proof -
+      let ?d = "(M ! (fst cfg)) (config_read cfg) [~] jj"
+      obtain v where v: "execute M (start_config 2 xs) (Suc t) <!> jj = act (v, ?d) (cfg <!> jj)"
+        using write_symbol by auto
+      then have "?d = Left"
+        using 0 read_tps_j assms(2) direction_to_symbol_def by (cases ?d) simp_all
+      then have "execute M (start_config 2 xs) (Suc t) <!> jj = cfg <!> jj |:=| v |-| 1"
+        using v act_Left' by simp
+      then have "execute M (start_config 2 xs) (Suc t) <#> jj = cfg <#> jj - 1"
+        by simp
+      then show ?thesis
+        using assms(2) by simp
+    qed
+  }
+qed
+
+lemma tm3:
+  assumes "ttt = 16 + 2 * nlength (cfg <#> jj) + 2 * nlength (exc xs (Suc t) <#> jj)"
+    and "tps' = tps
+      [j + 1 := (\<lfloor>execute M (start_config 2 xs) (Suc t) <#> jj\<rfloor>\<^sub>N, 1),
+       j + 2 := nltape (map (\<lambda>t. (execute M (start_config 2 xs) t <#> jj)) [0..<Suc (Suc t)])]"
+  shows "transforms tm3 tps ttt tps'"
+  unfolding tm3_def
+proof (tform tps: jk assms)
+  let ?ns = "(map (\<lambda>t. (execute M (start_config 2 xs) t <#> jj)) [0..<Suc t])"
+  let ?i = "Suc (nllength (map (\<lambda>t. (execute M (start_config 2 xs) t <#> jj)) [0..<Suc t]))"
+  let ?n = "exc xs (Suc t) <#> jj"
+  let ?tps = "tps[j + 1 := (\<lfloor>exc xs (Suc t) <#> jj\<rfloor>\<^sub>N, 1)]"
+  show "?tps ! (j + 2) = (\<lfloor>?ns\<rfloor>\<^sub>N\<^sub>L, ?i)"
+    using tps0 by simp
+  show "Suc (nllength ?ns) \<le> ?i"
+    by simp
+  show "tps' = tps
+    [j + 1 := (\<lfloor>?n\<rfloor>\<^sub>N, 1),
+     j + 2 := nltape (?ns @ [snd (exe M (exc xs t)) :#: jj])]"
+    using assms(2) nlcontents_def nllength_def by simp
+  show "ttt =
+      10 + 2 * nlength (cfg <#> jj) +
+      (7 + nllength (map (\<lambda>t. exc xs t <#> jj) [0..<Suc t]) -
+       Suc (nllength (map (\<lambda>t. exc xs t <#> jj) [0..<Suc t])) +
+       2 * nlength (snd (exe M (exc xs t)) :#: jj))"
+    using assms(1) by simp
+qed
+
+end  (* context tps k *)
+
+end  (* locale turing_machine_adjust_headpos *)
+
+lemma transforms_tm_adjust_headposI [transforms_intros]:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and k jj t :: nat and xs :: "symbol list"
+    and M :: machine and G :: nat and cfg :: config
+  assumes "turing_machine 2 G M"
+    and "length tps = k" and "k \<ge> j + 3" and "jj < 2"
+    and "symbols_lt G xs"
+    and cfg: "cfg = execute M (start_config 2 xs) t" "fst cfg < length M"
+  assumes
+    "tps ! j = \<lceil>direction_to_symbol ((M ! (fst cfg)) (config_read cfg) [~] jj)\<rceil>"
+    "tps ! (j + 1) = (\<lfloor>cfg <#> jj\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = nltape (map (\<lambda>t. (execute M (start_config 2 xs) t <#> jj)) [0..<Suc t])"
+  assumes max_head_pos: "\<forall>t. execute M (start_config 2 xs) t <#> jj \<le> max_head_pos"
+  assumes ttt: "ttt = 16 + 4 * nlength max_head_pos"
+  assumes "tps' = tps
+    [j + 1 := (\<lfloor>execute M (start_config 2 xs) (Suc t) <#> jj\<rfloor>\<^sub>N, 1),
+     j + 2 := nltape (map (\<lambda>t. (execute M (start_config 2 xs) t <#> jj)) [0..<Suc (Suc t)])]"
+  shows "transforms (tm_adjust_headpos j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_adjust_headpos j .
+  let ?ttt = "16 + 2 * nlength (cfg <#> jj) + 2 * nlength (execute M (start_config 2 xs) (Suc t) <#> jj)"
+  have "transforms (tm_adjust_headpos j) tps ?ttt tps'"
+    using assms loc.tm3_eq_tm_adjust_headpos loc.tm3 by simp
+  moreover have "?ttt \<le> ttt"
+  proof -
+    have "?ttt \<le> 16 + 2 * nlength (cfg <#> jj) + 2 * nlength max_head_pos"
+      using max_head_pos nlength_mono by (meson add_le_mono le_refl mult_le_mono2)
+    also have "... \<le> 16 + 2 * nlength max_head_pos + 2 * nlength max_head_pos"
+      using max_head_pos cfg nlength_mono by simp
+    also have "... = 16 + 4 * nlength max_head_pos"
+      by simp
+    finally show ?thesis
+      using ttt by simp
+  qed
+  ultimately show ?thesis
+    using transforms_monotone by simp
+qed
+
+
+subsection \<open>Listing the head positions\<close>
+
+text \<open>
+The next Turing machine is essentially a loop around the TM @{const tm_simulog}, which
+outputs head movements, combined with two instances of the TM @{const
+tm_adjust_headpos}, each of which maintains a head positions lists. The loop
+ends when the simulated machine reaches the halting state.  If the simulated
+machine does not halt, neither does the simulator, but we will not consider this
+case when we analyze the semantics. The TM receives an input on tape $j + 7$.
+During the simulation of $M$ this tape is a replica of the simulated machine's
+input tape, and tape $j + 8$ is a replica of the work/output tape. The lists of
+the head positions will be on tapes $j + 2$ and $j + 5$ for the input tape and
+work/output tape, respectively.
+\<close>
+
+definition tm_list_headpos :: "nat \<Rightarrow> machine \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_list_headpos G M j \<equiv>
+    tm_right_many {j + 1, j + 2, j + 4, j+ 5} ;;
+    tm_write (j + 6) \<box> ;;
+    tm_append (j + 2) (j + 1) ;;
+    tm_append (j + 5) (j + 4) ;;
+    WHILE [] ; \<lambda>rs. rs ! (j + 6) < length M DO
+      tm_simulog G M j ;;
+      tm_adjust_headpos j ;;
+      tm_adjust_headpos (j + 3) ;;
+      tm_write_many {j, j + 3} \<triangleright>
+    DONE ;;
+    tm_write (j + 6) \<triangleright> ;;
+    tm_cr (j + 2) ;;
+    tm_cr (j + 5)"
+
+lemma tm_list_headpos_tm:
+  fixes H :: nat
+  assumes "turing_machine 2 G M" and "k \<ge> j + 9" and "j > 0" and "H \<ge> Suc (length M)" and "H \<ge> G"
+  assumes "H \<ge> 5"
+  shows "turing_machine k H (tm_list_headpos G M j)"
+  unfolding tm_list_headpos_def
+  using assms turing_machine_loop_turing_machine turing_machine_sequential_turing_machine Nil_tm
+    tm_append_tm tm_simulog_tm tm_adjust_headpos_tm tm_right_many_tm tm_write_tm tm_write_many_tm tm_cr_tm
+  by simp
+
+locale turing_machine_list_headpos =
+  fixes G :: nat and M :: machine and j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_right_many {j + 1, j + 2, j + 4, j + 5}"
+definition "tm2 \<equiv> tm1 ;; tm_write (j + 6) \<box>"
+definition "tm3 \<equiv> tm2 ;; tm_append (j + 2) (j + 1)"
+definition "tm4 \<equiv> tm3 ;; tm_append (j + 5) (j + 4)"
+definition "tmL1 \<equiv> tm_simulog G M j"
+definition "tmL2 \<equiv> tmL1 ;; tm_adjust_headpos j"
+definition "tmL3 \<equiv> tmL2 ;; tm_adjust_headpos (j + 3)"
+definition "tmL4 \<equiv> tmL3 ;; tm_write_many {j, j + 3} \<triangleright>"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! (j + 6) < length M DO tmL4 DONE"
+definition "tm5 \<equiv> tm4 ;; tmL"
+definition "tm6 \<equiv> tm5 ;; tm_write (j + 6) \<triangleright>"
+definition "tm7 \<equiv> tm6 ;; tm_cr (j + 2)"
+definition "tm8 \<equiv> tm7 ;; tm_cr (j + 5)"
+
+lemma tm8_eq_tm_list_headpos: "tm8 = tm_list_headpos G M j"
+  unfolding tm1_def tm2_def tm3_def tm4_def tmL1_def tmL2_def tmL3_def tmL4_def tmL_def tm5_def tm6_def tm7_def tm8_def
+    tm_list_headpos_def
+  by simp
+
+context
+  fixes tps0 :: "tape list"
+  fixes thalt k :: nat and xs :: "symbol list"
+  assumes M: "turing_machine 2 G M"
+  assumes jk: "k \<ge> j + 9" "j > 0" "length tps0 = k"
+  assumes thalt:
+    "\<forall>t<thalt. fst (execute M (start_config 2 xs) t) < length M"
+    "fst (execute M (start_config 2 xs) thalt) = length M"
+  assumes xs: "symbols_lt G xs"
+  assumes tps0:
+    "tps0 ! j = \<lceil>\<triangleright>\<rceil>"
+    "tps0 ! (j + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 0)"
+    "tps0 ! (j + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 0)"
+    "tps0 ! (j + 3) = \<lceil>\<triangleright>\<rceil>"
+    "tps0 ! (j + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 0)"
+    "tps0 ! (j + 5) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 0)"
+    "tps0 ! (j + 6) = \<lceil>\<triangleright>\<rceil>"
+    "tps0 ! (j + 7) = (\<lfloor>xs\<rfloor>, 0)"
+    "tps0 ! (j + 8) = (\<lfloor>[]\<rfloor>, 0)"
+begin
+
+abbreviation exec :: "nat \<Rightarrow> config" where
+  "exec t \<equiv> execute M (start_config 2 xs) t"
+
+lemma max_head_pos_0: "\<forall>t. exec t <#> 0 \<le> thalt"
+  using thalt M head_pos_le_halting_time by simp
+
+lemma max_head_pos_1: "\<forall>t. exec t <#> 1 \<le> thalt"
+  using thalt M head_pos_le_halting_time by simp
+
+definition "tps1 \<equiv> tps0
+  [(j + 1) := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   (j + 2) := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+   (j + 4) := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   (j + 5) := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+   (j + 6) := \<lceil>\<triangleright>\<rceil>]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 1"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: assms tps0 jk tps1_def)
+  show "tps1 = map (\<lambda>i. if i \<in> {j + 1, j + 2, j + 4, j + 5} then tps0 ! i |+| 1
+                        else tps0 ! i) [0..<length tps0]"
+     (is "tps1 = ?rhs")
+  proof (rule nth_equalityI)
+    show len: "length tps1 = length ?rhs"
+      by (simp add: tps1_def)
+    let ?J = "{j + 1, j + 2, j + 4, j + 5}"
+    show "tps1 ! i = ?rhs ! i" if "i < length tps1" for i
+    proof (cases "i \<in> ?J")
+      case True
+      have "tps1 ! (j + 1) = ?rhs ! (j + 1)"
+        using tps1_def jk tps0 by fastforce
+      moreover have "tps1 ! (j + 2) = ?rhs ! (j + 2)"
+        using tps1_def jk tps0 by fastforce
+      moreover have "tps1 ! (j + 4) = ?rhs ! (j + 4)"
+        using tps1_def jk tps0 by fastforce
+      moreover have "tps1 ! (j + 5) = ?rhs ! (j + 5)"
+        using tps1_def jk tps0 by fastforce
+      ultimately show ?thesis
+        using True by fast
+    next
+      case notinJ: False
+      then have *: "?rhs ! i = tps0 ! i"
+        using that len by simp
+      show ?thesis
+      proof (cases "i = j + 6")
+        case True
+        then show ?thesis
+          using * that tps0(7) tps1_def by simp
+      next
+        case False
+        then have "tps1 ! i = tps0 ! i"
+          using tps1_def notinJ that by simp
+        then show ?thesis
+          using * by simp
+      qed
+    qed
+  qed
+qed
+
+definition "tps2 \<equiv> tps0
+  [(j + 1) := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   (j + 2) := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+   (j + 4) := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   (j + 5) := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+   (j + 6) := \<lceil>\<box>\<rceil>]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 2"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: assms tps0 jk tps2_def tps1_def)
+  show "tps2 = tps1[j + 6 := tps1 ! (j + 6) |:=| 0]"
+    using tps2_def tps1_def jk onesie_write
+    by (smt (z3) list_update_beyond list_update_overwrite nth_list_update_eq verit_comp_simplify1(3))
+qed
+
+definition "tps3 \<equiv> tps0
+  [(j + 1) := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   (j + 2) := nltape [0],
+   (j + 4) := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   (j + 5) := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+   (j + 6) := \<lceil>\<box>\<rceil>]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 8"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps0 jk tps2_def tps3_def)
+  show "tps3 = tps2[j + 2 := nltape ([] @ [0])]"
+    using tps3_def jk tps2_def
+    by (smt (verit, ccfv_SIG) Suc3_eq_add_3 add_2_eq_Suc add_less_cancel_left lessI list_update_overwrite
+      list_update_swap not_add_less2 numeral_2_eq_2 numeral_3_eq_3 numeral_Bit0 numeral_plus_numeral
+      self_append_conv2 semiring_norm(4) semiring_norm(5))
+  show "ttt = 2 + (7 + nllength [] - Suc 0 + 2 * nlength 0)"
+    using assms by simp
+qed
+
+definition "tps4 \<equiv> tps0
+  [(j + 1) := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   (j + 2) := nltape [0],
+   (j + 4) := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   (j + 5) := nltape [0],
+   (j + 6) := \<lceil>\<box>\<rceil>]"
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 14"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: tps3_def jk tps0 tps4_def)
+  show "tps4 = tps3[j + 5 := nltape ([] @ [0])]"
+    unfolding tps3_def tps4_def
+    using jk tps0
+    by (smt (z3) add_left_imp_eq list_update_overwrite list_update_swap num.simps(8) numeral_eq_iff self_append_conv2)
+  show "ttt = 8 + (7 + nllength [] - Suc 0 + 2 * nlength 0)"
+    using assms by simp
+qed
+
+text \<open>The tapes after $t$ iterations:\<close>
+
+definition "tpsL t \<equiv> tps0
+  [(j + 1) := (\<lfloor>exec t <#> 0\<rfloor>\<^sub>N, 1),
+   (j + 2) := nltape (map (\<lambda>t. exec t <#> 0) [0..<Suc t]),
+   (j + 4) := (\<lfloor>exec t <#> 1\<rfloor>\<^sub>N, 1),
+   (j + 5) := nltape (map (\<lambda>t. exec t <#> 1) [0..<Suc t]),
+   (j + 6) := \<lceil>fst (exec t)\<rceil>,
+   (j + 7) := exec t <!> 0,
+   (j + 8) := exec t <!> 1]"
+
+lemma lentpsL: "length (tpsL t) = k"
+  using jk tpsL_def by simp
+
+lemma tpsL_0_eq_tps4: "tpsL 0 = tps4"
+proof -
+  have *: "exec 0 = (0, [(\<lfloor>xs\<rfloor>, 0), (\<lfloor>[]\<rfloor>, 0)])"
+    using start_config_def contents_def by auto
+  show ?thesis
+    (is "tpsL 0 = ?rhs")
+  proof (rule nth_equalityI)
+    show "length (tpsL 0) = length ?rhs"
+      by (simp add: tps4_def tpsL_def)
+    show "tpsL 0 ! i = ?rhs ! i" if "i < length (tpsL 0)" for i
+    proof -
+      show ?thesis
+      proof (cases "i = j \<or> i = j + 1 \<or> i = j + 2 \<or> i = j + 4 \<or> i = j + 5 \<or> i = j + 6 \<or> i = j + 7 \<or> i = j + 8")
+        case True
+        then show ?thesis
+          unfolding tps4_def tpsL_def using * tps0 jk by auto
+      next
+        case False
+        then show ?thesis
+          unfolding tps4_def tpsL_def using * tps0 jk that by (smt (z3) nth_list_update_neq)
+      qed
+    qed
+  qed
+qed
+
+definition "tpsL1 t \<equiv> tps0
+  [j := \<lceil>direction_to_symbol ((M ! fst (exec t)) (config_read (exec t)) [~] 0)\<rceil>,
+   j + 1 := (\<lfloor>exec t <#> 0\<rfloor>\<^sub>N, 1),
+   j + 2 := nltape (map (\<lambda>t. exec t <#> 0) [0..<Suc t]),
+   j + 3 := \<lceil>direction_to_symbol ((M ! fst (exec t)) (config_read (exec t)) [~] 1)\<rceil>,
+   j + 4 := (\<lfloor>exec t <#> 1\<rfloor>\<^sub>N, 1),
+   j + 5 := nltape (map (\<lambda>t. exec t <#> 1) [0..<Suc t]),
+   j + 6 := \<lceil>fst (exec (Suc t))\<rceil>,
+   j + 7 := exec (Suc t) <!> 0,
+   j + 8 := exec (Suc t) <!> 1]"
+
+lemma lentpsL1: "length (tpsL1 t) = k"
+    using jk tpsL1_def by (simp only: length_list_update)
+
+lemma tmL1 [transforms_intros]:
+  assumes "fst (exec t) < length M"
+  shows "transforms tmL1 (tpsL t) 1 (tpsL1 t)"
+  unfolding tmL1_def
+proof (tform tps: M xs jk assms)
+  show "j + 9 \<le> length (tpsL t)"
+    using tpsL_def jk by (simp only: length_list_update)
+  show "tpsL t ! j = \<lceil>\<triangleright>\<rceil>"
+    using tpsL_def tps0 by (simp only: nth_list_update_eq nth_list_update_neq)
+  show "tpsL t ! (j + 3) = \<lceil>\<triangleright>\<rceil>"
+    using tpsL_def tps0 by (simp only: nth_list_update_eq nth_list_update_neq)
+  show "tpsL t ! (j + 6) = \<lceil>fst (exec t)\<rceil>"
+    using tpsL_def tps0 jk by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  show "tpsL t ! (j + 7) = exec t <!> 0"
+    using tpsL_def tps0 jk by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  show " tpsL t ! (j + 8) = exec t <!> 1"
+    using tpsL_def tps0 jk by (simp only: length_list_update nth_list_update_eq nth_list_update_neq One_nat_def)
+  show "tpsL1 t = (tpsL t)
+    [j := \<lceil>direction_to_symbol ((M ! fst (exec t)) (config_read (exec t)) [~] 0)\<rceil>,
+     j + 3 := \<lceil>direction_to_symbol ((M ! fst (exec t)) (config_read (exec t)) [~] 1)\<rceil>,
+     j + 6 := \<lceil>fst (exec (Suc t))\<rceil>,
+     j + 7 := exec (Suc t) <!> 0,
+     j + 8 := exec (Suc t) <!> 1]"
+    unfolding tpsL1_def tpsL_def
+    by (simp only: list_update_overwrite list_update_swap_less[of "j+7"] list_update_swap_less[of "j+6"]
+      list_update_swap_less[of "j+3"] list_update_swap_less[of "j"])
+qed
+
+definition "tpsL2 t \<equiv> tps0
+  [j := \<lceil>direction_to_symbol ((M ! fst (exec t)) (config_read (exec t)) [~] 0)\<rceil>,
+   j + 1 := (\<lfloor>exec (Suc t) <#> 0\<rfloor>\<^sub>N, 1),
+   j + 2 := nltape (map (\<lambda>t. exec t <#> 0) [0..<Suc (Suc t)]),
+   j + 3 := \<lceil>direction_to_symbol ((M ! fst (exec t)) (config_read (exec t)) [~] 1)\<rceil>,
+   j + 4 := (\<lfloor>exec t <#> 1\<rfloor>\<^sub>N, 1),
+   j + 5 := nltape (map (\<lambda>t. exec t <#> 1) [0..<Suc t]),
+   j + 6 := \<lceil>fst (exec (Suc t))\<rceil>,
+   j + 7 := exec (Suc t) <!> 0,
+   j + 8 := exec (Suc t) <!> 1]"
+
+lemma lentpsL2: "length (tpsL2 t) = k"
+    using jk tpsL2_def by (simp only: length_list_update)
+
+lemma tmL2 [transforms_intros]:
+  assumes "fst (exec t) < length M"
+    and "ttt = 17 + 4 * nlength thalt"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL2 t)"
+  unfolding tmL2_def
+proof (tform tps: M xs jk assms(1))
+  show "\<forall>t. exec t <#> 0 \<le> thalt"
+    using max_head_pos_0 by simp
+  show "j + 3 \<le> length (tpsL1 t)"
+    using lentpsL1 jk by simp
+  show "(0 :: nat) < 2"
+    by simp
+  show "tpsL1 t ! j = \<lceil>direction_to_symbol ((M ! fst (exec t)) (config_read (exec t)) [~] 0)\<rceil>"
+    using tpsL1_def jk lentpsL1 by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  show "tpsL1 t ! (j + 1) = (\<lfloor>exec t <#> 0\<rfloor>\<^sub>N, 1)"
+    using tpsL1_def jk by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  show "tpsL1 t ! (j + 2) = nltape (map (\<lambda>t. snd (exec t) :#: 0) [0..<Suc t])"
+    using tpsL1_def jk lentpsL1 by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  show "tpsL2 t = (tpsL1 t)
+      [j + 1 := (\<lfloor>exec (Suc t) <#> 0\<rfloor>\<^sub>N, 1),
+       j + 2 := nltape (map (\<lambda>t. exec t <#> 0) [0..<Suc (Suc t)])]"
+    unfolding tpsL1_def tpsL2_def
+    by (simp only: list_update_overwrite list_update_swap_less[of "j+1"] list_update_swap_less[of "j+2"])
+  show "ttt = 1 + (16 + 4 * nlength thalt)"
+    using assms(2) by simp
+qed
+
+definition "tpsL3 t \<equiv> tps0
+  [j := \<lceil>direction_to_symbol ((M ! fst (exec t)) (config_read (exec t)) [~] 0)\<rceil>,
+   j + 1 := (\<lfloor>exec (Suc t) <#> 0\<rfloor>\<^sub>N, 1),
+   j + 2 := nltape (map (\<lambda>t. exec t <#> 0) [0..<Suc (Suc t)]),
+   j + 3 := \<lceil>direction_to_symbol ((M ! fst (exec t)) (config_read (exec t)) [~] 1)\<rceil>,
+   j + 4 := (\<lfloor>exec (Suc t) <#> 1\<rfloor>\<^sub>N, 1),
+   j + 5 := nltape (map (\<lambda>t. exec t <#> 1) [0..<Suc (Suc t)]),
+   j + 6 := \<lceil>fst (exec (Suc t))\<rceil>,
+   j + 7 := exec (Suc t) <!> 0,
+   j + 8 := exec (Suc t) <!> 1]"
+
+lemma lentpsL3: "length (tpsL3 t) = k"
+  using jk tpsL3_def by (simp only: length_list_update)
+
+lemma tmL3 [transforms_intros]:
+  assumes "fst (exec t) < length M" and "ttt = 33 + 8 * nlength thalt"
+  shows "transforms tmL3 (tpsL t) ttt (tpsL3 t)"
+  unfolding tmL3_def
+proof (tform tps: M jk assms(1))
+  show "\<forall>t. exec t <#> 1 \<le> thalt"
+    using max_head_pos_1 .
+  show "j + 3 + 3 \<le> length (tpsL2 t)"
+    using tpsL2_def jk by (simp only: length_list_update)
+  show "symbols_lt G xs"
+    using xs .
+  show "(1 :: nat) < 2"
+    by simp
+  show "tpsL2 t ! (j + 3) = \<lceil>direction_to_symbol ((M ! fst (exec t)) (config_read (exec t)) [~] 1)\<rceil>"
+    using tpsL2_def jk lentpsL2 by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "j + 3 + 1 = j + 4"
+    by simp
+  then show "tpsL2 t ! (j + 3 + 1) = (\<lfloor>exec t <#> 1\<rfloor>\<^sub>N, 1)"
+    using tpsL2_def jk by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "j + 3 + 2 = j + 5"
+    by simp
+  then show "tpsL2 t ! (j + 3 + 2) = nltape (map (\<lambda>t. exec t <#> 1) [0..<Suc t])"
+    using tpsL2_def jk lentpsL2 by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "tpsL3 t = (tpsL2 t)
+      [j + 4 := (\<lfloor>snd (exec (Suc t)) :#: 1\<rfloor>\<^sub>N, 1),
+       j + 5 := nltape (map (\<lambda>t. snd (exec t) :#: 1) [0..<Suc (Suc t)])]"
+    unfolding tpsL2_def tpsL3_def
+    by (simp only: list_update_overwrite list_update_swap_less[of "j+4"] list_update_swap_less[of "j+5"])
+  moreover have "j + 3 + 1 = j + 4" "j + 3 + 2 = j + 5"
+    by simp_all
+  ultimately show "tpsL3 t = (tpsL2 t)
+      [j + 3 + 1 := (\<lfloor>snd (exec (Suc t)) :#: 1\<rfloor>\<^sub>N, 1),
+       j + 3 + 2 := nltape (map (\<lambda>t. snd (exec t) :#: 1) [0..<Suc (Suc t)])]"
+    by metis
+  show "ttt = 17 + 4 * nlength thalt + (16 + 4 * nlength thalt)"
+    using assms(2) by simp
+qed
+
+definition "tpsL4 t \<equiv> tps0
+  [j + 1 := (\<lfloor>exec (Suc t) <#> 0\<rfloor>\<^sub>N, 1),
+   j + 2 := nltape (map (\<lambda>t. exec t <#> 0) [0..<Suc (Suc t)]),
+   j + 4 := (\<lfloor>exec (Suc t) <#> 1\<rfloor>\<^sub>N, 1),
+   j + 5 := nltape (map (\<lambda>t. exec t <#> 1) [0..<Suc (Suc t)]),
+   j + 6 := \<lceil>fst (exec (Suc t))\<rceil>,
+   j + 7 := exec (Suc t) <!> 0,
+   j + 8 := exec (Suc t) <!> 1]"
+
+lemma lentpsL4: "length (tpsL4 t) = k"
+  using jk tpsL4_def by (simp only: length_list_update)
+
+lemma tmL4:
+  assumes "fst (exec t) < length M"
+    and "ttt = 34 + 8 * nlength thalt"
+  shows "transforms tmL4 (tpsL t) ttt (tpsL4 t)"
+  unfolding tmL4_def
+proof (tform tps: jk assms(1) lentpsL3 lentpsL4 time: assms)
+  have "tpsL4 t ! i = tpsL3 t ! i |:=| Suc 0" if "i = j \<or> i = j + 3 " for i
+  proof (cases "i = j")
+    case True
+    then show ?thesis
+      using tpsL3_def tpsL4_def jk lentpsL4 onesie_write tps0
+      by (simp only: length_list_update nth_list_update_eq nth_list_update_neq One_nat_def)
+  next
+    case False
+    then have "i = j + 3"
+      using that by simp
+    then show ?thesis
+      using tpsL3_def tpsL4_def jk lentpsL4 onesie_write tps0
+      by (simp only: length_list_update nth_list_update_eq nth_list_update_neq One_nat_def)
+  qed
+  then show "\<And>ja. ja \<in> {j, j + 3} \<Longrightarrow> tpsL4 t ! ja = tpsL3 t ! ja |:=| 1"
+    by simp
+  have "tpsL4 t ! i = tpsL3 t ! i" if "i < length (tpsL4 t)" and "i \<noteq> j \<and> i \<noteq> j + 3" for i
+  proof -
+    consider
+        "i = j" | "i = j + 1" | "i = j + 2" | "i = j + 3" | "i = j + 4" | "i = j + 5" | "i = j + 6" | "i = j + 7" | "i = j + 8"
+      | "i < j" | "i > j + 8"
+      by linarith
+    then show ?thesis
+      using tpsL3_def tpsL4_def that
+      by (cases) (auto simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  qed
+  then show "\<And>ja. ja < length (tpsL4 t) \<Longrightarrow> ja \<notin> {j, j + 3} \<Longrightarrow> tpsL4 t ! ja = tpsL3 t ! ja"
+    by simp
+qed
+
+lemma tpsL4_Suc: "tpsL4 t = tpsL (Suc t)" (is "?l = ?r")
+proof (rule nth_equalityI)
+  show "length ?l = length ?r"
+    using lentpsL4 tpsL_def jk by simp
+  show "?l ! i = ?r ! i" if "i < length ?l" for i
+  proof -
+    consider
+        "i = j" | "i = j + 1" | "i = j + 2" | "i = j + 3" | "i = j + 4" | "i = j + 5" | "i = j + 6" | "i = j + 7" | "i = j + 8"
+      | "i < j" | "i > j + 8"
+      by linarith
+    then show ?thesis
+      using tpsL4_def tpsL_def
+      by (cases) (simp_all only: length_list_update nth_list_update_eq nth_list_update_neq)
+  qed
+qed
+
+lemma tmL4':
+  assumes "fst (exec t) < length M"
+    and "ttt = 34 + 8 * nlength thalt"
+  shows "transforms tmL4 (tpsL t) ttt (tpsL (Suc t))"
+  using tpsL4_Suc tmL4 assms by simp
+
+lemma tmL:
+  assumes "ttt = thalt * (36 + 8 * nlength thalt) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL thalt)"
+  unfolding tmL_def
+proof (tform)
+  have "tpsL t ! (j + 6) = \<lceil>fst (exec t)\<rceil>" for t
+    using tpsL_def jk by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  moreover have "j + 6 < length (tpsL t)"
+    using jk tpsL_def by simp
+  ultimately have *: "read (tpsL t) ! (j + 6) = fst (exec t)" for t
+    using tapes_at_read'[of "j + 6" "tpsL t"] onesie_read[of "fst (exec t)"]
+    by (simp add: lentpsL)
+  show "\<And>t. t < thalt \<Longrightarrow> read (tpsL t) ! (j + 6) < length M"
+    using * thalt by simp
+  show "\<And>t. t < thalt \<Longrightarrow> transforms tmL4 (tpsL t) (34 + 8 * nlength thalt) (tpsL (Suc t))"
+    using tmL4' * thalt(1) by simp
+  show "\<not> read (tpsL thalt) ! (j + 6) < length M"
+    using * thalt(2) by simp
+  show "thalt * tosym (34 + 8 * nlength thalt) + 1 \<le> ttt"
+    using assms by simp
+qed
+
+lemma tmL' [transforms_intros]:
+  assumes "ttt = thalt * (36 + 8 * nlength thalt) + 1"
+  shows "transforms tmL tps4 ttt (tpsL thalt)"
+  using assms tmL tpsL_0_eq_tps4 by simp
+
+definition "tps5 \<equiv> tps0
+  [(j + 1) := (\<lfloor>exec thalt <#> 0\<rfloor>\<^sub>N, 1),
+   (j + 2) := nltape (map (\<lambda>t. exec t <#> 0) [0..<Suc thalt]),
+   (j + 4) := (\<lfloor>exec thalt <#> 1\<rfloor>\<^sub>N, 1),
+   (j + 5) := nltape (map (\<lambda>t. exec t <#> 1) [0..<Suc thalt]),
+   (j + 6) := \<lceil>fst (exec thalt)\<rceil>,
+   (j + 7) := exec thalt <!> 0,
+   (j + 8) := exec thalt <!> 1]"
+
+lemma tm5:
+  assumes "ttt = thalt * (36 + 8 * nlength thalt) + 15"
+  shows "transforms tm5 tps0 ttt (tpsL thalt)"
+  unfolding tm5_def by (tform tps: jk time: assms)
+
+lemma tm5' [transforms_intros]:
+  assumes "ttt = thalt * (36 + 8 * nlength thalt) + 15"
+  shows "transforms tm5 tps0 ttt tps5"
+  using assms tm5 tps5_def tpsL_def by simp
+
+definition "tps6 \<equiv> tps0
+  [(j + 1) := (\<lfloor>exec thalt <#> 0\<rfloor>\<^sub>N, 1),
+   (j + 2) := nltape (map (\<lambda>t. exec t <#> 0) [0..<Suc thalt]),
+   (j + 4) := (\<lfloor>exec thalt <#> 1\<rfloor>\<^sub>N, 1),
+   (j + 5) := nltape (map (\<lambda>t. exec t <#> 1) [0..<Suc thalt]),
+   (j + 7) := exec thalt <!> 0,
+   (j + 8) := exec thalt <!> 1]"
+
+lemma tm6 [transforms_intros]:
+  assumes "ttt = thalt * (36 + 8 * nlength thalt) + 16"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+proof (tform tps: jk time: assms)
+  show "tps6 = tps5[j + 6 := tps5 ! (j + 6) |:=| 1]"
+    (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show len: "length ?l = length ?r"
+      using tps5_def tps6_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have i_less: "i < length ?r"
+        using that len by simp
+      consider
+          "i = j" | "i = j + 1" | "i = j + 2" | "i = j + 3" | "i = j + 4" | "i = j + 5" | "i = j + 6" | "i = j + 7" | "i = j + 8"
+        | "i < j" | "i > j + 8"
+        by linarith
+      then show ?thesis
+        using i_less tps5_def tps6_def onesie_write tps0
+        by (cases) (simp_all only: length_list_update nth_list_update_eq nth_list_update_neq)
+    qed
+  qed
+qed
+
+definition "tps7 \<equiv> tps0
+  [(j + 1) := (\<lfloor>exec thalt <#> 0\<rfloor>\<^sub>N, 1),
+   (j + 2) := (\<lfloor>map (\<lambda>t. exec t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   (j + 4) := (\<lfloor>exec thalt <#> 1\<rfloor>\<^sub>N, 1),
+   (j + 5) := nltape (map (\<lambda>t. exec t <#> 1) [0..<Suc thalt]),
+   (j + 7) := exec thalt <!> 0,
+   (j + 8) := exec thalt <!> 1]"
+
+lemma tm7 [transforms_intros]:
+  assumes "ttt = thalt * (36 + 8 * nlength thalt) + 19 + nllength (map (\<lambda>t. exec t <#> 0) [0..<Suc thalt])"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def
+proof (tform tps: tps7_def tps6_def jk assms)
+  show "clean_tape (tps6 ! (j + 2))"
+    using jk tps6_def clean_tape_nlcontents by simp
+  have "tps6 ! (j + 2) = nltape (map (\<lambda>t. exec t <#> 0) [0..<Suc thalt])"
+    using jk tps6_def by simp
+  then have "tps6 ! (j + 2) |#=| 1 = (\<lfloor>map (\<lambda>t. exec t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1)" (is "_ = ?tp")
+    by simp
+  moreover have "tps7 = tps6[j + 2 := ?tp]"
+    unfolding tps7_def tps6_def by (simp add: list_update_swap)
+  ultimately show "tps7 = tps6[j + 2 := tps6 ! (j + 2) |#=| 1]"
+    by simp
+qed
+
+definition "tps8 \<equiv> tps0
+  [(j + 1) := (\<lfloor>exec thalt <#> 0\<rfloor>\<^sub>N, 1),
+   (j + 2) := (\<lfloor>map (\<lambda>t. exec t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   (j + 4) := (\<lfloor>exec thalt <#> 1\<rfloor>\<^sub>N, 1),
+   (j + 5) := (\<lfloor>map (\<lambda>t. exec t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   (j + 7) := exec thalt <!> 0,
+   (j + 8) := exec thalt <!> 1]"
+
+lemma tm8:
+  assumes "ttt = thalt * (36 + 8 * nlength thalt) + 22 + nllength (map (\<lambda>t. exec t <#> 0) [0..<Suc thalt]) +
+    nllength (map (\<lambda>t. (exec t) <#> 1) [0..<Suc thalt])"
+  shows "transforms tm8 tps0 ttt tps8"
+  unfolding tm8_def
+proof (tform tps: tps8_def tps7_def jk assms)
+  show "clean_tape (tps7 ! (j + 5))"
+    using jk tps7_def clean_tape_nlcontents by simp
+  have "tps7 ! (j + 5) = nltape (map (\<lambda>t. exec t <#> 1) [0..<Suc thalt])"
+    using jk tps7_def by simp
+  then have "tps7 ! (j + 5) |#=| 1 = (\<lfloor>map (\<lambda>t. exec t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1)" (is "_ = ?tp")
+    by simp
+  moreover have "tps8 = tps7[j + 5 := ?tp]"
+    unfolding tps8_def tps7_def by (simp add: list_update_swap)
+  ultimately show "tps8 = tps7[j + 5 := tps7 ! (j + 5) |#=| 1]"
+    by simp
+qed
+
+lemma tm8':
+  assumes "ttt = 27 * Suc thalt * (9 + 2 * nlength thalt)"
+  shows "transforms tm8 tps0 ttt tps8"
+proof -
+  have 0: "nllength (map (\<lambda>t. exec t <#> 0) [0..<Suc thalt]) \<le> Suc (nlength thalt) * Suc thalt"
+    using nllength_le_len_mult_max[of "map (\<lambda>t. exec t <#> 0) [0..<Suc thalt]" thalt] max_head_pos_0 by simp
+  have 1: "nllength (map (\<lambda>t. exec t <#> 1) [0..<Suc thalt]) \<le> Suc (nlength thalt) * Suc thalt"
+    using nllength_le_len_mult_max[of "map (\<lambda>t. exec t <#> 1) [0..<Suc thalt]" thalt] max_head_pos_1 by simp
+
+  let ?ttt = "thalt * (36 + 8 * nlength thalt) + 22 + nllength (map (\<lambda>t. exec t <#> 0) [0..<Suc thalt]) +
+    nllength (map (\<lambda>t. (exec t) <#> 1) [0..<Suc thalt])"
+  have "?ttt \<le> thalt * (36 + 8 * nlength thalt) + 22 + Suc (nlength thalt) * Suc thalt + Suc (nlength thalt) * Suc thalt"
+    using 0 1 by linarith
+  also have "... = thalt * (36 + 8 * nlength thalt) + 22 + 2 * Suc (nlength thalt) * Suc thalt"
+    by simp
+  also have "... \<le> Suc thalt * (36 + 8 * nlength thalt) + 22 + 2 * Suc (nlength thalt) * Suc thalt"
+    by simp
+  also have "... \<le> Suc thalt * (4 * (9 + 2 * nlength thalt)) + 22 + 2 * Suc (nlength thalt) * Suc thalt"
+    by simp
+  also have "... = 4 * Suc thalt * (9 + 2 * nlength thalt) + 22 + 2 * Suc (nlength thalt) * Suc thalt"
+    by linarith
+  also have "... = 4 * Suc thalt * (9 + 2 * nlength thalt) + 22 + Suc thalt * (2 + 2 * nlength thalt)"
+    by simp
+  also have "... \<le> 4 * Suc thalt * (9 + 2 * nlength thalt) + 22 + Suc thalt * (9 + 2 * nlength thalt)"
+  proof -
+    have "2 + 2 * nlength thalt \<le> 9 + 2 * nlength thalt"
+      by simp
+    then show ?thesis
+      using Suc_mult_le_cancel1 add_le_cancel_left by blast
+  qed
+  also have "... = 5 * Suc thalt * (9 + 2 * nlength thalt) + 22"
+    by linarith
+  also have "... \<le> 5 * Suc thalt * (9 + 2 * nlength thalt) + 22 * Suc thalt * (9 + 2 * nlength thalt)"
+  proof -
+    have "1 \<le> Suc thalt * (9 + 2 * nlength thalt)"
+      by simp
+    then show ?thesis
+      by linarith
+  qed
+  also have "... = 27 * Suc thalt * (9 + 2 * nlength thalt)"
+    by linarith
+  finally have "?ttt \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using tm8 transforms_monotone by simp
+qed
+
+end  (* context *)
+
+end  (* locale turing_machine_list_headpos *)
+
+lemma transforms_tm_list_headposI [transforms_intros]:
+  fixes G :: nat and j :: tapeidx and M :: machine
+  fixes tps tps' :: "tape list"
+  fixes thalt k ttt :: nat and xs :: "symbol list"
+  assumes "turing_machine 2 G M"
+  assumes "length tps = k" and "k \<ge> j + 9" and "j > 0"
+  assumes
+    "\<forall>t<thalt. fst (execute M (start_config 2 xs) t) < length M"
+    "fst (execute M (start_config 2 xs) thalt) = length M"
+  assumes "symbols_lt G xs"
+  assumes "tps ! j = \<lceil>\<triangleright>\<rceil>"
+    "tps ! (j + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 0)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 0)"
+    "tps ! (j + 3) = \<lceil>\<triangleright>\<rceil>"
+    "tps ! (j + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 0)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 0)"
+    "tps ! (j + 6) = \<lceil>\<triangleright>\<rceil>"
+    "tps ! (j + 7) = (\<lfloor>xs\<rfloor>, 0)"
+    "tps ! (j + 8) = (\<lfloor>[]\<rfloor>, 0)"
+  assumes "ttt = 27 * Suc thalt * (9 + 2 * nlength thalt)"
+  assumes "tps' = tps
+    [(j + 1) := (\<lfloor>(execute M (start_config 2 xs) thalt) <#> 0\<rfloor>\<^sub>N, 1),
+     (j + 2) := (\<lfloor>map (\<lambda>t. (execute M (start_config 2 xs) t) <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+     (j + 4) := (\<lfloor>(execute M (start_config 2 xs) thalt) <#> 1\<rfloor>\<^sub>N, 1),
+     (j + 5) := (\<lfloor>map (\<lambda>t. (execute M (start_config 2 xs) t) <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+     (j + 7) := (execute M (start_config 2 xs) thalt) <!> 0,
+     (j + 8) := (execute M (start_config 2 xs) thalt) <!> 1]"
+  shows "transforms (tm_list_headpos G M j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_list_headpos .
+  show ?thesis
+    using assms loc.tm8' loc.tm8_eq_tm_list_headpos loc.tps8_def by metis
+qed
+
+
+section \<open>A Turing machine for $\Psi$ formulas\<close>
+
+text \<open>
+CNF formulas from the $\Psi$ family of formulas feature prominently in $\Phi$. In
+this section we first present a Turing machine for generating arbitrary members of this
+family and later a specialized one for the $\Psi$ formulas that we need for
+$\Phi$.
+\<close>
+
+subsection \<open>The general case\<close>
+
+text \<open>
+The next Turing machine generates a representation of the CNF formula $\Psi(vs,
+k)$. It expects $vs$ as a list of numbers on tape $j$ and the number $k$ on tape
+$j + 1$. A list of lists of numbers representing $\Psi(vs, k)$ is output to tape
+$j + 2$.
+
+The TM iterates over the elements of $vs$. In each iteration it generates a
+singleton clause containing the current element of $vs$ either as positive or
+negative literal, depending on whether $k$ is greater than zero or equal to
+zero. Then it decrements the number $k$. Thus the first $k$ variable indices of
+$vs$ will be turned into $k$ positive literals, the rest into negative ones
+(provided $|vs| \geq k$).
+
+\null
+\<close>
+
+definition tm_Psi :: "tapeidx \<Rightarrow> machine" where
+  "tm_Psi j \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! j \<noteq> \<box> DO
+      tm_nextract \<bar> j (j + 3) ;;
+      tm_times2 (j + 3) ;;
+      IF \<lambda>rs. rs ! (j + 1) \<noteq> \<box> THEN
+        tm_incr (j + 3)
+      ELSE
+        []
+      ENDIF ;;
+      tm_to_list (j + 3) ;;
+      tm_appendl (j + 2) (j + 3) ;;
+      tm_decr (j + 1) ;;
+      tm_erase_cr (j + 3)
+    DONE ;;
+    tm_cr (j + 2) ;;
+    tm_erase_cr j"
+
+lemma tm_Psi_tm:
+  assumes "0 < j" and "j + 3 < k" and "G \<ge> 6"
+  shows "turing_machine k G (tm_Psi j)"
+  unfolding tm_Psi_def
+  using Nil_tm tm_nextract_tm tm_times2_tm tm_incr_tm tm_to_list_tm tm_appendl_tm tm_decr_tm
+    tm_erase_cr_tm tm_cr_tm turing_machine_loop_turing_machine turing_machine_branch_turing_machine
+    assms
+  by simp
+
+text \<open>
+Two lemmas to help with the running time bound of @{const tm_Psi}:
+\<close>
+
+lemma sum_list_mono_nth:
+  fixes xs :: "'a list" and f g :: "'a \<Rightarrow> nat"
+  assumes "\<forall>i<length xs. f (xs ! i) \<le> g (xs ! i)"
+  shows "sum_list (map f xs) \<le> sum_list (map g xs)"
+  using assms by (metis in_set_conv_nth sum_list_mono)
+
+lemma sum_list_plus_const:
+  fixes xs :: "'a list" and f :: "'a \<Rightarrow> nat" and c :: nat
+  shows "sum_list (map (\<lambda>x. c + f x) xs) = c * length xs + sum_list (map f xs)"
+  by (induction xs) simp_all
+
+locale turing_machine_Psi =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_nextract \<bar> j (j + 3)"
+definition "tm2 \<equiv> tm1 ;; tm_times2 (j + 3)"
+definition "tm23 \<equiv> IF \<lambda>rs. rs ! (j + 1) \<noteq> \<box> THEN tm_incr (j + 3) ELSE [] ENDIF"
+definition "tm3 \<equiv> tm2 ;; tm23"
+definition "tm4 \<equiv> tm3 ;; tm_to_list (j + 3)"
+definition "tm5 \<equiv> tm4 ;; tm_appendl (j + 2) (j + 3)"
+definition "tm6 \<equiv> tm5 ;; tm_decr (j + 1)"
+definition "tm7 \<equiv> tm6 ;; tm_erase_cr (j + 3)"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! j \<noteq> \<box> DO tm7 DONE"
+definition "tm8 \<equiv> tmL ;; tm_cr (j + 2)"
+definition "tm9 \<equiv> tm8 ;; tm_erase_cr j"
+
+lemma tm9_eq_tm_Psi: "tm9 = tm_Psi j"
+  unfolding tm9_def tm8_def tmL_def tm7_def tm6_def tm5_def tm4_def tm3_def tm2_def tm1_def tm_Psi_def tm23_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k kk :: nat and ns :: "nat list"
+  assumes jk: "length tps0 = k" "0 < j" "j + 3 < k"
+    and kk: "kk \<le> length ns"
+  assumes tps0:
+    "tps0 ! j = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>kk\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+ "tpsL t \<equiv> tps0
+    [j := nltape' ns t,
+     j + 1 := (\<lfloor>kk - t\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<t])]"
+
+lemma tpsL_eq_tps0: "tpsL 0 = tps0"
+proof -
+  have "tpsL 0 ! (j + 2) = tps0 ! (j + 2)"
+    using tpsL_def tps0 jk by simp
+  moreover have "tpsL 0 ! (j + 1) = tps0 ! (j + 1)"
+    using tpsL_def tps0 jk by simp
+  moreover have "tpsL 0 ! (j + 3) = tps0 ! (j + 3)"
+    using tpsL_def tps0 jk by simp
+  ultimately show ?thesis
+    using tpsL_def tps0 jk
+    by (metis (no_types, lifting) One_nat_def diff_zero list_update_id list_update_overwrite nllength_Nil take0)
+qed
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+ "tpsL1 t \<equiv> tps0
+    [j := nltape' ns (Suc t),
+     j + 1 := (\<lfloor>kk - t\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<t]),
+     j + 3 := (\<lfloor>ns ! t\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "t < length ns"
+    and "ttt = 12 + 2 * nlength (ns ! t)"
+  shows "transforms tm1 (tpsL t) ttt (tpsL1 t)"
+  unfolding tm1_def
+proof (tform tps: assms(1) tpsL_def jk)
+  show "tpsL t ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL_def jk tps0 canrepr_0 by simp
+  show "ttt = 12 + 2 * nlength 0 + 2 * nlength (ns ! t)"
+    using assms(2) by simp
+  show "tpsL1 t = (tpsL t)
+      [j := nltape' ns (Suc t),
+       j + 3 := (\<lfloor>ns ! t\<rfloor>\<^sub>N, 1)]"
+    by (simp add: jk tps0 tpsL1_def tpsL_def list_update_swap numeral_3_eq_3)
+qed
+
+definition tpsL2 :: "nat \<Rightarrow> tape list" where
+ "tpsL2 t \<equiv> tps0
+    [j := nltape' ns (Suc t),
+     j + 1 := (\<lfloor>kk - t\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<t]),
+     j + 3 := (\<lfloor>2 * ns ! t\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "t < length ns"
+    and "ttt = 17 + 4 * nlength (ns ! t)"
+  shows "transforms tm2 (tpsL t) ttt (tpsL2 t)"
+  unfolding tm2_def by (tform tps: assms(1) tpsL1_def tpsL2_def jk time: assms(2))
+
+definition tpsL3 :: "nat \<Rightarrow> tape list" where
+ "tpsL3 t \<equiv> tps0
+    [j := nltape' ns (Suc t),
+     j + 1 := (\<lfloor>kk - t\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<t]),
+     j + 3 := (\<lfloor>2 * ns ! t + (if t < kk then 1 else 0)\<rfloor>\<^sub>N, 1)]"
+
+lemma tm23 [transforms_intros]:
+  assumes "t < length ns"
+    and "ttt = 7 + 2 * nlength (2 * ns ! t)"
+  shows "transforms tm23 (tpsL2 t) ttt (tpsL3 t)"
+  unfolding tm23_def
+proof (tform tps: assms(1) tpsL2_def jk time: assms(2))
+  show "read (tpsL2 t) ! (j + 1) \<noteq> \<box> \<Longrightarrow>
+      tpsL3 t = (tpsL2 t)[j + 3 := (\<lfloor>Suc (2 * ns ! t)\<rfloor>\<^sub>N, 1)]"
+    using tpsL2_def tpsL3_def jk read_ncontents_eq_0 by simp
+  show "5 + 2 * nlength (2 * ns ! t) + 2 \<le> ttt"
+    using assms by simp
+  show "\<not> read (tpsL2 t) ! (j + 1) \<noteq> \<box> \<Longrightarrow> tpsL3 t = tpsL2 t"
+    using tpsL2_def tpsL3_def jk read_ncontents_eq_0 by simp
+qed
+
+lemma tm3:
+  assumes "t < length ns"
+    and "ttt = 24 + 4 * nlength (ns ! t) + 2 * nlength (2 * ns ! t)"
+  shows "transforms tm3 (tpsL t) ttt (tpsL3 t)"
+  unfolding tm3_def by (tform tps: assms jk)
+
+lemma tm3' [transforms_intros]:
+  assumes "t < length ns" and "ttt = 26 + 6 * nlength (ns ! t)"
+  shows "transforms tm3 (tpsL t) ttt (tpsL3 t)"
+proof -
+  let ?ttt = "24 + 4 * nlength (ns ! t) + 2 * nlength (2 * ns ! t)"
+  have "nlength (2*x) \<le> Suc (nlength x)" for x
+    by (metis eq_refl gr0I less_imp_le_nat nat_0_less_mult_iff nlength_0 nlength_even_le)
+  then have "?ttt \<le> 24 + 4 * nlength (ns ! t) + 2 * Suc (nlength (ns ! t))"
+    by (meson add_mono_thms_linordered_semiring(2) mult_le_mono2)
+  then have "?ttt \<le> 26 + 6 * nlength (ns ! t)"
+    by simp
+  then show ?thesis
+    using tm3 assms transforms_monotone by blast
+qed
+
+definition tpsL4 :: "nat \<Rightarrow> tape list" where
+ "tpsL4 t \<equiv> tps0
+    [j := nltape' ns (Suc t),
+     j + 1 := (\<lfloor>kk - t\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<t]),
+     j + 3 := (\<lfloor>[2 * ns ! t + (if t < kk then 1 else 0)]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm4:
+  assumes "t < length ns"
+   and "ttt = 31 + 6 * nlength (ns ! t) + 2 * nlength (2 * ns ! t + (if t < kk then 1 else 0))"
+  shows "transforms tm4 (tpsL t) ttt (tpsL4 t)"
+  unfolding tm4_def
+proof (tform tps: assms tpsL3_def jk tps0)
+  show "tpsL4 t = (tpsL3 t)
+      [j + 3 := (\<lfloor>[2 * ns ! t + (if t < kk then 1 else 0)]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+    using tpsL3_def tpsL4_def jk tps0 by simp
+qed
+
+lemma tm4' [transforms_intros]:
+  assumes "t < length ns" and "ttt = 33 + 8 * nlength (ns ! t)"
+  shows "transforms tm4 (tpsL t) ttt (tpsL4 t)"
+proof -
+  have "nlength (2 * ns ! t + (if t < kk then 1 else 0)) \<le> Suc (nlength (ns ! t))"
+    using nlength_0_simp nlength_even_le nlength_le_n nlength_times2plus1
+    by (smt (z3) add.right_neutral le_Suc_eq mult_0_right neq0_conv)
+  then have "31 + 6 * nlength (ns ! t) +
+      2 * nlength (2 * ns ! t + (if t < kk then 1 else 0)) \<le> ttt"
+    using assms(2) by simp
+  then show ?thesis
+    using tm4 transforms_monotone assms(1) by blast
+qed
+
+definition tpsL5 :: "nat \<Rightarrow> tape list" where
+ "tpsL5 t \<equiv> tps0
+    [j := nltape' ns (Suc t),
+     j + 1 := (\<lfloor>kk - t\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<Suc t]),
+     j + 3 := (\<lfloor>[2 * ns ! t + (if t < kk then 1 else 0)]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "t < length ns"
+    and "ttt = 39 + 8 * nlength (ns ! t) + 2 * nllength [2 * ns ! t + (if t < kk then 1 else 0)]"
+  shows "transforms tm5 (tpsL t) ttt (tpsL5 t)"
+  unfolding tm5_def
+proof (tform tps: assms(1) tpsL4_def jk)
+  let ?tps = "(tpsL4 t)
+    [j + 2 := nlltape
+        (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<t] @ [[2 * ns ! t + (if t < kk then 1 else 0)]])]"
+  show "tpsL5 t = ?tps"
+    unfolding tpsL5_def tpsL4_def
+    by (simp only: list_update_overwrite list_update_swap_less[of "j+2"]) simp
+  show "ttt = 33 + 8 * nlength (ns ! t) +
+      (7 + nlllength (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<t]) -
+       Suc (nlllength (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<t])) +
+      2 * nllength [2 * ns ! t + (if t < kk then 1 else 0)])"
+    using assms by simp
+qed
+
+definition tpsL6 :: "nat \<Rightarrow> tape list" where
+ "tpsL6 t \<equiv> tps0
+    [j := nltape' ns (Suc t),
+     j + 1 := (\<lfloor>kk - t - 1\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<Suc t]),
+     j + 3 := (\<lfloor>[2 * ns ! t + (if t < kk then 1 else 0)]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm6:
+  assumes "t < length ns"
+    and "ttt = 39 + 8 * nlength (ns ! t) +
+      2 * nllength [2 * ns ! t + (if t < kk then 1 else 0)] +
+      (8 + 2 * nlength (kk - t))"
+  shows "transforms tm6 (tpsL t) ttt (tpsL6 t)"
+  unfolding tm6_def by (tform tps: assms(1) tpsL6_def tpsL5_def jk time: assms(2))
+
+lemma nllength_elem: "nllength [2 * ns ! t + (if t < kk then 1 else 0)] \<le> 2 + nlength (ns ! t)"
+proof -
+  have "2 * ns ! t + (if t < kk then 1 else 0) \<le> 2 * ns ! t + 1"
+    by simp
+  then have "nlength (2 * ns ! t + (if t < kk then 1 else 0)) \<le> nlength (2 * ns ! t + 1)"
+    using nlength_mono by simp
+  then have "nlength (2 * ns ! t + (if t < kk then 1 else 0)) \<le> Suc (nlength (ns ! t))"
+    using nlength_times2plus1 by fastforce
+  then show ?thesis
+    using nllength by simp
+qed
+
+lemma tm6' [transforms_intros]:
+  assumes "t < length ns"
+    and "ttt = 43 + 10 * nlength (ns ! t) + (8 + 2 * nlength (kk - t))"
+  shows "transforms tm6 (tpsL t) ttt (tpsL6 t)"
+proof -
+  let ?ttt = "39 + 8 * nlength (ns ! t) +
+      2 * nllength [2 * ns ! t + (if t < kk then 1 else 0)] +
+      (8 + 2 * nlength (kk - t))"
+  have "?ttt \<le> 39 + 8 * nlength (ns ! t) +
+      2 * (2 + nlength (ns ! t)) + (8 + 2 * nlength (kk - t))"
+    using nllength_elem
+    by (meson add_mono_thms_linordered_semiring(2) add_mono_thms_linordered_semiring(3) nat_mult_le_cancel_disj)
+  also have "... \<le> 43 + 10 * nlength (ns ! t) + (8 + 2 * nlength (kk - t))"
+    by simp
+  finally have "?ttt \<le> ttt"
+    using assms(2) by simp
+  then show ?thesis
+    using assms(1) tm6 transforms_monotone by blast
+qed
+
+definition tpsL7 :: "nat \<Rightarrow> tape list" where
+ "tpsL7 t \<equiv> tps0
+    [j := nltape' ns (Suc t),
+     j + 1 := (\<lfloor>kk - Suc t\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<Suc t]),
+     j + 3 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm7:
+  assumes "t < length ns"
+    and "ttt = 51 + (10 * nlength (ns ! t) + 2 * nlength (kk - t)) +
+      (7 + 2 * length (numlist [2 * ns ! t + (if t < kk then 1 else 0)]))"
+  shows "transforms tm7 (tpsL t) ttt (tpsL7 t)"
+  unfolding tm7_def
+proof (tform tps: assms(1) tpsL6_def tpsL7_def jk time: tpsL6_def jk assms(2))
+  let ?ns = "[2 * ns ! t + (if t < kk then 1 else 0)]"
+  show "tpsL6 t ::: (j + 3) = \<lfloor>numlist ?ns\<rfloor>"
+    using tpsL6_def nlcontents_def jk by simp
+  show "proper_symbols (numlist ?ns)"
+    using proper_symbols_numlist by simp
+qed
+
+lemma tm7':
+  assumes "t < length ns" and "ttt = 62 + 14 * nllength ns"
+  shows "transforms tm7 (tpsL t) ttt (tpsL7 t)"
+proof -
+  let ?ttt = "51 + (10 * nlength (ns ! t) + 2 * nlength (kk - t)) +
+      (7 + 2 * length (numlist [2 * ns ! t + (if t < kk then 1 else 0)]))"
+  have "?ttt = 58 + (10 * nlength (ns ! t) + 2 * nlength (kk - t)) +
+      2 * length (numlist [2 * ns ! t + (if t < kk then 1 else 0)])"
+    by simp
+  also have "... \<le> 58 + (10 * nlength (ns ! t) + 2 * nlength (kk - t)) + 2 * (2 + nlength (ns ! t))"
+    using nllength_elem nllength_def mult_le_mono2 nat_add_left_cancel_le by metis
+  also have "... = 62 + 12 * nlength (ns ! t) + 2 * nlength (kk - t)"
+    by simp
+  also have "... \<le> 62 + 12 * nlength (ns ! t) + 2 * nlength (length ns)"
+    using assms(1) kk nlength_mono by simp
+  also have "... \<le> 62 + 12 * nllength ns + 2 * nlength (length ns)"
+    using assms(1) member_le_nllength by simp
+  also have "... \<le> 62 + 12 * nllength ns + 2 * nllength ns"
+    using length_le_nllength nlength_le_n by (meson add_left_mono dual_order.trans mult_le_mono2)
+  also have "... = 62 + 14 * nllength ns"
+    by simp
+  finally have "?ttt \<le> 62 + 14 * nllength ns" .
+  then show ?thesis
+    using assms tm7 transforms_monotone by blast
+qed
+
+lemma tpsL7_eq_tpsL: "tpsL7 t = tpsL (Suc t)"
+  unfolding tpsL7_def tpsL_def
+  using jk tps0
+  by (smt (z3) Suc_eq_plus1 add_2_eq_Suc' add_cancel_left_right add_left_cancel list_update_id list_update_swap
+   num.simps(8) numeral_eq_iff numeral_eq_one_iff semiring_norm(86) zero_neq_numeral)
+
+lemma tm7'' [transforms_intros]:
+  assumes "t < length ns" and "ttt = 62 + 14 * nllength ns"
+  shows "transforms tm7 (tpsL t) ttt (tpsL (Suc t))"
+  using assms tpsL7_eq_tpsL tm7' by simp
+
+lemma tmL [transforms_intros]:
+  assumes "ttt = length ns * (62 + 14 * nllength ns + 2) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (length ns))"
+  unfolding tmL_def
+proof (tform)
+  let ?t = "62 + 14 * nllength ns"
+  show "read (tpsL t) ! j \<noteq> \<box>" if "t < length ns" for t
+  proof -
+    have "tpsL t ! j = nltape' ns t"
+      using tpsL_def jk by simp
+    then show ?thesis
+      using nltape'_tape_read that tapes_at_read' tpsL_def jk
+      by (metis (no_types, lifting) add_lessD1 leD length_list_update)
+  qed
+  have "tpsL t ! j = nltape' ns t" for t
+    using tpsL_def jk nlcontents_def by simp
+  then show "\<not> read (tpsL (length ns)) ! j \<noteq> \<box>"
+    using nltape'_tape_read tpsL_def jk tapes_at_read'
+    by (metis (no_types, lifting) add_lessD1 length_list_update order_refl)
+  show "length ns * (62 + 14 * nllength ns + 2) + 1 \<le> ttt"
+    using assms by simp
+qed
+
+definition tps8 :: "tape list" where
+ "tps8 \<equiv> tps0
+    [j := nltape' ns (length ns),
+     j + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape' (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<length ns]) 0]"
+
+lemma tm8:
+  assumes "ttt = Suc (length ns * (64 + 14 * nllength ns)) +
+    Suc (Suc (Suc (nlllength (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<length ns]))))"
+  shows "transforms tm8 (tpsL 0) ttt tps8"
+  unfolding tm8_def
+proof (tform tps: tpsL_def tps8_def jk time: assms tpsL_def jk)
+  show "clean_tape (tpsL (length ns) ! (j + 2))"
+    using tpsL_def jk clean_tape_nllcontents by simp
+  show "tps8 = (tpsL (length ns))[j + 2 := tpsL (length ns) ! (j + 2) |#=| 1]"
+    unfolding tps8_def tpsL_def using jk kk by simp
+qed
+
+lemma tm8' [transforms_intros]:
+  assumes "ttt = 4 + 81 * nllength ns ^ 2"
+  shows "transforms tm8 tps0 ttt tps8"
+proof -
+  let ?nss = "map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<length ns]"
+  let ?ttt = "Suc (length ns * (64 + 14 * nllength ns)) + Suc (Suc (Suc (nlllength ?nss)))"
+
+  have "nlllength ?nss = (\<Sum>ns\<leftarrow>?nss. Suc (nllength ns))"
+    using nlllength by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<length ns]. Suc (nllength [2 * ns ! i + (if i < kk then 1 else 0)]))"
+  proof -
+    have "map (\<lambda>ns. Suc (nllength ns)) ?nss = map (\<lambda>i. Suc (nllength (?nss ! i))) [0..<length ns]"
+      by simp
+    then have "map (\<lambda>ns. Suc (nllength ns)) ?nss = map (\<lambda>i. Suc (nllength [2 * ns ! i + (if i < kk then 1 else 0)])) [0..<length ns]"
+      by simp
+    then show ?thesis
+      by metis
+  qed
+  also have "... = (\<Sum>i\<leftarrow>[0..<length ns]. Suc (Suc (nlength (2 * ns ! i + (if i < kk then 1 else 0)))))"
+    using nllength by simp
+  also have "... \<le> (\<Sum>i\<leftarrow>[0..<length ns]. Suc (Suc (nlength (2 * ns ! i + 1))))"
+    using sum_list_mono_nth[of "[0..<length ns]"] nlength_mono by simp
+  also have "... \<le> (\<Sum>i\<leftarrow>[0..<length ns]. Suc (Suc (Suc (nlength (ns ! i)))))"
+    using sum_list_mono_nth[of "[0..<length ns]"] nlength_times2plus1 by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<length ns]. 2 + Suc (nlength (ns ! i)))"
+    by simp
+  also have "... = 2 * length ns + (\<Sum>i\<leftarrow>[0..<length ns]. Suc (nlength (ns ! i)))"
+    using sum_list_plus_const[of 2 _ "[0..<length ns]"] by simp
+  also have "... = 2 * length ns + nllength ns"
+  proof -
+    have "map (\<lambda>i. Suc (nlength (ns ! i))) [0..<length ns] = map (\<lambda>n. Suc (nlength n)) ns"
+      by (rule nth_equalityI) simp_all
+    then show ?thesis
+      using nllength by simp
+  qed
+  finally have "nlllength ?nss \<le> 2 * length ns + nllength ns" .
+  then have "?ttt \<le> Suc (length ns * (64 + 14 * nllength ns)) + Suc (Suc (Suc (2 * length ns + nllength ns)))"
+    by simp
+  also have "... = 4 + length ns * (64 + 14 * nllength ns) + 2 * length ns + nllength ns"
+    by simp
+  also have "... = 4 + length ns * (66 + 14 * nllength ns) + nllength ns"
+    by algebra
+  also have "... \<le> 4 + nllength ns * (66 + 14 * nllength ns) + nllength ns"
+    using length_le_nllength by simp
+  also have "... = 4 + 67 * nllength ns + 14 * nllength ns ^ 2"
+    by algebra
+  also have "... \<le> 4 + 67 * nllength ns ^ 2 + 14 * nllength ns ^ 2"
+    using linear_le_pow by simp
+  also have "... = 4 + 81 * nllength ns ^ 2"
+    by simp
+  finally have "?ttt \<le> 4 + 81 * nllength ns ^ 2" .
+  then show ?thesis
+    using tm8 assms transforms_monotone tpsL_eq_tps0 by simp
+qed
+
+definition tps9 :: "tape list" where
+ "tps9 \<equiv> tps0
+    [j := (\<lfloor>[]\<rfloor>, 1),
+     j + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape' (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<length ns]) 0]"
+
+lemma tm9:
+  assumes "ttt = 11 + 81 * nllength ns ^ 2 + 3 * nllength ns"
+  shows "transforms tm9 tps0 ttt tps9"
+  unfolding tm9_def
+proof (tform tps: tps8_def tps9_def jk)
+  show "tps8 ::: j = \<lfloor>numlist ns\<rfloor>"
+    using tps8_def jk nlcontents_def by simp
+  show "proper_symbols (numlist ns)"
+    using proper_symbols_numlist by simp
+  show "ttt = 4 + 81 * (nllength ns)\<^sup>2 + (tps8 :#: j + 2 * length (numlist ns) + 6)"
+    using tps8_def jk assms nllength_def by simp
+qed
+
+lemma tm9':
+  assumes "ttt = 11 + 84 * nllength ns ^ 2"
+  shows "transforms tm9 tps0 ttt tps9"
+proof -
+  have "11 + 81 * nllength ns ^ 2 + 3 * nllength ns \<le> 11 + 84 * nllength ns ^ 2"
+    using linear_le_pow by simp
+  then show ?thesis
+    using tm9 assms transforms_monotone by simp
+qed
+
+end
+
+end  (* locale turing_machine_Psi *)
+
+lemma transforms_tm_PsiI [transforms_intros]:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k kk :: nat and ns :: "nat list"
+  assumes "length tps = k" "0 < j" "j + 3 < k"
+    and "kk \<le> length ns"
+  assumes
+    "tps ! j = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! (j + 1) = (\<lfloor>kk\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 11 + 84 * nllength ns ^ 2"
+  assumes "tps' = tps
+    [j := (\<lfloor>[]\<rfloor>, 1),
+     j + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape' (map (\<lambda>t. [2 * ns ! t + (if t < kk then 1 else 0)]) [0..<length ns]) 0]"
+  shows "transforms (tm_Psi j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_Psi j .
+  show ?thesis
+    using loc.tm9_eq_tm_Psi loc.tps9_def loc.tm9' assms by simp
+qed
+
+
+subsection \<open>For intervals\<close>
+
+text \<open>
+To construct $\Phi$ we need only $\Psi$ formulas where the variable index list
+is an interval $\gamma_i = [iH, (i+1)H)$. In this section we devise a Turing
+machine that outputs $\Psi([start, start + len), \kappa)$ for arbitrary $start$,
+$len$, and $\kappa$.
+\<close>
+
+definition nll_Psi :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list list" where
+  "nll_Psi start len \<kappa> \<equiv> map (\<lambda>i. [2 * (start + i) + (if i < \<kappa> then 1 else 0)]) [0..<len]"
+
+lemma nll_Psi: "nll_Psi start len \<kappa> = formula_n (\<Psi> [start..<start+len] \<kappa>)"
+    (is "?lhs = ?rhs")
+proof (rule nth_equalityI)
+  show len: "length ?lhs = length ?rhs"
+    using nll_Psi_def Psi_def formula_n_def by simp
+  let ?psi = "\<Psi> [start..<start+len] \<kappa>"
+  show "?lhs ! i = ?rhs ! i" if "i < length ?lhs" for i
+  proof -
+    have "i < length ?psi"
+      using that Psi_def nll_Psi_def by simp
+    have "i < len"
+      using that Psi_def nll_Psi_def by simp
+    show ?thesis
+    proof (cases "i < \<kappa>")
+      case True
+      then have "?psi ! i = [Pos (start + i)]"
+        using Psi_def nth_append[of "map (\<lambda>s. [Pos s]) (take \<kappa> [start..<start+len])" _ i] `i < len`
+        by simp
+      moreover have "?rhs ! i = clause_n (?psi ! i)"
+        using formula_n_def that `i < length ?psi` by simp
+      ultimately have "?rhs ! i = [Suc (2 * (start + i))]"
+        using clause_n_def by simp
+      moreover have "?lhs ! i = [2 * (start + i) + 1]"
+        using True nll_Psi_def that by simp
+      ultimately show ?thesis
+        by simp
+    next
+      case False
+      then have "?psi ! i = [Neg (start + i)]"
+        using Psi_def nth_append[of "map (\<lambda>s. [Pos s]) (take \<kappa> [start..<start+len])" _ i] `i < len`
+        by auto
+      moreover have "?rhs ! i = clause_n (?psi ! i)"
+        using formula_n_def that `i < length ?psi` by simp
+      ultimately have "?rhs ! i = [2 * (start + i)]"
+        using clause_n_def by simp
+      moreover have "?lhs ! i = [2 * (start + i)]"
+        using False nll_Psi_def that by simp
+      ultimately show ?thesis
+        by simp
+    qed
+  qed
+qed
+
+lemma nlllength_nll_Psi_le: "nlllength (nll_Psi start len \<kappa>) \<le> len * (3 + nlength (start + len))"
+proof -
+  define f :: "nat \<Rightarrow> nat list" where
+    "f = (\<lambda>i. [2 * (start + i) + (if i < \<kappa> then 1 else 0)])"
+  let ?nss = "map f [0..<len]"
+  have "nlllength (nll_Psi start len \<kappa>) = (\<Sum>ns\<leftarrow>?nss. Suc (nllength ns))"
+    using nlllength f_def nll_Psi_def by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<len]. (\<lambda>ns. Suc (nllength ns)) (f i))"
+    by (metis (no_types, lifting) map_eq_conv map_map o_apply)
+  also have "... = (\<Sum>i\<leftarrow>[0..<len]. Suc (nllength ([2 * (start + i) + (if i < \<kappa> then 1 else 0)])))"
+    using f_def by simp
+  also have "... = (\<Sum>i\<leftarrow>[0..<len]. Suc (Suc (nlength (2 * (start + i) + (if i < \<kappa> then 1 else 0)))))"
+    using nllength by simp
+  also have "... \<le> (\<Sum>i\<leftarrow>[0..<len]. Suc (Suc (nlength (2 * (start + i) + 1))))"
+    using nlength_mono
+      sum_list_mono[of "[0..<len]"
+        "\<lambda>i. Suc (Suc (nlength (2 * (start + i) + (if i < \<kappa> then 1 else 0))))"
+        "\<lambda>i. Suc (Suc (nlength (2 * (start + i) + 1)))"]
+    by simp
+  also have "... \<le> (\<Sum>i\<leftarrow>[0..<len]. Suc (Suc (nlength (2 * (start + len)))))"
+    using nlength_mono
+      sum_list_mono[of "[0..<len]"
+        "\<lambda>i. Suc (Suc (nlength (2 * (start + i) + 1)))"
+        "\<lambda>i. Suc (Suc (nlength (2 * (start + len))))"]
+    by simp
+  also have "... = len * Suc (Suc (nlength (2 * (start + len))))"
+    using sum_list_const[of _ "[0..<len]"] by simp
+  also have "... \<le> len * Suc (Suc (Suc (nlength (start + len))))"
+    using nlength_times2 by (metis add_gr_0 eq_refl mult_le_cancel1 nlength_even_le)
+  also have "... = len * (3 + nlength (start + len))"
+    by (simp add: Suc3_eq_add_3)
+  finally show ?thesis .
+qed
+
+lemma nlllength_nll_Psi_le':
+  assumes "start1 \<le> start2"
+  shows "nlllength (nll_Psi start1 len \<kappa>) \<le> len * (3 + nlength (start2 + len))"
+proof -
+  have "nlllength (nll_Psi start1 len \<kappa>) \<le> len * (3 + nlength (start1 + len))"
+    using nlllength_nll_Psi_le by simp
+  moreover have "nlength (start1 + len) \<le> nlength (start2 + len)"
+    using assms nlength_mono by simp
+  ultimately show ?thesis
+    by (meson add_mono_thms_linordered_semiring(2) mult_le_mono2 order_trans)
+qed
+
+lemma H4_nlength:
+  fixes x y H :: nat
+  assumes "x \<le> y" and "H \<ge> 3"
+  shows "H ^ 4 * (nlength x)\<^sup>2 \<le> H ^ 4 * (nlength y)\<^sup>2"
+  using assms by (simp add: nlength_mono)
+
+text \<open>
+The next Turing machine receives on tape $j$ a number $i$, on tape $j + 1$ a
+number $H$, and on tape $j + 2$ a number $\kappa$. It outputs $\Psi([i \cdot
+H, (i + 1) \cdot H), \kappa)$.
+\<close>
+
+definition tm_Psigamma :: "tapeidx \<Rightarrow> machine" where
+  "tm_Psigamma j \<equiv>
+    tm_mult j (j + 1) (j + 3) ;;
+    tm_range (j + 3) (j + 1) (j + 4) ;;
+    tm_copyn (j + 2) (j + 5) ;;
+    tm_Psi (j + 4) ;;
+    tm_erase_cr (j + 3)"
+
+lemma tm_Psigamma_tm:
+  assumes "G \<ge> 6" and "j + 7 < k"
+  shows "turing_machine k G (tm_Psigamma j)"
+  unfolding tm_Psigamma_def
+  using assms tm_mult_tm tm_range_tm tm_copyn_tm tm_Psi_tm tm_erase_cr_tm
+  by simp
+
+locale turing_machine_Psigamma =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_mult j (j + 1) (j + 3)"
+definition "tm2 \<equiv> tm1 ;; tm_range (j + 3) (j + 1) (j + 4)"
+definition "tm3 \<equiv> tm2 ;; tm_copyn (j + 2) (j + 5)"
+definition "tm4 \<equiv> tm3 ;; tm_Psi (j + 4)"
+definition "tm5 \<equiv> tm4 ;; tm_erase_cr (j + 3)"
+
+lemma tm5_eq_tm_Psigamma: "tm5 = tm_Psigamma j"
+  using tm5_def tm4_def tm3_def tm2_def tm1_def tm_Psigamma_def by simp
+
+context
+  fixes tps0 :: "tape list" and H k idx \<kappa> :: nat
+  assumes jk: "length tps0 = k" "0 < j" "j + 7 < k"
+    and H: "H \<ge> 3"
+    and \<kappa>: "\<kappa> \<le> H"
+  assumes tps0:
+    "tps0 ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>\<kappa>\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j + 3 := (\<lfloor>idx * H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 4 + 26 * (nlength idx + nlength H) ^ 2 "
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: jk tps0 tps1_def)
+  show "tps0 ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps0 canrepr_0 by simp
+  show "ttt = 4 + 26 * (nlength idx + nlength H) * (nlength idx + nlength H)"
+    using assms by algebra
+qed
+
+definition "tps2 \<equiv> tps0
+  [j + 3 := (\<lfloor>idx * H\<rfloor>\<^sub>N, 1),
+   j + 4 := (\<lfloor>[idx * H..<idx * H + H]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 4 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * nlength (idx * H + H))"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps0 tps1_def tps2_def jk time: assms)
+  show "tps1 ! (j + 4) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tps1_def tps0 jk nlcontents_Nil by simp
+  have "j + 4 + 1 = j + 5"
+    by simp
+  then show "tps1 ! (j + 4 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps1_def tps0 jk canrepr_0
+    by (metis add_left_imp_eq nth_list_update_neq numeral_eq_iff semiring_norm(83) semiring_norm(90))
+  have "j + 4 + 2 = j + 6"
+    by simp
+  then show "tps1 ! (j + 4 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps1_def tps0 jk canrepr_0
+    by (metis add_left_imp_eq nth_list_update_neq num.simps(8) numeral_eq_iff)
+qed
+
+definition "tps3 \<equiv> tps0
+  [j + 3 := (\<lfloor>idx * H\<rfloor>\<^sub>N, 1),
+   j + 4 := (\<lfloor>[idx * H..<idx * H + H]\<rfloor>\<^sub>N\<^sub>L, 1),
+   j + 5 := (\<lfloor>\<kappa>\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 18 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * nlength (idx * H + H)) + 3 * nlength \<kappa>"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps0 tps2_def tps3_def jk)
+  show "tps2 ! (j + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps2_def jk tps0 canrepr_0 by simp
+  show "ttt = 4 + 26 * (nlength idx + nlength H)\<^sup>2 +
+      Suc H * (43 + 9 * nlength (idx * H + H)) +
+      (14 + 3 * (nlength \<kappa> + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps4 \<equiv> tps0
+  [j + 3 := (\<lfloor>idx * H\<rfloor>\<^sub>N, 1),
+   j + 4 := (\<lfloor>[]\<rfloor>, 1),
+   j + 5 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j + 6 := nlltape'
+        (map (\<lambda>t. [2 * [idx * H..<idx * H + H] ! t + (if t < \<kappa> then 1 else 0)])
+          [0..<length [idx * H..<idx * H + H]]) 0]"
+
+lemma tm4:
+  assumes "ttt = 29 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * nlength (idx * H + H)) +
+     3 * nlength \<kappa> + 84 * (nllength [idx * H..<idx * H + H])\<^sup>2"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: tps0 tps3_def tps4_def jk \<kappa> time: assms)
+  have *: "j + 4 + 1 = j + 5" "j + 4 + 2 = j + 6" "j + 4 + 3 = j + 7"
+    using add.assoc by simp_all
+  have "tps3 ! (j + 5) = (\<lfloor>\<kappa>\<rfloor>\<^sub>N, 1)"
+    using tps3_def jk by simp
+  then show "tps3 ! (j + 4 + 1) = (\<lfloor>\<kappa>\<rfloor>\<^sub>N, 1)"
+    using * by metis
+  have "tps3 ! (j + 6) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    using tps3_def jk tps0 nllcontents_Nil by simp
+  then show "tps3 ! (j + 4 + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    using * by metis
+  have "tps3 ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    using tps3_def jk tps0 by simp
+  then show "tps3 ! (j + 4 + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    using * by metis
+  have "tps4 = tps3
+    [j + 4 := (\<lfloor>[]\<rfloor>, 1),
+     j + 5 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j + 6 := nlltape'
+        (map (\<lambda>t. [2 * [idx * H..<idx * H + H] ! t + (if t < \<kappa> then 1 else 0)])
+          [0..<length [idx * H..<idx * H + H]]) 0]"
+    unfolding tps4_def tps3_def
+    by (simp only: list_update_overwrite list_update_swap_less)
+  then show "tps4 = tps3
+    [j + 4 := (\<lfloor>[]\<rfloor>, 1),
+     j + 4 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j + 4 + 2 := nlltape'
+        (map (\<lambda>t. [2 * [idx * H..<idx * H + H] ! t + (if t < \<kappa> then 1 else 0)])
+          [0..<length [idx * H..<idx * H + H]]) 0]"
+    using * by metis
+qed
+
+definition "tps4' \<equiv> tps0
+  [j + 3 := (\<lfloor>idx * H\<rfloor>\<^sub>N, 1),
+   j + 4 := (\<lfloor>[]\<rfloor>, 1),
+   j + 5 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j + 6 := nlltape' (map (\<lambda>t. [2 * (idx * H + t) + (if t < \<kappa> then 1 else 0)]) [0..<H]) 0]"
+
+lemma tps4'_eq_tps4: "tps4' = tps4"
+proof -
+  have "map (\<lambda>t. [2 * [idx * H..<idx * H + H] ! t + (if t < \<kappa> then 1 else 0)]) [0..<length [idx * H..<idx * H + H]] =
+      map (\<lambda>t. [2 * (idx * H + t) + (if t < \<kappa> then 1 else 0)]) [0..<H]"
+    by simp
+  then show ?thesis
+    using tps4'_def tps4_def by metis
+qed
+
+lemma tm4' [transforms_intros]:
+  assumes "ttt = 29 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * nlength (idx * H + H)) +
+     3 * nlength \<kappa> + 84 * (nllength [idx * H..<idx * H + H])\<^sup>2"
+  shows "transforms tm4 tps0 ttt tps4'"
+  using tm4 tps4'_eq_tps4 assms by simp
+
+definition "tps5 \<equiv> tps0
+  [j + 3 := (\<lfloor>[]\<rfloor>, 1),
+   j + 4 := (\<lfloor>[]\<rfloor>, 1),
+   j + 5 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j + 6 := nlltape' (map (\<lambda>t. [2 * (idx * H + t) + (if t < \<kappa> then 1 else 0)]) [0..<H]) 0]"
+
+lemma tm5:
+  assumes "ttt = 36 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * nlength (idx * H + H)) +
+    3 * nlength \<kappa> + 84 * (nllength [idx * H..<idx * H + H])\<^sup>2 +
+    2 * nlength (idx * H)"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def
+proof (tform tps: tps0 tps4'_def tps5_def jk \<kappa> time: assms tps4'_def jk)
+  show "proper_symbols (canrepr (idx * H))"
+    using proper_symbols_canrepr by simp
+qed
+
+definition "tps5' \<equiv> tps0
+  [j + 6 := (\<lfloor>nll_Psi (idx * H) H \<kappa>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tps5'_eq_tps5: "tps5' = tps5"
+  using tps5'_def tps5_def jk tps0 nll_Psi_def nlltape'_0 canrepr_0 by (metis list_update_id)
+
+lemma tm5':
+  assumes "ttt = 1851 * H^4 * (nlength (Suc idx))^2"
+  shows "transforms tm5 tps0 ttt tps5'"
+proof -
+  let ?ttt = "36 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * nlength (idx * H + H)) +
+      3 * nlength \<kappa> + 84 * (nllength [idx * H..<idx * H + H])\<^sup>2 + 2 * nlength (idx * H)"
+  have "?ttt \<le> 36 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * nlength (idx * H + H)) +
+      3 * nlength \<kappa> + 84 * (Suc (nlength (Suc idx * H)) * H)\<^sup>2 + 2 * nlength (idx * H)"
+    using nllength_le_len_mult_max[of "[idx * H..<idx * H + H]" "Suc idx * H"] by simp
+  also have "... \<le> 36 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * nlength (idx * H + H)) +
+      3 * nlength H + 84 * (Suc (nlength (Suc idx * H)) * H)\<^sup>2 + 2 * nlength (idx * H)"
+    using \<kappa> nlength_mono by simp
+  also have "... = 36 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * nlength (Suc idx * H)) +
+      3 * nlength H + 84 * (Suc (nlength (Suc idx * H)) * H)\<^sup>2 + 2 * nlength (idx * H)"
+    by (simp add: add.commute)
+  also have "... \<le> 36 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * (nlength (Suc idx) + nlength H)) +
+      3 * nlength H + 84 * (Suc (nlength (Suc idx * H)) * H)\<^sup>2 + 2 * nlength (idx * H)"
+  proof -
+    have "Suc H * (43 + 9 * nlength (Suc idx * H)) \<le> Suc H * (43 + 9 * (nlength (Suc idx) + nlength H))"
+      using nlength_prod by (meson add_mono_thms_linordered_semiring(2) mult_le_mono2)
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<le> 36 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * (nlength (Suc idx) + nlength H)) +
+      3 * nlength H + 84 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 + 2 * nlength (idx * H)"
+    using nlength_prod Suc_le_mono add_le_mono le_refl mult_le_mono power2_nat_le_eq_le by presburger
+  also have "... \<le> 36 + 26 * (nlength idx + nlength H)\<^sup>2 + Suc H * (43 + 9 * (nlength (Suc idx) + nlength H)) +
+      3 * nlength H + 84 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 + 2 * (nlength idx + nlength H)"
+    using nlength_prod Suc_le_mono add_le_mono le_refl mult_le_mono power2_nat_le_eq_le by presburger
+  also have "... \<le> 36 + 26 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 + Suc H * (43 + 9 * (nlength (Suc idx) + nlength H)) +
+      3 * nlength H + 84 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 + 2 * (nlength idx + nlength H)"
+  proof -
+    have "nlength idx + nlength H \<le> Suc (nlength (Suc idx) + nlength H)"
+      using nlength_mono by (metis add.commute nat_add_left_cancel_le nlength_Suc_le plus_1_eq_Suc trans_le_add2)
+    moreover have "H > 0"
+      using H by simp
+    ultimately have "nlength idx + nlength H \<le> Suc (nlength (Suc idx) + nlength H) * H"
+      by (metis (no_types, opaque_lifting) Suc_le_eq Suc_neq_Zero mult.assoc mult.commute mult_eq_1_iff mult_le_mono nat_mult_eq_cancel_disj)
+    then show ?thesis
+      by simp
+  qed
+  also have "... = 36 + 110 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 + Suc H * (43 + 9 * (nlength (Suc idx) + nlength H)) +
+      3 * nlength H + 2 * (nlength idx + nlength H)"
+    by simp
+  also have "... \<le> 36 + 110 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 + Suc H * (43 + 9 * (nlength (Suc idx) + nlength H)) +
+      3 * (Suc (nlength (Suc idx) + nlength H) * H)^2 + 2 * (nlength idx + nlength H)"
+  proof -
+    have "nlength H \<le> Suc (nlength (Suc idx) + nlength H) * H"
+      using H by (simp add: nlength_le_n trans_le_add1)
+    then have "nlength H \<le> (Suc (nlength (Suc idx) + nlength H) * H)^2"
+      by (meson le_refl le_trans power2_nat_le_imp_le)
+    then show ?thesis
+      by simp
+  qed
+  also have "... = 36 + 113 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 + Suc H * (43 + 9 * (nlength (Suc idx) + nlength H)) +
+      2 * (nlength idx + nlength H)"
+    by simp
+  also have "... \<le> 36 + 113 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 + Suc H * (43 + 9 * (nlength (Suc idx) + nlength H)) +
+      2 * (Suc (nlength (Suc idx) + nlength H) * H) ^ 2"
+  proof -
+    have "nlength idx + nlength H \<le> Suc (nlength (Suc idx) + nlength H)"
+      using nlength_mono by (simp add: le_SucI)
+    also have "... \<le> Suc (nlength (Suc idx) + nlength H) * H"
+      using H by (metis Suc_eq_plus1 le_add2 mult.commute mult_le_mono1 nat_mult_1 numeral_eq_Suc order_trans)
+    also have "... \<le> (Suc (nlength (Suc idx) + nlength H) * H)^2"
+      by (simp add: power2_eq_square)
+    finally have "nlength idx + nlength H \<le> (Suc (nlength (Suc idx) + nlength H) * H)^2" .
+    then show ?thesis
+      by simp
+  qed
+  also have "... = 79 + 115 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 +
+      9 * (nlength (Suc idx) + nlength H) + (43 + 9 * (nlength (Suc idx) + nlength H)) * H"
+    by simp
+  also have "... = 79 + 115 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 +
+      9 * (nlength (Suc idx) + nlength H) + 43 * H + 9 * (nlength (Suc idx) + nlength H) * H"
+    by algebra
+  also have "... \<le> 79 + 115 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 +
+      9 * (Suc (nlength (Suc idx) + nlength H) * H) ^ 2 + 43 * H + 9 * (nlength (Suc idx) + nlength H) * H"
+  proof -
+    have "nlength (Suc idx) + nlength H \<le> Suc (nlength (Suc idx) + nlength H)"
+      by simp
+    also have "... \<le> Suc (nlength (Suc idx) + nlength H) * H"
+      using H
+      by (metis One_nat_def add_leD1 le_refl mult_le_mono mult_numeral_1_right numeral_3_eq_3 numeral_nat(1) plus_1_eq_Suc)
+    also have "... \<le> (Suc (nlength (Suc idx) + nlength H) * H) ^ 2"
+      by (simp add: power2_eq_square)
+    finally have "nlength (Suc idx) + nlength H \<le> (Suc (nlength (Suc idx) + nlength H) * H) ^ 2" .
+    then show ?thesis
+      by simp
+  qed
+  also have "... = 79 + 124 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 + 43 * H + 9 * (nlength (Suc idx) + nlength H) * H"
+    by simp
+  also have "... \<le> 79 + 124 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 +
+    43 * H + 9 * (Suc (nlength (Suc idx) + nlength H) * H) ^ 2"
+  proof -
+    have "(nlength (Suc idx) + nlength H) * H \<le> Suc (nlength (Suc idx) + nlength H) * H"
+      by simp
+    then have "(nlength (Suc idx) + nlength H) * H \<le> (Suc (nlength (Suc idx) + nlength H) * H) ^ 2"
+      by (metis nat_le_linear power2_nat_le_imp_le verit_la_disequality)
+    then show ?thesis
+      by linarith
+  qed
+  also have "... = 79 + 133 * (Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 + 43 * H"
+    by simp
+  also have "... \<le> 79 + 133 * (9*H^3 * (nlength (Suc idx))^2 + 4*H^4) + 43 * H"
+  proof -
+    let ?m = "nlength (Suc idx)"
+    let ?l = "Suc ?m"
+    have "(Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 = ((?l + nlength H) * H)\<^sup>2"
+      by simp
+    also have "... = (?l*H + nlength H*H) ^ 2"
+      by algebra
+    also have "... \<le> (?l*H + H*H) ^ 2"
+      using nlength_le_n by simp
+    also have "... = (?l*H)^2 + 2*?l*H^3 + H^4"
+      by algebra
+    also have "... \<le> (?l*H)^2 + 2*?l^2*H^3 + H^4"
+      by (metis Suc_n_not_le_n add_le_mono1 mult_le_mono1 mult_le_mono2 nat_add_left_cancel_le not_less_eq_eq power2_nat_le_imp_le)
+    also have "... = ?l^2*(H^2 + 2*H^3) + H^4"
+      by algebra
+    also have "... \<le> ?l^2*(H^3 + 2*H^3) + H^4"
+    proof -
+      have "H^2 \<le> H^3"
+        using pow_mono by (simp add: numeral_3_eq_3 numerals(2))
+      then show ?thesis
+        by simp
+    qed
+    also have "... = ?l^2*3*H^3 + H^4"
+      by simp
+    also have "... = (?m^2 + 2 * ?m + 1)*3*H^3 + H^4"
+      by (smt (z3) add.commute add_Suc mult_2 nat_1_add_1 one_power2 plus_1_eq_Suc power2_sum)
+    also have "... \<le> (?m^2 + 2 * ?m^2 + 1)*3*H^3 + H^4"
+      using linear_le_pow by simp
+    also have "... = (3*?m^2 + 1)*3*H^3 + H^4"
+      by simp
+    also have "... = 9*?m^2*H^3 + 3*H^3 + H^4"
+      by algebra
+    also have "... \<le> 9*?m^2*H^3 + 3*H^4 + H^4"
+      using pow_mono' by simp
+    also have "... = 9*H^3 * ?m^2 + 4*H^4"
+      by simp
+    finally have "(Suc (nlength (Suc idx) + nlength H) * H)\<^sup>2 \<le> 9*H^3 * ?m^2 + 4*H^4" .
+    then show ?thesis
+      by simp
+  qed
+  also have "... = 79 + 133 * 9*H^3 * (nlength (Suc idx))^2 + 133*4*H^4 + 43 * H"
+    by simp
+  also have "... \<le> 79 + 133 * 9*H^3 * (nlength (Suc idx))^2 + 133*4*H^4 + 43 * H^4"
+    using linear_le_pow by simp
+  also have "... \<le> 79*H^4 + 133 * 9*H^3 * (nlength (Suc idx))^2 + 133*4*H^4 + 43 * H^4"
+    using H by simp
+  also have "... = 654 * H^4 + 1197 * H^3 * (nlength (Suc idx))^2"
+    by simp
+  also have "... \<le> 654 * H^4 + 1197 * H^4 * (nlength (Suc idx))^2"
+    using pow_mono' by simp
+  also have "... \<le> 654 * H^4 * (nlength (Suc idx))^2 + 1197 * H^4 * (nlength (Suc idx))^2"
+    using nlength_mono nlength_1_simp
+    by (metis add_le_mono1 le_add1 mult_le_mono2 mult_numeral_1_right numerals(1) one_le_power plus_1_eq_Suc)
+  also have "... = 1851 * H^4 * (nlength (Suc idx))^2"
+    by simp
+  finally have "?ttt \<le> 1851 * H^4 * (nlength (Suc idx))^2" .
+  then show ?thesis
+    using assms tm5 transforms_monotone tps5'_eq_tps5 by simp
+qed
+
+end  (* context *)
+
+end  (* locale turing_machine_Psigamma *)
+
+lemma transforms_tm_PsigammaI [transforms_intros]:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt H k idx \<kappa> :: nat
+  assumes "length tps = k" and "0 < j" and "j + 7 < k"
+    and "H \<ge> 3"
+    and "\<kappa> \<le> H"
+  assumes
+    "tps ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>\<kappa>\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 1851 * H^4 * (nlength (Suc idx))^2"
+  assumes "tps' = tps
+    [j + 6 := (\<lfloor>nll_Psi (idx * H) H \<kappa>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+  shows "transforms (tm_Psigamma j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_Psigamma j .
+  show ?thesis
+    using loc.tm5' loc.tps5'_def loc.tm5_eq_tm_Psigamma assms by simp
+qed
+
+
+section \<open>A Turing machine for $\Upsilon$ formulas\<close>
+
+text \<open>
+The CNF formula $\Phi_7$ is made of CNF formulas $\Upsilon(\gamma_i)$ with
+$\gamma_i = [i\cdot H, (i+1)\cdot H)$. In this section we build a Turing machine
+that outputs such CNF formulas.
+\<close>
+
+
+subsection \<open>A Turing machine for singleton clauses\<close>
+
+text \<open>
+The $\Upsilon$ formulas, just like the $\Psi$ formulas, are conjunctions of
+singleton clauses. The next Turing machine outputs singleton clauses. The Turing
+machine has two parameters: a Boolean $incr$ and a tape index $j$. It receives a
+variable index on tape $j$, a CNF formula as list of lists of numbers on tape $j
++ 2$ and a number $H$ on tape $j + 3$. The TM appends to the formula on tape $j
++ 2$ a singleton clause with a positive or negative (depending on $incr$)
+literal derived from the variable index. It also decrements $H$ and increments
+the variable index, which makes it more suitable for use in a loop constructing
+an $\Upsilon$ formula.
+
+Given our encoding of literals, what the TM actually does is doubling the number
+on tape $j + 1$ and optionally (if $incr$ is true) incrementing it.
+\<close>
+
+definition tm_times2_appendl :: "bool \<Rightarrow> tapeidx \<Rightarrow> machine" where
+ "tm_times2_appendl incr j \<equiv>
+    tm_copyn j (j + 1) ;;
+    tm_times2 (j + 1) ;;
+    (if incr then tm_incr (j + 1) else []) ;;
+    tm_to_list (j + 1) ;;
+    tm_appendl (j + 2) (j + 1) ;;
+    tm_erase_cr (j + 1) ;;
+    tm_incr j ;;
+    tm_decr (j + 3)"
+
+lemma tm_times2_appendl_tm:
+  assumes "0 < j" and "j + 3 < k" and "G \<ge> 6"
+  shows "turing_machine k G (tm_times2_appendl incr j)"
+  unfolding tm_times2_appendl_def
+  using Nil_tm tm_incr_tm tm_to_list_tm tm_appendl_tm tm_decr_tm tm_erase_cr_tm tm_times2_tm assms tm_copyn_tm
+  by simp
+
+locale turing_machine_times2_appendl =
+  fixes j :: tapeidx
+begin
+
+context
+  fixes tps0 :: "tape list" and v H k :: nat and nss :: "nat list list" and incr :: bool
+  assumes jk: "length tps0 = k" "0 < j" "j + 3 < k"
+  assumes tps0:
+    "tps0 ! j = (\<lfloor>v\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 2) = nlltape nss"
+    "tps0 ! (j + 3) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tm1 \<equiv> tm_copyn j (j + 1)"
+definition "tm2 \<equiv> tm1 ;; tm_times2 (j + 1)"
+definition "tm3 \<equiv> tm2 ;; (if incr then tm_incr (j + 1) else [])"
+definition "tm4 \<equiv> tm3 ;; tm_to_list (j + 1)"
+definition "tm5 \<equiv> tm4 ;; tm_appendl (j + 2) (j + 1)"
+definition "tm6 \<equiv> tm5 ;; tm_erase_cr (j + 1)"
+definition "tm7 \<equiv> tm6 ;; tm_incr j"
+definition "tm8 \<equiv> tm7 ;; tm_decr (j + 3)"
+
+lemma tm8_eq_tm_times2appendl: "tm8 \<equiv> tm_times2_appendl incr j"
+  using tm8_def tm7_def tm6_def tm5_def tm4_def tm3_def tm2_def tm1_def tm_times2_appendl_def by simp
+
+definition "tps1 \<equiv> tps0
+  [j + 1 := (\<lfloor>v\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 14 + 3 * nlength v"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps1_def tps0 jk)
+  show "tps0 ! (j + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using jk tps0 canrepr_0 by simp
+  show "ttt = 14 + 3 * (nlength v + nlength 0)"
+    using assms by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j + 1 := (\<lfloor>2 * v\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 19 + 5 * nlength v"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: tps2_def tps1_def jk assms)
+
+definition "tps3 \<equiv> tps0
+  [j + 1 := (\<lfloor>2 * v + (if incr then 1 else 0)\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3_True:
+  assumes "ttt = 24 + 5 * nlength v + 2 * nlength (2 * v)" and incr
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps3_def tps2_def jk)
+  let ?t = "5 + 2 * nlength (2 * v)"
+  have "transforms (tm_incr (j + 1)) tps2 ?t tps3"
+    by (tform tps: tps3_def tps2_def jk assms(2))
+  then show "transforms (if incr then tm_incr (j + 1) else []) tps2 ?t tps3"
+    using assms(2) by simp
+  show "ttt = 19 + 5 * nlength v + ?t"
+    using assms by simp
+qed
+
+lemma tm3_False:
+  assumes "ttt = 19 + 5 * nlength v" and "\<not> incr"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps3_def tps2_def jk assms)
+  show "transforms (if incr then tm_incr (j + 1) else []) tps2 0 tps3"
+    using transforms_Nil jk tps3_def tps2_def assms(2) by simp
+qed
+
+lemma tm3:
+  assumes "ttt = 24 + 5 * nlength v + 2 * nlength (2 * v)"
+  shows "transforms tm3 tps0 ttt tps3"
+  using tm3_True tm3_False assms transforms_monotone by (cases incr) simp_all
+
+lemma tm3' [transforms_intros]:
+  assumes "ttt = 26 + 7 * nlength v"
+  shows "transforms tm3 tps0 ttt tps3"
+proof -
+  have "nlength (2 * v) \<le> Suc (nlength v)"
+    using nlength_times2 by simp
+  then show ?thesis
+    using assms tm3 transforms_monotone by simp
+qed
+
+definition "tps4 \<equiv> tps0
+  [j + 1 := (\<lfloor>[2 * v + (if incr then 1 else 0)]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm4:
+  assumes "ttt = 31 + 7 * nlength v + 2 * nlength (2 * v + (if incr then 1 else 0))"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def by (tform tps: tps4_def tps3_def jk assms)
+
+lemma tm4' [transforms_intros]:
+  assumes "ttt = 33 + 9 * nlength v"
+  shows "transforms tm4 tps0 ttt tps4"
+proof -
+  have "nlength (2 * v + (if incr then 1 else 0)) \<le> Suc (nlength v)"
+    using nlength_times2 nlength_times2plus1 by simp
+  then show ?thesis
+    using assms tm4 transforms_monotone by simp
+qed
+
+definition "tps5 \<equiv> tps0
+  [j + 1 := (\<lfloor>[2 * v + (if incr then 1 else 0)]\<rfloor>\<^sub>N\<^sub>L, 1),
+   j + 2 := nlltape (nss @ [[2 * v + (if incr then 1 else 0)]])]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 39 + 9 * nlength v + 2 * nllength [2 * v + (if incr then 1 else 0)]"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def
+proof (tform tps: tps5_def tps4_def jk tps0)
+  show "ttt = 33 + 9 * nlength v + (7 + nlllength nss - Suc (nlllength nss) +
+      2 * nllength [2 * v + (if incr then 1 else 0)])"
+    using assms by simp
+qed
+
+definition "tps6 \<equiv> tps0
+  [j + 2 := nlltape (nss @ [[2 * v + (if incr then 1 else 0)]])]"
+
+lemma tm6:
+  assumes "ttt = 46 + 9 * nlength v + 4 * nllength [2 * v + (if incr then 1 else 0)]"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+proof (tform tps: tps6_def tps5_def jk)
+  let ?zs = "numlist [2 * v + (if incr then 1 else 0)]"
+  show "tps5 ::: (j + 1) = \<lfloor>?zs\<rfloor>"
+    using jk tps5_def nlcontents_def by simp
+  show "proper_symbols ?zs"
+    using proper_symbols_numlist by simp
+  show "tps6 = tps5[j + 1 := (\<lfloor>[]\<rfloor>, 1)]"
+    using jk tps6_def tps5_def tps0
+    by (metis (no_types, lifting) add_left_cancel list_update_id list_update_overwrite list_update_swap
+      numeral_eq_one_iff semiring_norm(83))
+  show "ttt = 39 + 9 * nlength v + 2 * nllength [2 * v + (if incr then 1 else 0)] +
+      (tps5 :#: (j + 1) + 2 * length (numlist [2 * v + (if incr then 1 else 0)]) + 6)"
+    using assms nllength_def tps5_def jk by simp
+qed
+
+lemma tm6' [transforms_intros]:
+  assumes "ttt = 54 + 13 * nlength v"
+  shows "transforms tm6 tps0 ttt tps6"
+proof -
+  have "nlength (2 * v + (if incr then 1 else 0)) \<le> Suc (nlength v)"
+    using nlength_times2 nlength_times2plus1 by simp
+  then show ?thesis
+    using assms tm6 transforms_monotone nllength by simp
+qed
+
+definition "tps7 \<equiv> tps0
+  [j := (\<lfloor>Suc v\<rfloor>\<^sub>N, 1),
+   j + 2 := nlltape (nss @ [[2 * v + (if incr then 1 else 0)]])]"
+
+lemma tm7 [transforms_intros]:
+  assumes "ttt = 59 + 15 * nlength v"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def by (tform tps: tps7_def tps6_def tps0 jk assms)
+
+definition "tps8 \<equiv> tps0
+  [j := (\<lfloor>Suc v\<rfloor>\<^sub>N, 1),
+   j + 2 := nlltape (nss @ [[2 * v + (if incr then 1 else 0)]]),
+   j + 3 := (\<lfloor>H - 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm8:
+  assumes "ttt = 67 + 15 * nlength v + 2 * nlength H"
+  shows "transforms tm8 tps0 ttt tps8"
+  unfolding tm8_def by (tform tps: tps8_def tps0 tps7_def jk time: assms)
+
+end
+
+end  (* locale turing_machine_times2_appendl *)
+
+lemma transforms_tm_times2_appendlI [transforms_intros]:
+  fixes j :: tapeidx and incr :: bool
+  fixes tps tps' :: "tape list" and ttt v H k :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "0 < j" and "j + 3 < k"
+  assumes
+    "tps ! j = (\<lfloor>v\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 2) = nlltape nss"
+    "tps ! (j + 3) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 67 + 15 * nlength v + 2 * nlength H"
+  assumes "tps' = tps
+    [j := (\<lfloor>Suc v\<rfloor>\<^sub>N, 1),
+     j + 2 := nlltape (nss @ [[2 * v + (if incr then 1 else 0)]]),
+     j + 3 := (\<lfloor>H - 1\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_times2_appendl incr j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_times2_appendl j .
+  show ?thesis
+    using assms loc.tm8 loc.tps8_def loc.tm8_eq_tm_times2appendl by metis
+qed
+
+
+subsection \<open>A Turing machine for $\Upsilon(\gamma_i)$ formulas\<close>
+
+text \<open>
+We will not need the general $\Upsilon$ formulas, but only $\Upsilon(\gamma_i)$
+for $\gamma_i = [i\cdot H, (i + 1)\cdot H)$. Represented as list of lists of
+numbers they look like this (for $H \geq 3$):
+\<close>
+
+definition nll_Upsilon :: "nat \<Rightarrow> nat \<Rightarrow> nat list list" where
+  "nll_Upsilon idx len \<equiv> [[2 * (idx * len) + 1], [2 * (idx * len + 1) + 1]] @ map (\<lambda>i. [2 * (idx * len + i)]) [3..<len]"
+
+lemma nll_Upsilon:
+  assumes "len \<ge> 3"
+  shows "nll_Upsilon idx len = formula_n (\<Upsilon> [idx*len..<idx*len+len])"
+    (is "?lhs = ?rhs")
+proof (rule nth_equalityI)
+  show len: "length ?lhs = length ?rhs"
+    using nll_Upsilon_def Upsilon_def formula_n_def assms by simp
+  have "length ?lhs = len - 1"
+    using nll_Upsilon_def assms by simp
+  define nss where "nss = [[2 * (idx * len) + 1], [2 * (idx * len + 1) + 1]]"
+  then have *: "?lhs = nss @ map (\<lambda>i. [2 * (idx * len + i)]) [3..<len]"
+    using nll_Upsilon_def by simp
+  have "length nss = 2"
+    using nss_def by simp
+  let ?ups = "\<Upsilon> [idx*len..<idx*len+len]"
+  show "?lhs ! i = ?rhs ! i" if "i < length ?lhs" for i
+  proof (cases "i < 2")
+    case True
+    then have "?lhs ! i = nss ! i"
+      using * `length nss = 2` by (simp add: nth_append)
+    then have lhs: "?lhs ! i = [2 * (idx * len + i) + 1]"
+      using nss_def True by (cases "i = 0") auto
+
+    have "?ups ! i = [Pos (idx*len+i)]"
+      unfolding Upsilon_def using True assms by (cases "i = 0") auto
+    moreover have "?rhs ! i = clause_n (?ups ! i)"
+      using that len formula_n_def by simp
+    ultimately have "?rhs ! i = clause_n [Pos (idx*len+i)]"
+      by simp
+    then have "?rhs ! i = [Suc (2*(idx*len+i))]"
+      using clause_n_def by simp
+    then show ?thesis
+      using lhs by simp
+  next
+    case False
+    then have "?lhs ! i = map (\<lambda>i. [2 * (idx * len + i)]) [3..<len] ! (i - 2)"
+      using `length nss = 2` * by (simp add: nth_append)
+    also have "... = (\<lambda>i. [2 * (idx * len + i)]) ([3..<len] ! (i - 2))"
+      using False that `length nss = 2` * by simp
+    also have "... = (\<lambda>i. [2 * (idx * len + i)]) (i + 1)"
+      using False that `length nss = 2` * by simp
+    also have "... = [2 * (idx * len + i + 1)]"
+      by simp
+    finally have lhs: "?lhs ! i = [2 * (idx * len + i + 1)]" .
+
+    have "?ups ! i = map (\<lambda>s. [Neg s]) (drop 3 [idx*len..<idx*len+len]) ! (i - 2)"
+      using Upsilon_def False that formula_n_def len by auto
+    also have "... = (\<lambda>s. [Neg s]) (drop 3 [idx*len..<idx*len+len] ! (i - 2))"
+      using Upsilon_def False that formula_n_def len by auto
+    also have "... = (\<lambda>s. [Neg s]) (idx * len + i + 1)"
+      using Upsilon_def False that formula_n_def len by auto
+    finally have "?ups ! i = [Neg (idx * len + i + 1)]" .
+    moreover have "?rhs ! i = clause_n (?ups ! i)"
+      using Upsilon_def False that formula_n_def len by auto
+    ultimately have "?rhs ! i = clause_n [Neg (idx * len + i + 1)]"
+      by simp
+    then show ?thesis
+      using clause_n_def lhs by simp
+  qed
+qed
+
+lemma nlllength_nll_Upsilon_le:
+  assumes "len \<ge> 3"
+  shows "nlllength (nll_Upsilon idx len) \<le> len * (4 + nlength idx + nlength len)"
+proof -
+  define f :: "nat \<Rightarrow> nat list" where "f = (\<lambda>i. [2 * (idx * len + i)])"
+  let ?nss = "map f [3..<len]"
+  have "nlllength ?nss = (\<Sum>ns\<leftarrow>?nss. Suc (nllength ns))"
+    using nlllength f_def by simp
+  also have "... = (\<Sum>i\<leftarrow>[3..<len]. (\<lambda>ns. Suc (nllength ns)) (f i))"
+    by (metis (no_types, lifting) map_eq_conv map_map o_apply)
+  also have "... = (\<Sum>i\<leftarrow>[3..<len]. Suc (nllength ([2 * (idx * len + i)])))"
+    using f_def by simp
+  also have "... = (\<Sum>i\<leftarrow>[3..<len]. Suc (Suc (nlength (2 * (idx * len + i)))))"
+    using nllength by simp
+  also have "... \<le> (\<Sum>i\<leftarrow>[3..<len]. Suc (Suc (nlength (2 * (Suc idx * len)))))"
+    using nlength_mono
+      sum_list_mono[of "[3..<len]"
+        "\<lambda>i. Suc (Suc (nlength (2 * (idx * len + i))))"
+        "\<lambda>i. Suc (Suc (nlength (2 * (Suc idx * len))))"]
+    by simp
+  also have "... = Suc (Suc (nlength (2 * (Suc idx * len)))) * (len - 3)"
+    using assms sum_list_const[of _ "[3..<len]"] by simp
+  also have "... \<le> Suc (Suc (Suc (nlength (Suc idx * len)))) * (len - 3)"
+    using nlength_times2 Suc_le_mono mult_le_mono1 by presburger
+  also have "... = (len - 3) * (3 + nlength (Suc idx * len))"
+    by (simp add: Suc3_eq_add_3)
+  finally have *: "nlllength ?nss \<le> (len - 3) * (3 + nlength (Suc idx * len))" .
+
+  let ?nss2 = "[[2 * (idx * len) + 1], [2 * (idx * len + 1) + 1]]"
+  have "nlllength ?nss2 = (\<Sum>ns\<leftarrow>?nss2. Suc (nllength ns))"
+    using nlllength by simp
+  also have "... = Suc (nllength [2 * (idx * len) + 1]) + Suc (nllength [2 * (idx * len + 1) + 1])"
+    by simp
+  also have "... = Suc (Suc (nlength (2 * (idx * len) + 1))) + Suc (Suc (nlength (2 * (idx * len + 1) + 1)))"
+    using nllength by simp
+  also have "... \<le> Suc (Suc (nlength (2 * (Suc idx * len)))) + Suc (Suc (nlength (2 * (idx * len + 1) + 1)))"
+    using nlength_mono assms by simp
+  also have "... \<le> Suc (Suc (nlength (2 * (Suc idx * len)))) + Suc (Suc (nlength (2 * (Suc idx * len))))"
+    using nlength_mono assms by simp
+  also have "... = 2 * Suc (Suc (nlength (2 * (Suc idx * len))))"
+    by simp
+  also have "... \<le> 2 * Suc (Suc (Suc (nlength (Suc idx * len))))"
+    using nlength_times2 by (meson Suc_le_mono mult_le_mono nle_le)
+  also have "... = 2 * (3 + nlength (Suc idx * len))"
+    by simp
+  finally have **: "nlllength ?nss2 \<le> 2 * (3 + nlength (Suc idx * len))" .
+
+  have "nll_Upsilon idx len = ?nss2 @ ?nss"
+    using nll_Upsilon_def f_def by simp
+  then have "nlllength (nll_Upsilon idx len) = nlllength ?nss2 + nlllength ?nss"
+    by (metis length_append nlllength_def numlistlist_append)
+  then have "nlllength (nll_Upsilon idx len) \<le> 2 * (3 + nlength (Suc idx * len)) + (len - 3) * (3 + nlength (Suc idx * len))"
+    using * ** by simp
+  also have "... = (2 + (len - 3)) * (3 + nlength (Suc idx * len))"
+    by simp
+  also have "... = (len - 1) * (3 + nlength (Suc idx * len))"
+    using assms Nat.le_imp_diff_is_add by fastforce
+  also have "... \<le> len * (3 + nlength (Suc idx * len))"
+    by simp
+  also have "... \<le> len * (3 + nlength (Suc idx) + nlength len)"
+    using nlength_prod by (metis ab_semigroup_add_class.add_ac(1) mult_le_mono2 nat_add_left_cancel_le)
+  also have "... \<le> len * (4 + nlength idx + nlength len)"
+    using nlength_Suc by simp
+  finally show ?thesis .
+qed
+
+text \<open>
+The next Turing machine outputs CNF formulas of the shape $\Upsilon(\gamma_i)$,
+where $\gamma_i = [i\cdot H, (i+1)\cdot H)$. It expects a number $i$ on tape $j$
+and a number $H$ on tape $j + 1$. It writes a representation of the formula to
+tape $j + 4$.
+\<close>
+
+definition tm_Upsilongamma :: "tapeidx \<Rightarrow> machine" where
+  "tm_Upsilongamma j \<equiv>
+    tm_copyn (j + 1) (j + 5) ;;
+    tm_mult j (j + 1) (j + 2) ;;
+    tm_times2_appendl True (j + 2) ;;
+    tm_times2_appendl True (j + 2) ;;
+    tm_decr (j + 5) ;;
+    tm_incr (j + 2) ;;
+    WHILE [] ; \<lambda>rs. rs ! (j + 5) \<noteq> \<box> DO
+      tm_times2_appendl False (j + 2)
+    DONE ;;
+    tm_erase_cr (j + 2) ;;
+    tm_cr (j + 4)"
+
+lemma tm_Upsilongamma_tm:
+  assumes "0 < j" and "j + 5 < k" and "G \<ge> 6"
+  shows "turing_machine k G (tm_Upsilongamma j)"
+  unfolding tm_Upsilongamma_def
+  using tm_copyn_tm Nil_tm tm_decr_tm tm_times2_appendl_tm tm_decr_tm tm_mult_tm tm_incr_tm
+    assms turing_machine_loop_turing_machine tm_erase_cr_tm tm_cr_tm
+  by simp
+
+locale turing_machine_Upsilongamma =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_copyn (j + 1) (j + 5)"
+definition "tm2 \<equiv> tm1 ;; tm_mult j (j + 1) (j + 2)"
+definition "tm3 \<equiv> tm2 ;; tm_times2_appendl True (j + 2)"
+definition "tm4 \<equiv> tm3 ;; tm_times2_appendl True (j + 2)"
+definition "tm5 \<equiv> tm4 ;; tm_decr (j + 5)"
+definition "tm6 \<equiv> tm5 ;; tm_incr (j + 2)"
+definition "tmB \<equiv> tm_times2_appendl False (j + 2)"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! (j + 5) \<noteq> \<box> DO tmB DONE"
+definition "tm7 \<equiv> tm6 ;; tmL"
+definition "tm8 \<equiv> tm7 ;; tm_erase_cr (j + 2)"
+definition "tm9 \<equiv> tm8 ;; tm_cr (j + 4)"
+
+lemma tm9_eq_tm_Upsilongamma: "tm9 = tm_Upsilongamma j"
+  using tm9_def tm8_def tm7_def tm6_def tm5_def tm4_def tm3_def tm2_def tm1_def tmB_def tmL_def tm_Upsilongamma_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and idx H k :: nat
+  assumes jk: "length tps0 = k" "0 < j" "j + 5 < k"
+    and H: "H \<ge> 3"
+  assumes tps0:
+    "tps0 ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j + 5 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 14 + 3 * nlength H"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps1_def tps0 jk)
+  show "tps0 ! (j + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using jk tps0 canrepr_0 by simp
+  show "ttt = 14 + 3 * (nlength H + nlength 0)"
+    using assms by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j + 5 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>idx * H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 18 + 3 * nlength H + 26 * (nlength idx + nlength H)^2"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps2_def tps1_def jk tps0)
+  show "tps1 ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps1_def jk canrepr_1 tps0
+    by (metis add_left_imp_eq canrepr_0 nth_list_update_neq' numeral_eq_iff semiring_norm(89))
+  show "ttt = 14 + 3 * nlength H + (4 + 26 * (nlength idx + nlength H) * (nlength idx + nlength H))"
+    using assms by algebra
+qed
+
+definition "tps3 \<equiv> tps0
+  [j + 5 := (\<lfloor>H - 1\<rfloor>\<^sub>N, 1),
+   j + 4 := nlltape ([[2 * (idx * H) + 1]]),
+   j + 2 := (\<lfloor>idx * H + 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 85 + 5 * nlength H + 26 * (nlength idx + nlength H)^2 + 15 * nlength (idx * H)"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps3_def tps2_def jk tps0)
+  have *: "j + 2 + 1 = j + 3" "j + 2 + 2 = j + 4" "j + 2 + 3 = j + 5"
+    by simp_all
+  show "tps2 ! (j + 2 + 1) = (\<lfloor>[]\<rfloor>, 1)"
+    using jk tps2_def tps0 by (simp only: *) simp
+  show "tps2 ! (j + 2 + 2) = nlltape []"
+    using jk tps2_def tps0 nllcontents_Nil by (simp only: *) simp
+  show "tps2 ! (j + 2 + 3) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using jk tps2_def tps0 by (simp only: *) simp
+  show "tps3 = tps2
+    [j + 2 := (\<lfloor>Suc (idx * H)\<rfloor>\<^sub>N, 1),
+     j + 2 + 2 := nlltape ([] @ [[2 * (idx * H) + (if True then 1 else 0)]]),
+     j + 2 + 3 := (\<lfloor>H - 1\<rfloor>\<^sub>N, 1)]"
+    unfolding tps3_def tps2_def
+    by (simp only: *) (simp add: list_update_swap[of "Suc (Suc j)"] list_update_swap_less[of "j+4"])
+  show "ttt = 18 + 3 * nlength H + 26 * (nlength idx + nlength H)\<^sup>2 +
+      (67 + 15 * nlength (idx * H) + 2 * nlength H)"
+    using assms by simp
+qed
+
+definition "tps4 \<equiv> tps0
+  [j + 5 := (\<lfloor>H - 2\<rfloor>\<^sub>N, 1),
+   j + 4 := nlltape ([[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]]),
+   j + 2 := (\<lfloor>idx * H + 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 152 + 5 * nlength H + 26 * (nlength idx + nlength H)^2 + 15 * nlength (idx * H) +
+      15 * nlength (Suc (idx * H)) + 2 * nlength (H - 1)"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: tps4_def tps3_def jk tps0)
+  have *: "j + 2 + 1 = j + 3" "j + 2 + 2 = j + 4" "j + 2 + 3 = j + 5"
+    by simp_all
+  show "tps3 ! (j + 2 + 1) = (\<lfloor>[]\<rfloor>, 1)"
+    using jk tps3_def tps0 by (simp only: *) simp
+  show "tps3 ! (j + 2 + 2) = nlltape [[2 * (idx * H) + 1]]"
+    using jk tps3_def tps0 by (simp only: *) simp
+  show "tps3 ! (j + 2 + 3) = (\<lfloor>H - 1\<rfloor>\<^sub>N, 1)"
+    using jk tps3_def tps0 by (simp only: *) simp
+  have 2: "2 = Suc (Suc 0)"
+    by simp
+  show "tps4 = tps3
+    [j + 2 := (\<lfloor>Suc (Suc (idx * H))\<rfloor>\<^sub>N, 1),
+     j + 2 + 2 := nlltape ([[2 * (idx * H) + 1]] @ [[2 * Suc (idx * H) + (if True then 1 else 0)]]),
+     j + 2 + 3 := (\<lfloor>H - 1 - 1\<rfloor>\<^sub>N, 1)]"
+    unfolding tps4_def tps3_def by (simp only: *) (simp add: 2 list_update_swap)
+  show "ttt = 85 + 5 * nlength H + 26 * (nlength idx + nlength H)\<^sup>2 + 15 * nlength (idx * H) +
+      (67 + 15 * nlength (Suc (idx * H)) + 2 * nlength (H - 1))"
+    using assms by simp
+qed
+
+definition "tps5 \<equiv> tps0
+  [j + 5 := (\<lfloor>H - 3\<rfloor>\<^sub>N, 1),
+   j + 4 := nlltape ([[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]]),
+   j + 2 := (\<lfloor>idx * H + 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 160 + 5 * nlength H + 26 * (nlength idx + nlength H)^2 + 15 * nlength (idx * H) +
+      15 * nlength (Suc (idx * H)) + 2 * nlength (H - 1) + 2 * nlength (H - 2)"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def
+proof (tform tps: tps5_def tps4_def jk tps0)
+  show "ttt = 152 + 5 * nlength H + 26 * (nlength idx + nlength H)\<^sup>2 + 15 * nlength (idx * H) +
+      15 * nlength (Suc (idx * H)) + 2 * nlength (H - 1) + (8 + 2 * nlength (H - 2)) "
+    using assms by simp
+qed
+
+definition "tps6 \<equiv> tps0
+  [j + 5 := (\<lfloor>H - 3\<rfloor>\<^sub>N, 1),
+   j + 4 := nlltape ([[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]]),
+   j + 2 := (\<lfloor>idx * H + 3\<rfloor>\<^sub>N, 1)]"
+
+lemma tm6:
+  assumes "ttt = 165 + 5 * nlength H + 26 * (nlength idx + nlength H)^2 + 15 * nlength (idx * H) +
+      15 * nlength (Suc (idx * H)) + 2 * nlength (H - 1) + 2 * nlength (H - 2) +
+      2 * nlength (Suc (Suc (idx * H)))"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+proof (tform tps: tps6_def tps5_def jk tps0)
+  show "tps6 = tps5[j + 2 := (\<lfloor>Suc (Suc (Suc (idx * H)))\<rfloor>\<^sub>N, 1)]"
+    unfolding tps5_def tps6_def
+    by (simp only: One_nat_def Suc_1 add_2_eq_Suc' add_Suc_right numeral_3_eq_3) (simp add: list_update_swap)
+  show "ttt = 160 + 5 * nlength H + 26 * (nlength idx + nlength H)\<^sup>2 + 15 * nlength (idx * H) +
+      15 * nlength (Suc (idx * H)) + 2 * nlength (H - 1) + 2 * nlength (H - 2) +
+      (5 + 2 * nlength (Suc (Suc (idx * H))))"
+    using assms by simp
+qed
+
+lemma tm6' [transforms_intros]:
+  assumes "ttt = 165 + 41 * nlength (Suc idx * H) + 26 * (nlength idx + nlength H)^2"
+  shows "transforms tm6 tps0 ttt tps6"
+proof -
+  let ?ttt = "165 + 5 * nlength H + 26 * (nlength idx + nlength H)^2 + 15 * nlength (idx * H) +
+      15 * nlength (Suc (idx * H)) + 2 * nlength (H - 1) + 2 * nlength (H - 2) +
+      2 * nlength (Suc (Suc (idx * H)))"
+  have "?ttt \<le> 165 + 5 * nlength (Suc idx * H) + 26 * (nlength idx + nlength H)^2 + 15 * nlength (idx * H) +
+      15 * nlength (Suc (idx * H)) + 2 * nlength (H - 1) + 2 * nlength (H - 2) +
+      2 * nlength (Suc (Suc (idx * H)))"
+    using nlength_mono by simp
+  also have "... \<le> 165 + 5 * nlength (Suc idx * H) + 26 * (nlength idx + nlength H)^2 + 15 * nlength (idx * H) +
+      15 * nlength (Suc (idx * H)) + 2 * nlength (Suc idx * H) + 2 * nlength (H - 2) +
+      2 * nlength (Suc (Suc (idx * H)))"
+    using nlength_mono by simp
+  also have "... \<le> 165 + 5 * nlength (Suc idx * H) + 26 * (nlength idx + nlength H)^2 + 15 * nlength (idx * H) +
+      15 * nlength (Suc (idx * H)) + 2 * nlength (Suc idx * H) + 2 * nlength (Suc idx * H) +
+      2 * nlength (Suc (Suc (idx * H)))"
+    using nlength_mono by simp
+  also have "... \<le> 165 + 5 * nlength (Suc idx * H) + 26 * (nlength idx + nlength H)^2 + 15 * nlength (Suc idx * H) +
+      15 * nlength (Suc (idx * H)) + 2 * nlength (Suc idx * H) + 2 * nlength (Suc idx * H) +
+      2 * nlength (Suc (Suc (idx * H)))"
+    using nlength_mono by simp
+  also have "... \<le> 165 + 5 * nlength (Suc idx * H) + 26 * (nlength idx + nlength H)^2 + 15 * nlength (Suc idx * H) +
+      15 * nlength (Suc idx * H) + 2 * nlength (Suc idx * H) + 2 * nlength (Suc idx * H) +
+      2 * nlength (Suc (Suc (idx * H)))"
+    using nlength_mono H by simp
+  also have "... \<le> 165 + 5 * nlength (Suc idx * H) + 26 * (nlength idx + nlength H)^2 + 15 * nlength (Suc idx * H) +
+      15 * nlength (Suc idx * H) + 2 * nlength (Suc idx * H) + 2 * nlength (Suc idx * H) +
+      2 * nlength (Suc idx * H)"
+    using nlength_mono H by simp
+  also have "... = 165 + 41 * nlength (Suc idx * H) + 26 * (nlength idx + nlength H)^2"
+    using nlength_mono by simp
+  finally have "?ttt \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using tm6 transforms_monotone by simp
+qed
+
+definition "tpsL t \<equiv> tps0
+  [j + 5 := (\<lfloor>H - 3 - t\<rfloor>\<^sub>N, 1),
+   j + 4 := nlltape ([[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]] @ map (\<lambda>i. [2 * (idx * H + i)]) [3..<3 + t]),
+   j + 2 := (\<lfloor>idx * H + 3 + t\<rfloor>\<^sub>N, 1)]"
+
+lemma tpsL_eq_tps6: "tpsL 0 = tps6"
+  using tpsL_def tps6_def by simp
+
+lemma map_Suc_append: "a \<le> b \<Longrightarrow> map f [a..<Suc b] = map f [a..<b] @ [f b]"
+  by simp
+
+lemma tmB:
+  assumes "ttt = 67 + 15 * nlength (idx * H + 3 + t) + 2 * nlength (H - 3 - t)"
+  shows "transforms tmB (tpsL t) ttt (tpsL (Suc t))"
+  unfolding tmB_def
+proof (tform tps: tpsL_def jk tps0)
+  have *: "j + 2 + 1 = j + 3" "j + 2 + 2 = j + 4" "j + 2 + 3 = j + 5"
+    by simp_all
+  show "tpsL t ! (j + 2 + 1) = (\<lfloor>[]\<rfloor>, 1)"
+    using jk tpsL_def tps0 by (simp only: *) simp
+  let ?nss = "[[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]] @ map (\<lambda>i. [2 * (idx * H + i)]) [3..<3 + t]"
+  show "tpsL t ! (j + 2 + 2) = nlltape ?nss"
+    using jk tpsL_def by (simp only: *) simp
+  show "tpsL t ! (j + 2 + 3) = (\<lfloor>H - 3 - t\<rfloor>\<^sub>N, 1)"
+    using jk tpsL_def by (simp only: *) simp
+  have "map (\<lambda>i. [2 * (idx * H + i)]) [3..<3 + Suc t] =
+      map (\<lambda>i. [2 * (idx * H + i)]) [3..<3 + t] @ [[2 * (idx * H + 3 + t) + (if False then 1 else 0)]]"
+    using map_Suc_append[of "3" "3 + t" "\<lambda>i. [2 * (idx * H + i)]"] by simp
+  then have "[[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]] @ map (\<lambda>i. [2 * (idx * H + i)]) [3..<3 + Suc t] =
+      ?nss @ [[2 * (idx * H + 3 + t) + (if False then 1 else 0)]]"
+    by simp
+  then show "tpsL (Suc t) = (tpsL t)
+    [j + 2 := (\<lfloor>Suc (idx * H + 3 + t)\<rfloor>\<^sub>N, 1),
+     j + 2 + 2 := nlltape (?nss @ [[2 * (idx * H + 3 + t) + (if False then 1 else 0)]]),
+     j + 2 + 3 := (\<lfloor>H - 3 - t - 1\<rfloor>\<^sub>N, 1)]"
+    unfolding tpsL_def
+    by (simp only: *) (simp add: list_update_swap[of "Suc (Suc j)"] list_update_swap_less[of "j + 4"])
+  show "ttt = 67 + 15 * nlength (idx * H + 3 + t) + 2 * nlength (H - 3 - t)"
+    using assms by simp
+qed
+
+lemma tmB' [transforms_intros]:
+  assumes "ttt = 67 + 15 * nlength (Suc idx * H) + 2 * nlength H"
+    and "t < H - 3"
+  shows "transforms tmB (tpsL t) ttt (tpsL (Suc t))"
+proof -
+  let ?ttt = "67 + 15 * nlength (idx * H + 3 + t) + 2 * nlength (H - 3 - t)"
+  have "?ttt \<le> 67 + 15 * nlength (idx * H + 3 + t) + 2 * nlength H"
+    using nlength_mono by simp
+  also have "... \<le> 67 + 15 * nlength (Suc idx * H) + 2 * nlength H"
+    using assms(2) nlength_mono by simp
+  finally have "?ttt \<le> ttt"
+    using assms(1) by simp
+  then show ?thesis
+    using tmB transforms_monotone by blast
+qed
+
+lemma tmL:
+  assumes "ttt = H * (70 + 17 * nlength (Suc idx * H))"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (H - 3))"
+  unfolding tmL_def
+proof (tform)
+  have "read (tpsL t) ! (j + 5) = \<box> \<longleftrightarrow> H - 3 - t = 0" for t
+    using jk tpsL_def read_ncontents_eq_0 by simp
+  then show "\<And>t. t < H - 3 \<Longrightarrow> read (tpsL t) ! (j + 5) \<noteq> \<box>"
+      and "\<not> read (tpsL (H - 3)) ! (j + 5) \<noteq> \<box>"
+    by simp_all
+  show "(H - 3) * (67 + 15 * nlength (Suc idx * H) + 2 * nlength H + 2) + 1 \<le> ttt"
+    (is "?lhs \<le> ttt")
+  proof -
+    have "?lhs = (H - 3) * (69 + 15 * nlength (Suc idx * H) + 2 * nlength H) + 1"
+      by simp
+    also have "... \<le> (H - 3) * (69 + 15 * nlength (Suc idx * H) + 2 * nlength (Suc idx * H)) + 1"
+      using nlength_mono by simp
+    also have "... = (H - 3) * (69 + 17 * nlength (Suc idx * H)) + 1"
+      by simp
+    also have "... \<le> H * (69 + 17 * nlength (Suc idx * H)) + 1"
+      by simp
+    also have "... \<le> H * (69 + 17 * nlength (Suc idx * H)) + H"
+      using H by simp
+    also have "... = H * (70 + 17 * nlength (Suc idx * H))"
+      by algebra
+    finally show "?lhs \<le> ttt"
+      using assms by simp
+  qed
+qed
+
+definition "tps7 \<equiv> tps0
+  [j + 5 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j + 4 := nlltape ([[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]] @ map (\<lambda>i. [2 * (idx * H + i)]) [3..<H]),
+   j + 2 := (\<lfloor>Suc idx * H\<rfloor>\<^sub>N, 1)]"
+
+lemma tpsL_eq_tps7: "tpsL (H - 3) = tps7"
+proof -
+  let ?t = "H - 3"
+  have "(\<lfloor>H - 3 - ?t\<rfloor>\<^sub>N, 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    by simp
+  moreover have "nlltape ([[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]] @ map (\<lambda>i. [2 * (idx * H + i)]) [3..<3 + ?t]) =
+      nlltape ([[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]] @ map (\<lambda>i. [2 * (idx * H + i)]) [3..<H])"
+    using H by simp
+  moreover have "(\<lfloor>idx * H + 3 + ?t\<rfloor>\<^sub>N, 1) = (\<lfloor>Suc idx * H\<rfloor>\<^sub>N, 1)"
+    using H by (simp add: add.commute)
+  ultimately show ?thesis
+    using tpsL_def tps7_def by simp
+qed
+
+lemma tmL' [transforms_intros]:
+  assumes "ttt = H * (70 + 17 * nlength (Suc idx * H))"
+  shows "transforms tmL tps6 ttt tps7"
+  using tmL tpsL_eq_tps6 tpsL_eq_tps7 assms by simp
+
+lemma tm7 [transforms_intros]:
+  assumes "ttt = 165 + 41 * nlength (H + idx * H) + 26 * (nlength idx + nlength H)\<^sup>2 +
+      H * (70 + 17 * nlength (H + idx * H))"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def by (tform tps: tps7_def tpsL_def jk tps0 time: assms)
+
+definition "tps8 \<equiv> tps0
+  [j + 5 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j + 4 := nlltape ([[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]] @ map (\<lambda>i. [2 * (idx * H + i)]) [3..<H]),
+   j + 2 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm8:
+  assumes "ttt = 172 + 43 * nlength (H + idx * H) + 26 * (nlength idx + nlength H)\<^sup>2 +
+      H * (70 + 17 * nlength (H + idx * H))"
+  shows "transforms tm8 tps0 ttt tps8"
+  unfolding tm8_def
+proof (tform tps: tps8_def tps7_def jk tps0 assms)
+  show "proper_symbols (canrepr (H + idx * H))"
+    using proper_symbols_canrepr by simp
+qed
+
+definition "tps8' \<equiv> tps0[j + 4 := nlltape (nll_Upsilon idx H)]"
+
+lemma tps8'_eq_tps8: "tps8' = tps8"
+proof -
+  define tps where "tps = tps0
+    [j + 4 := nlltape ([[2 * (idx * H) + 1], [2 * (idx * H + 1) + 1]] @ map (\<lambda>i. [2 * (idx * H + i)]) [3..<H])]"
+  then have "tps = tps8"
+    using jk tps8_def canrepr_0 tps0
+    by (smt (verit, best) add_left_imp_eq arith_simps(4) list_update_id list_update_swap num.simps(2) numeral_eq_iff semiring_norm(83))
+  then show ?thesis
+    using nll_Upsilon_def tps8'_def tps_def by simp
+qed
+
+lemma tm8' [transforms_intros]:
+  assumes "ttt = 199 * H * (nlength idx + nlength H)^2"
+  shows "transforms tm8 tps0 ttt tps8'"
+proof -
+  let ?ttt = "172 + 43 * nlength (H + idx * H) + 26 * (nlength idx + nlength H)\<^sup>2 +
+      H * (70 + 17 * nlength (H + idx * H))"
+  have "?ttt = 172 + 43 * nlength (H + idx * H) + 26 * (nlength idx + nlength H)\<^sup>2 +
+      70 * H + 17 * H * nlength (H + idx * H)"
+    by algebra
+  also have "... = 172 + 70 * H + (17 * H + 43) * nlength (H + idx * H) + 26 * (nlength idx + nlength H)\<^sup>2"
+    by algebra
+  also have "... = 172 + 70 * H + (17 * H + 43) * nlength (Suc idx * H) + 26 * (nlength idx + nlength H)\<^sup>2"
+    by simp
+  also have "... \<le> 172 + 70 * H + (17 * H + 43) * (nlength (Suc idx) + nlength H) + 26 * (nlength idx + nlength H)\<^sup>2"
+    using nlength_prod by (meson add_le_mono mult_le_mono order_refl)
+  also have "... \<le> 172 + 70 * H + (17 * H + 43) * (Suc (nlength idx) + nlength H) + 26 * (nlength idx + nlength H)\<^sup>2"
+    using nlength_Suc add_le_mono le_refl mult_le_mono by presburger
+  also have "... = 172 + 70 * H + (17 * H + 43) + (17 * H + 43) * (nlength idx + nlength H) + 26 * (nlength idx + nlength H)\<^sup>2"
+    by simp
+  also have "... = 215 + 87 * H + (17 * H + 43) * (nlength idx + nlength H) + 26 * (nlength idx + nlength H)\<^sup>2"
+    by simp
+  also have "... \<le> 215 + 87 * H + (17 * H + 43) * (nlength idx + nlength H)^2 + 26 * (nlength idx + nlength H)\<^sup>2"
+    using linear_le_pow by simp
+  also have "... = 215 + 87 * H + (17 * H + 69) * (nlength idx + nlength H)^2"
+    by algebra
+  also have "... \<le> 159 * H + (17 * H + 69) * (nlength idx + nlength H)^2"
+    using H by simp
+  also have "... \<le> 159 * H + 40 * H * (nlength idx + nlength H)^2"
+    using H by simp
+  also have "... \<le> 199 * H * (nlength idx + nlength H)^2"
+  proof -
+    have "nlength H > 0"
+      using H nlength_0 by simp
+    then have "nlength idx + nlength H \<ge> 1"
+      by linarith
+    then show ?thesis
+      by simp
+  qed
+  finally have "?ttt \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using tps8'_eq_tps8 tm8 transforms_monotone by simp
+qed
+
+definition "tps9 \<equiv> tps0
+  [j + 4 := (\<lfloor>nll_Upsilon idx H\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm9:
+  assumes "ttt = 199 * H * (nlength idx + nlength H)^2 + Suc (Suc (Suc (nlllength (nll_Upsilon idx H))))"
+  shows "transforms tm9 tps0 ttt tps9"
+  unfolding tm9_def
+proof (tform tps: tps8'_def tps9_def jk tps0 assms)
+  show "clean_tape (tps8' ! (j + 4))"
+    using tps8'_def jk tps0 clean_tape_nllcontents by simp
+qed
+
+lemma tm9' [transforms_intros]:
+  assumes "ttt = 205 * H * (nlength idx + nlength H)^2"
+  shows "transforms tm9 tps0 ttt tps9"
+proof -
+  let ?ttt = "199 * H * (nlength idx + nlength H)^2 + Suc (Suc (Suc (nlllength (nll_Upsilon idx H))))"
+  have "?ttt \<le> 199 * H * (nlength idx + nlength H)^2 + Suc (Suc (Suc (H * (4 + nlength idx + nlength H))))"
+    using nlllength_nll_Upsilon_le H by simp
+  also have "... = 199 * H * (nlength idx + nlength H)^2 + 3 + H * (4 + nlength idx + nlength H)"
+    by simp
+  also have "... = 199 * H * (nlength idx + nlength H)^2 + 3 + 4 * H + H * (nlength idx + nlength H)"
+    by algebra
+  also have "... \<le> 199 * H * (nlength idx + nlength H)^2 + 5 * H + H * (nlength idx + nlength H)"
+    using H by simp
+  also have "... \<le> 199 * H * (nlength idx + nlength H)^2 + 5 * H + H * (nlength idx + nlength H)^2"
+    using linear_le_pow by simp
+  also have "... = 200 * H * (nlength idx + nlength H)^2 + 5 * H"
+    by simp
+  also have "... \<le> 205 * H * (nlength idx + nlength H)^2"
+  proof -
+    have "nlength H \<ge> 1"
+      using H nlength_0 by (metis less_one not_less not_numeral_le_zero)
+    then show ?thesis
+      by simp
+  qed
+  finally have "?ttt \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using tm9 transforms_monotone by simp
+qed
+
+end  (* context *)
+
+end  (* locale turing_machine_Upsilongamma *)
+
+lemma transforms_tm_UpsilongammaI [transforms_intros]:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt idx H k :: nat
+  assumes "length tps = k" and "0 < j" and "j + 5 < k"
+    and "H \<ge> 3"
+  assumes
+    "tps ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 205 * H * (nlength idx + nlength H)^2"
+  assumes "tps' = tps[j + 4 := (\<lfloor>nll_Upsilon idx H\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+  shows "transforms (tm_Upsilongamma j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_Upsilongamma j .
+  show ?thesis
+    using assms loc.tm9_eq_tm_Upsilongamma loc.tm9' loc.tps9_def by simp
+qed
+
+end
diff --git a/thys/Cook_Levin/Basics.thy b/thys/Cook_Levin/Basics.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Basics.thy
@@ -0,0 +1,2776 @@
+chapter \<open>Introduction\<close>
+
+text \<open>
+The Cook-Levin theorem states that the problem \SAT{} of deciding the
+satisfiability of Boolean formulas in conjunctive normal form is
+$\NP$-complete~\cite{Cook,Levin}. This article formalizes a proof of this
+theorem based on the textbook \emph{Computational Complexity:\ A Modern
+Approach} by Arora and Barak~\cite{ccama}.
+\<close>
+
+section \<open>Outline\<close>
+
+text \<open>
+We start out in Chapter~\ref{s:TM} with a definition of multi-tape Turing
+machines (TMs) slightly modified from Arora and Barak's definition. The
+remainder of the chapter is devoted to constructing ever more complex machines
+for arithmetic on binary numbers, evaluating polynomials, and performing basic
+operations on lists of numbers and even lists of lists of numbers.
+
+Specifying Turing machines and proving their correctness and running time is
+laborious at the best of times. We slightly alleviate the seemingly inevitable
+tedium of this by defining elementary reusable Turing machines and introducing
+ways of composing them sequentially as well as in if-then-else branches and
+while loops. Together with the representation of natural numbers and lists, we
+thus get something faintly resembling a structured programming language of
+sorts.
+
+In Chapter~\ref{s:TC} we introduce some basic concepts of complexity theory,
+such as $\mathcal{P}$, $\NP$, and polynomial-time many-one reduction.  Following
+Arora and Barak the complexity class $\NP$ is defined via verifier Turing
+machines rather than nondeterministic machines, and so the deterministic TMs
+introduced in the previous chapter suffice for all definitions. To flesh out the
+chapter a little we formalize obvious proofs of $\mathcal{P} \subseteq \NP$ and
+the transitivity of the reducibility relation, although neither result is needed
+for proving the Cook-Levin theorem.
+
+Chapter~\ref{s:Sat} introduces the problem \SAT{} as a language over bit
+strings. Boolean formulas in conjunctive normal form (CNF) are represented as
+lists of clauses, each consisting of a list of literals encoded in binary numbers.
+The list of lists of numbers ``data type'' defined in Chapter~\ref{s:TM} will
+come in handy at this point.
+
+The proof of the Cook-Levin theorem has two parts: Showing that \SAT{} is in
+$\NP$ and showing that \SAT{} is $\NP$-hard, that is, that every language in
+$\NP$ can be reduced to \SAT{} in polynomial time. The first part, also proved
+in Chapter~\ref{s:Sat}, is fairly easy: For a satisfiable CNF formula, a
+satisfying assignment can be given in roughly the size of the formula, because
+only the variables in the formula need be assigned a truth value.  Moreover
+whether an assignment satisfies a CNF formula can be verified easily.
+
+The hard part is showing the $\NP$-hardness of \SAT{}. The first step
+(Chapter~\ref{s:oblivious}) is to show that every polynomial-time computation on
+a multi-tape TM can be performed in polynomial time on a two-tape
+\emph{oblivious} TM.  Oblivious means that the sequence of positions of the
+Turing machine's tape heads depends only on the \emph{length} of the input.
+Thus any language in $\NP$ has a polynomial-time two-tape oblivious verifier TM.
+In Chapter~\ref{s:Reducing} the proof goes on to show how the computations of
+such a machine can be mapped to CNF formulas such that a CNF formula is
+satisfiable if and only if the underlying computation was for a string in the
+language \SAT{} paired with a certificate. Finally in Chapter~\ref{s:Aux_TM} and
+Chapter~\ref{s:Red_TM} we construct a Turing machine that carries out the
+reduction in polynomial time.
+\<close>
+
+
+section \<open>Related work\<close>
+
+text \<open>
+The Cook-Levin theorem has been formalized before. Gamboa and
+Cowles~\cite{Gamboa2004AMP} present a formalization in ACL2~\cite{acl2}.  They
+formalize $\NP$ and reducibility in terms of Turing machines, but analyze the
+running time of the reduction from $\NP$-languages to \SAT{} in a
+different, somewhat ad-hoc, model of computation that they call ``the major
+weakness'' of their formalization.
+
+Employing Coq~\cite{coq}, Gäher and Kunze~\cite{Gher2021MechanisingCT} define
+$\NP$ and reducibility in the computational model ``call-by-value
+$\lambda$-calculus L'' introduced by Forster and
+Smolka~\cite{Forster2017WeakCL}. They show the $\NP$-completeness of \SAT{} in
+this framework. Turing machines appear in an intermediate problem in the chain
+of reductions from $\NP$ languages to \SAT{}, but are not used to show the
+polynomiality of the reduction. Nevertheless, this is likely the first
+formalization of the Cook-Levin theorem where both the complexity theoretic
+concepts and the proof of the polynomiality of the reduction use the same model
+of computation.
+
+With regards to Isabelle, Xu~et al.~\cite{Universal_Turing_Machine-AFP} provide
+a formalization of single-tape Turing machines with a fixed binary alphabet in
+the computability theory setting and construct a universal TM.  While I was
+putting the finishing touches on this article, Dalvit and
+Thiemann~\cite{Multitape_To_Singletape_TM-AFP} published a formalization of
+(deterministic and nondeterministic) multi-tape and single-tape Turing machines
+and showed how to simulate the former on the latter with quadratic slowdown.
+Moreover, Thiemann and Schmidinger~\cite{Multiset_Ordering_NPC-AFP} prove the
+$\NP$-completeness of the Multiset Ordering problem, without, however, proving
+the polynomial-time computability of the reduction.
+
+This article uses Turing machines as model of computation for both the
+complexity theoretic concepts and the running time analysis of the reduction. It
+is thus most similar to Gäher and Kunze's work, but has a more elementary, if
+not brute-force, flavor to it.
+\<close>
+
+
+section \<open>The core concepts\<close>
+
+text \<open>
+The proof of the Cook-Levin theorem awaits us in Section~\ref{s:complete} on the
+very last page of this article. The way there is filled with definitions of
+Turing machines, correctness proofs for Turing machines, and running time-bound
+proofs for Turing machines, all of which can easily drown out the more relevant
+concepts. For instance, for verifying that the theorem on the last page really
+is the Cook-Levin theorem, only a small fraction of this article is relevant,
+namely the definitions of $\NP$-completeness and of \SAT{}. Recursively breaking
+down these definitions yields:
+
+\begin{itemize}
+  \item $\NP$-completeness: Section~\ref{s:TC-NP}
+  \begin{itemize}
+    \item languages: Section~\ref{s:TC-NP}
+    \item $\NP$-hard: Section~\ref{s:TC-NP}
+    \begin{itemize}
+      \item $\NP$: Section~\ref{s:TC-NP}
+      \begin{itemize}
+        \item Turing machines: Section~\ref{s:tm-basic-tm}
+        \item computing a function: Section~\ref{s:tm-basic-comp}
+        \item pairing strings: Section~\ref{s:tm-basic-pair}
+        \item Big-Oh, polynomial: Section~\ref{s:tm-basic-bigoh}
+      \end{itemize}
+      \item polynomial-time many-one reduction: Section~\ref{s:TC-NP}
+    \end{itemize}
+  \end{itemize}
+
+  \item \SAT{}: Section~\ref{s:sat-sat-repr}
+  \begin{itemize}
+    \item literal, clause, CNF formula, assignment, satisfiability: Section~\ref{s:CNF}
+    \item representing CNF formulas as strings: Section~\ref{s:sat-sat-repr}
+    \begin{itemize}
+      \item string: Section~\ref{s:tm-basic-tm}
+      \item CNF formula: Section~\ref{s:CNF}
+      \item mapping between symbols and strings: Section~\ref{s:tm-basic-comp}
+      \item mapping between binary and quaternary alphabets: Section~\ref{s:tm-quaternary-encoding}
+      \item lists of lists of natural numbers: Section~\ref{s:tm-numlistlist-repr}
+      \begin{itemize}
+        \item binary representation of natural numbers: Section~\ref{s:tm-arithmetic-binary}
+        \item lists of natural numbers: Section~\ref{s:tm-numlist-repr}
+      \end{itemize}
+    \end{itemize}
+  \end{itemize}
+\end{itemize}
+
+In other words the Sections~\ref{s:tm-basic}, \ref{s:tm-arithmetic-binary},
+\ref{s:tm-numlist-repr}, \ref{s:tm-numlistlist-repr}, \ref{s:tm-quaternary-encoding},
+\ref{s:TC-NP}, \ref{s:CNF}, and \ref{s:sat-sat-repr} cover all definitions for
+formalizing the statement ``\SAT{} is $\NP$-complete''.
+\<close>
+
+
+chapter \<open>Turing machines\label{s:TM}\<close>
+
+text \<open>
+This chapter introduces Turing machines as a model of computing functions within
+a running-time bound. Despite being quite intuitive, Turing machines are
+notoriously tedious to work with. And so most of the rest of the chapter is
+devoted to making this a little easier by providing means of combining TMs and a
+library of reusable TMs for common tasks.
+
+The basic idea (Sections~\ref{s:tm-basic} and~\ref{s:tm-trans}) is to treat
+Turing machines as a kind of GOTO programming language. A state of a TM
+corresponds to a line of code executing a rather complex command that, depending
+on the symbols read, can write symbols, move tape heads, and jump to another
+state (that is, line of code). States are identified by line numbers. This makes
+it easy to execute TMs in sequence by concatenating two TM ``programs''. On top
+of the GOTO implicit in all commands, we then define IF and WHILE in the
+traditional way (Section~\ref{s:tm-combining}). This makes TMs more composable.
+
+The interpretation of states as line numbers deprives TMs of the ability to
+memorize values ``in states'', for example, the carry bit during a binary
+addition. In Section~\ref{s:tm-memorizing} we recover some of this flexibility.
+
+Being able to combine TMs is helpful, but we also need TMs to combine. This
+takes up most of the remainder of the chapter. We start with simple operations,
+such as moving a tape head to the next blank symbol or copying symbols between
+tapes (Section~\ref{s:tm-elementary}). Extending our programming language
+analogy for more complex TMs, we identify tapes with variables, so that a tape
+contains a value of a specific type, such as a number or a list of numbers. In
+the remaining Sections~\ref{s:tm-arithmetic} to~\ref{s:tm-wellformed} we define
+these ``data types'' and devise TMs for operations over them.
+
+It would be an exaggeration to say all this makes working with Turing machines
+easy or fun. But at least it makes TMs somewhat more feasible to use for
+complexity theory, as witnessed by the subsequent chapters.
+\<close>
+
+
+section \<open>Basic definitions\label{s:tm-basic}\<close>
+
+theory Basics
+  imports Main
+begin
+
+text \<open>
+While Turing machines are fairly simple, there are still a few parts to define,
+especially if one allows multiple tapes and an arbitrary alphabet: states, tapes
+(read-only or read-write), cells, tape heads, head movements, symbols, and
+configurations. Beyond these are more semantic aspects like executing one or
+many steps of a Turing machine, its running time, and what it means for a TM to
+``compute a function''. Our approach at formalizing all this must look rather
+crude compared to Dalvit and Thiemann's~\cite{Multitape_To_Singletape_TM-AFP},
+but still it does get the job done.
+
+For lack of a better place, this section also introduces a minimal version of
+Big-Oh, polynomials, and a pairing function for strings.
+\<close>
+
+
+subsection \<open>Multi-tape Turing machines\label{s:tm-basic-tm}\<close>
+
+text \<open>
+Arora and Barak~\cite[p.~11]{ccama} define multi-tape Turing machines with these
+features:
+
+\begin{itemize}
+\item There are $k \geq 2$ infinite one-directional tapes, and each has one head.
+\item The first tape is the input tape and read-only; the other $k - 1$ tapes
+  can be written to.
+\item The tape alphabet is a finite set $\Gamma$ containing at least the blank
+  symbol $\Box$, the start symbol $\triangleright$, and the symbols \textbf{0}
+  and \textbf{1}.
+\item There is a finite set $Q$ of states with start state and halting state
+  $q_\mathit{start}, q_\mathit{halt} \in Q$.
+\item The behavior is described by a transition function $\delta\colon\ Q
+  \times \Gamma^k \to Q \times \Gamma^{k-1} \times \{L, S, R\}^k$.  If the TM is
+  in a state $q$ and the symbols $g_1,\dots,g_k$ are under the $k$ tape heads
+  and $\delta(q, (g_1, \dots, g_k)) = (q', (g'_2, \dots, g'_k), (d_1, \dots,
+  d_k))$, then the TM writes $g'_2, \dots, g'_k$ to the writable tapes, moves
+  the tape heads in the direction (Left, Stay, or Right) indicated by the $d_1,
+  \dots, d_k$ and switches to state $q'$.
+\end{itemize}
+\<close>
+
+
+subsubsection \<open>Syntax\<close>
+
+text \<open>
+An obvious data type for the direction a tape head can move:
+\<close>
+
+datatype direction = Left | Stay | Right
+
+text \<open>
+We simplify the definition a bit in that we identify both symbols and states
+with natural numbers:
+\begin{itemize}
+\item We set $\Gamma = \{0, 1, \dots, G - 1\}$ for some $G \geq 4$ and represent
+  the symbols $\Box$, $\triangleright$, \textbf{0}, and \textbf{1} by the
+  numbers 0, 1, 2, and~3, respectively. We represent an alphabet $\Gamma$ by its
+  size $G$.
+\item We let the set of states be of the form $\{0, 1, \dots, Q\}$ for some
+  $Q\in\nat$ and set the start state $q_\mathit{start} = 0$ and halting state
+  $q_\mathit{halt} = Q$.
+\end{itemize}
+
+The last item presents a fundamental difference to the textbook definition,
+because it requires that Turing machines with $q_\mathit{start} =
+q_\mathit{halt}$ have exactly one state, whereas the textbook definition allows
+them arbitrarily many states.  However, if $q_\mathit{start} = q_\mathit{halt}$
+then the TM starts in the halting state and thus does not actually do anything.
+But then it does not matter if there are other states besides that one
+start/halting state.  Our simplified definition therefore does not restrict the
+expressive power of TMs. It does, however, simplify composing them.
+\<close>
+
+text \<open>
+The type @{type nat} is used for symbols and for states.
+\<close>
+
+type_synonym state = nat
+
+type_synonym symbol = nat
+
+text \<open>
+It is confusing to have the numbers 2 and 3 represent the symbols \textbf{0} and
+\textbf{1}. The next abbreviations try to hide this somewhat. The glyphs for
+symbols number~4 and~5 are chosen arbitrarily. While we will encounter Turing
+machines with huge alphabets, only the following symbols will be used literally:
+\<close>
+
+abbreviation (input) blank_symbol :: nat ("\<box>") where "\<box> \<equiv> 0"
+abbreviation (input) start_symbol :: nat ("\<triangleright>")   where "\<triangleright> \<equiv> 1"
+abbreviation (input) zero_symbol :: nat ("\<zero>")   where "\<zero> \<equiv> 2"
+abbreviation (input) one_symbol :: nat ("\<one>")    where "\<one> \<equiv> 3"
+abbreviation (input) bar_symbol :: nat ("\<bar>")      where "\<bar> \<equiv> 4"
+abbreviation (input) sharp_symbol :: nat ("\<sharp>")  where "\<sharp> \<equiv> 5"
+
+no_notation abs ("\<bar>_\<bar>")
+
+text \<open>
+Tapes are infinite in one direction, so each cell can be addressed by a natural
+number. Likewise the position of a tape head is a natural number. The contents
+of a tape are represented by a mapping from cell numbers to symbols. A
+\emph{tape} is a pair of tape contents and head position:
+\<close>
+
+type_synonym tape = "(nat \<Rightarrow> symbol) \<times> nat"
+
+text \<open>
+Our formalization of Turing machines begins with a data type representing a more
+general concept, which we call \emph{machine}, and later adds a predicate to
+define which machines are \emph{Turing} machines. In this generalization the
+number $k$ of tapes is arbitrary, although machines with zero tapes are of
+little interest. Also, all tapes are writable and the alphabet is not limited,
+that is, $\Gamma = \nat$. The transition function becomes
+$
+  \delta\colon\ \{0, \dots, Q\} \times \nat^k \to \{0, \dots, Q\} \times \nat^k \times \{L,S,R\}^k
+$
+or, saving us one occurrence of~$k$,
+$
+  \delta\colon\ \{0, \dots, Q\} \times \nat^k \to \{0, \dots, Q\} \times (\nat \times \{L,S,R\})^k\;.
+$
+
+The transition function $\delta$ has a fixed behavior in the state $q_{halt} =
+Q$ (namely making the machine do nothing). Hence $\delta$ needs to be specified
+only for the $Q$ states $0, \dots, Q - 1$ and thus can be given as a sequence
+$\delta_0, \dots, \delta_{Q-1}$ where each $\delta_q$ is a function
+\begin{equation} \label{eq:wf}
+  \delta_q\colon \nat^k \to \{0, \dots, Q\} \times (\nat \times \{L,S,R\})^k.
+\end{equation}
+Going one step further we allow the machine to jump to any state in $\nat$, and
+we will treat any state $q \geq Q$ as a halting state. The $\delta_q$ are then
+\begin{equation} \label{eq:proper}
+  \delta_q\colon \nat^k \to \nat \times (\nat \times \{L,S,R\})^k.
+\end{equation}
+Finally we allow inputs and outputs of arbitrary length, turning the $\delta_q$
+into
+\[
+  \delta_q\colon \nat^* \to \nat \times (\nat \times \{L,S,R\})^*.
+\]
+Such a $\delta_q$ will be called a \emph{command}, and the elements of $\nat
+\times \{L,S,R\}$ will be called \emph{actions}. An action consists of writing a
+symbol to a tape at the current tape head position and then moving the tape
+head.
+\<close>
+
+type_synonym action = "symbol \<times> direction"
+
+text \<open>
+A command maps the list of symbols read from the tapes to a follow-up state and
+a list of actions. It represents the machine's behavior in one state.
+\<close>
+
+type_synonym command = "symbol list \<Rightarrow> state \<times> action list"
+
+text \<open>
+Machines are then simply lists of commands. The $q$-th element of the list
+represents the machine's behavior in state $q$. The halting state of a machine
+$M$ is @{term "length M"}, but there is obviously no such element in the list.
+\<close>
+
+type_synonym machine = "command list"
+
+text \<open>
+Commands in this general form are too amorphous. We call a command
+\emph{well-formed} for $k$ tapes and the state space $Q$ if on reading $k$
+symbols it performs $k$ actions and jumps to a state in $\{0, \dots, Q\}$. A
+well-formed command corresponds to (\ref{eq:wf}).
+\<close>
+
+definition wf_command :: "nat \<Rightarrow> nat \<Rightarrow> command \<Rightarrow> bool" where
+  "wf_command k Q cmd \<equiv> \<forall>gs. length gs = k \<longrightarrow> length (snd (cmd gs)) = k \<and> fst (cmd gs) \<le> Q"
+
+text \<open>
+A well-formed command is a \emph{Turing command} for $k$ tapes and alphabet $G$
+if it writes only symbols from $G$ when reading symbols from $G$ and does not
+write to tape $0$; that is, it writes to tape $0$ the symbol it read from
+tape~$0$.
+\<close>
+
+definition turing_command :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> command \<Rightarrow> bool" where
+  "turing_command k Q G cmd \<equiv>
+    wf_command k Q cmd \<and>
+    (\<forall>gs. length gs = k \<longrightarrow>
+      ((\<forall>i<k. gs ! i < G) \<longrightarrow> (\<forall>i<k. fst (snd (cmd gs) ! i) < G)) \<and>
+       (k > 0 \<longrightarrow> fst (snd (cmd gs) ! 0) = gs ! 0))"
+
+text \<open>
+A \emph{Turing machine} is a machine with at least two tapes and four symbols
+and only Turing commands.
+\<close>
+
+definition turing_machine :: "nat \<Rightarrow> nat \<Rightarrow> machine \<Rightarrow> bool" where
+  "turing_machine k G M \<equiv> k \<ge> 2 \<and> G \<ge> 4 \<and> (\<forall>cmd\<in>set M. turing_command k (length M) G cmd)"
+
+
+subsubsection \<open>Semantics\<close>
+
+text \<open>
+Next we define the semantics of machines. The state and the list of tapes make
+up the \emph{configuration} of a machine. The semantics are given as functions
+mapping configurations to follow-up configurations.
+\<close>
+
+type_synonym config = "state \<times> tape list"
+
+text \<open>
+We start with the semantics of a single command. An action affects a tape in the
+following way. For the head movements we imagine the tapes having cell~0 at the
+left and the cell indices growing rightward.
+\<close>
+
+fun act :: "action \<Rightarrow> tape \<Rightarrow> tape" where
+  "act (w, m) tp =
+    ((fst tp)(snd tp:=w),
+     case m of Left \<Rightarrow> snd tp - 1 | Stay \<Rightarrow> snd tp | Right \<Rightarrow> snd tp + 1)"
+
+text \<open>
+Reading symbols from one tape, from all tapes, and from configurations:
+\<close>
+
+abbreviation tape_read :: "tape \<Rightarrow> symbol" ("|.|") where
+  "|.| tp \<equiv> fst tp (snd tp)"
+
+definition read :: "tape list \<Rightarrow> symbol list" where
+  "read tps \<equiv> map tape_read tps"
+
+abbreviation config_read :: "config \<Rightarrow> symbol list" where
+  "config_read cfg \<equiv> read (snd cfg)"
+
+text \<open>
+The semantics of a command:
+\<close>
+
+definition sem :: "command \<Rightarrow> config \<Rightarrow> config" where
+  "sem cmd cfg \<equiv>
+    let (newstate, actions) = cmd (config_read cfg)
+    in (newstate, map (\<lambda>(a, tp). act a tp) (zip actions (snd cfg)))"
+
+text \<open>
+The semantics of one step of a machine consist in the semantics of the command
+corresponding to the state the machine is in. The following definition ensures
+that the configuration does not change when it is in a halting state.
+\<close>
+
+definition exe :: "machine \<Rightarrow> config \<Rightarrow> config" where
+  "exe M cfg \<equiv> if fst cfg < length M then sem (M ! (fst cfg)) cfg else cfg"
+
+text \<open>
+Executing a machine $M$ for multiple steps:
+\<close>
+
+fun execute :: "machine \<Rightarrow> config \<Rightarrow> nat \<Rightarrow> config" where
+  "execute M cfg 0 = cfg" |
+  "execute M cfg (Suc t) = exe M (execute M cfg t)"
+
+text \<open>
+We have defined the semantics for arbitrary machines, but most lemmas we are
+going to prove about @{const exe}, @{const execute}, etc.\ will require the
+commands to be somewhat well-behaved, more precisely to map lists of $k$ symbols
+to lists of $k$ actions, as shown in (\ref{eq:proper}). We will call such
+commands \emph{proper}.  \<close>
+
+abbreviation proper_command :: "nat \<Rightarrow> command \<Rightarrow> bool" where
+  "proper_command k cmd \<equiv> \<forall>gs. length gs = k \<longrightarrow> length (snd (cmd gs)) = length gs"
+
+text \<open>
+Being proper is a weaker condition than being well-formed. Since @{const exe}
+treats the state $Q$ and the states $q > Q$ the same, we do not need the
+$Q$-closure property of well-formedness for most lemmas about semantics.
+\<close>
+
+text \<open>
+Next we introduce a number of abbreviations for components of a machine and
+aspects of its behavior. In general, symbols between bars $|\cdot|$ represent
+operations on tapes, inside angle brackets $<\cdot>$ operations on
+configurations, between colons $:\!\cdot\!:$ operations on lists of tapes, and
+inside brackets $[\cdot]$ operations on state/action-list pairs. As for the
+symbol inside the delimiters, a dot ($.$) refers to a tape symbol, a colon ($:$)
+to the entire tape contents, and a hash ($\#$) to a head position; an equals
+sign ($=$) means some component of the left-hand side is changed. An exclamation
+mark ($!$) accesses an element in a list on the left-hand side term.
+
+\null
+\<close>
+
+abbreviation config_length :: "config \<Rightarrow> nat"  ("||_||") where
+  "config_length cfg \<equiv> length (snd cfg)"
+
+abbreviation tape_move_right :: "tape \<Rightarrow> nat \<Rightarrow> tape" (infixl "|+|" 60) where
+  "tp |+| n \<equiv> (fst tp, snd tp + n)"
+
+abbreviation tape_move_left :: "tape \<Rightarrow> nat \<Rightarrow> tape" (infixl "|-|" 60) where
+  "tp |-| n \<equiv> (fst tp, snd tp - n)"
+
+abbreviation tape_move_to :: "tape \<Rightarrow> nat \<Rightarrow> tape" (infixl "|#=|" 60) where
+  "tp |#=| n \<equiv> (fst tp, n)"
+
+abbreviation tape_write :: "tape \<Rightarrow> symbol \<Rightarrow> tape" (infixl "|:=|" 60) where
+  "tp |:=| h \<equiv> ((fst tp) (snd tp := h), snd tp)"
+
+abbreviation config_tape_by_no :: "config \<Rightarrow> nat \<Rightarrow> tape" (infix "<!>" 90) where
+  "cfg <!> j \<equiv> snd cfg ! j"
+
+abbreviation config_contents_by_no :: "config \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> symbol)" (infix "<:>" 100) where
+  "cfg <:> j \<equiv> fst (cfg <!> j)"
+
+abbreviation config_pos_by_no :: "config \<Rightarrow> nat \<Rightarrow> nat" (infix "<#>" 100) where
+  "cfg <#> j \<equiv> snd (cfg <!> j)"
+
+abbreviation config_symbol_read :: "config \<Rightarrow> nat \<Rightarrow> symbol" (infix "<.>" 100) where
+  "cfg <.> j \<equiv> (cfg <:> j) (cfg <#> j)"
+
+abbreviation config_update_state :: "config \<Rightarrow> nat \<Rightarrow> config" (infix "<+=>" 90) where
+  "cfg <+=> q \<equiv> (fst cfg + q, snd cfg)"
+
+abbreviation tapes_contents_by_no :: "tape list \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> symbol)" (infix ":::" 100) where
+  "tps ::: j \<equiv> fst (tps ! j)"
+
+abbreviation tapes_pos_by_no :: "tape list \<Rightarrow> nat \<Rightarrow> nat" (infix ":#:" 100) where
+  "tps :#: j \<equiv> snd (tps ! j)"
+
+abbreviation tapes_symbol_read :: "tape list \<Rightarrow> nat \<Rightarrow> symbol" (infix ":.:" 100) where
+  "tps :.: j \<equiv> (tps ::: j) (tps :#: j)"
+
+abbreviation jump_by_no :: "state \<times> action list \<Rightarrow> state" ("[*] _" [90]) where
+  "[*] sas \<equiv> fst sas"
+
+abbreviation actions_of_cmd :: "state \<times> action list \<Rightarrow> action list" ("[!!] _" [100] 100) where
+  "[!!] sas \<equiv> snd sas"
+
+abbreviation action_by_no :: "state \<times> action list \<Rightarrow> nat \<Rightarrow> action" (infix "[!]" 90) where
+  "sas [!] j \<equiv> snd sas ! j"
+
+abbreviation write_by_no :: "state \<times> action list \<Rightarrow> nat \<Rightarrow> symbol" (infix "[.]" 90) where
+  "sas [.] j \<equiv> fst (sas [!] j)"
+
+abbreviation direction_by_no :: "state \<times> action list \<Rightarrow> nat \<Rightarrow> direction" (infix "[~]" 100) where
+  "sas [~] j \<equiv> snd (sas [!] j)"
+
+text \<open>
+Symbol sequences consisting of symbols from an alphabet $G$:
+\<close>
+
+abbreviation symbols_lt :: "nat \<Rightarrow> symbol list \<Rightarrow> bool" where
+  "symbols_lt G rs \<equiv> \<forall>i<length rs. rs ! i < G"
+
+text \<open>
+We will frequently have to show that commands are proper or Turing commands.
+\<close>
+
+lemma turing_commandI [intro]:
+  assumes "\<And>gs. length gs = k \<Longrightarrow> length ([!!] cmd gs) = length gs"
+    and "\<And>gs. length gs = k \<Longrightarrow>  (\<And>i. i < length gs \<Longrightarrow> gs ! i < G) \<Longrightarrow> (\<And>j. j < length gs \<Longrightarrow> cmd gs [.] j < G)"
+    and "\<And>gs. length gs = k \<Longrightarrow> k > 0 \<Longrightarrow> cmd gs [.] 0 = gs ! 0"
+    and "\<And>gs. length gs = k \<Longrightarrow> [*] (cmd gs) \<le> Q"
+  shows "turing_command k Q G cmd"
+  using assms turing_command_def wf_command_def by simp
+
+lemma turing_commandD:
+  assumes "turing_command k Q G cmd" and "length gs = k"
+  shows "length ([!!] cmd gs) = length gs"
+    and "(\<And>i. i < length gs \<Longrightarrow> gs ! i < G) \<Longrightarrow> (\<And>j. j < length gs \<Longrightarrow> cmd gs [.] j < G)"
+    and "k > 0 \<Longrightarrow> cmd gs [.] 0 = gs ! 0"
+    and "\<And>gs. length gs = k \<Longrightarrow> [*] (cmd gs) \<le> Q"
+  using assms turing_command_def wf_command_def by simp_all
+
+lemma turing_command_mono:
+  assumes "turing_command k Q G cmd" and "Q \<le> Q'"
+  shows "turing_command k Q' G cmd"
+  using turing_command_def wf_command_def assms by auto
+
+lemma proper_command_length:
+  assumes "proper_command k cmd" and "length gs = k"
+  shows "length ([!!] cmd gs) = length gs"
+  using assms by simp
+
+abbreviation proper_machine :: "nat \<Rightarrow> machine \<Rightarrow> bool" where
+  "proper_machine k M \<equiv> \<forall>i<length M. proper_command k (M ! i)"
+
+lemma prop_list_append:
+  assumes "\<forall>i<length M1. P (M1 ! i)"
+    and "\<forall>i<length M2. P (M2 ! i)"
+  shows "\<forall>i<length (M1 @ M2). P ((M1 @ M2) ! i)"
+  using assms by (simp add: nth_append)
+
+text \<open>
+The empty Turing machine $[]$ is the one Turing machine where the start state is
+the halting state, that is, $q_\mathit{start} = q_\mathit{halt} = Q = 0$. It is
+a Turing machine for every $k \geq 2$ and $G \geq 4$:
+\<close>
+
+lemma Nil_tm: "G \<ge> 4 \<Longrightarrow> k \<ge> 2 \<Longrightarrow> turing_machine k G []"
+  using turing_machine_def by simp
+
+lemma turing_machineI [intro]:
+  assumes "k \<ge> 2"
+    and "G \<ge> 4"
+    and "\<And>i. i < length M \<Longrightarrow> turing_command k (length M) G (M ! i)"
+  shows "turing_machine k G M"
+  unfolding turing_machine_def using assms by (metis in_set_conv_nth)
+
+lemma turing_machineD:
+  assumes "turing_machine k G M"
+  shows "k \<ge> 2"
+    and "G \<ge> 4"
+    and "\<And>i. i < length M \<Longrightarrow> turing_command k (length M) G (M ! i)"
+  using turing_machine_def assms by simp_all
+
+text \<open>
+A few lemmas about @{const act}, @{const read}, and @{const sem}:
+
+\null
+\<close>
+
+lemma act: "act a tp =
+  ((fst tp)(snd tp := fst a),
+   case snd a of Left \<Rightarrow> snd tp - 1 | Stay \<Rightarrow> snd tp | Right \<Rightarrow> snd tp + 1)"
+  by (metis act.simps prod.collapse)
+
+lemma act_Stay: "j < length tps \<Longrightarrow> act (read tps ! j, Stay) (tps ! j) = tps ! j"
+  by (simp add: read_def)
+
+lemma act_Right: "j < length tps \<Longrightarrow> act (read tps ! j, Right) (tps ! j) = tps ! j |+| 1"
+  by (simp add: read_def)
+
+lemma act_Left: "j < length tps \<Longrightarrow> act (read tps ! j, Left) (tps ! j) = tps ! j |-| 1"
+  by (simp add: read_def)
+
+lemma act_Stay': "act (h, Stay) (tps ! j) = tps ! j |:=| h"
+  by simp
+
+lemma act_Right': "act (h, Right) (tps ! j) = tps ! j |:=| h |+| 1"
+  by simp
+
+lemma act_Left': "act (h, Left) (tps ! j) = tps ! j |:=| h |-| 1"
+  by simp
+
+lemma act_pos_le_Suc: "snd (act a (tps ! j)) \<le> Suc (snd (tps ! j))"
+proof -
+  obtain w m where "a = (w, m)"
+    by fastforce
+  then show "snd (act a (tps ! j)) \<le> Suc (snd (tps ! j))"
+    using act_Left' act_Stay' act_Right' by (cases m) simp_all
+qed
+
+lemma act_changes_at_most_pos:
+  assumes "i \<noteq> snd tp"
+  shows "fst (act (h, mv) tp) i = fst tp i"
+  by (simp add: assms)
+
+lemma act_changes_at_most_pos':
+  assumes "i \<noteq> snd tp"
+  shows "fst (act a tp) i = fst tp i"
+  by (simp add: assms act)
+
+lemma read_length: "length (read tps) = length tps"
+  using read_def by simp
+
+lemma tapes_at_read: "j < length tps \<Longrightarrow> (q, tps) <.> j = read tps ! j"
+  unfolding read_def by simp
+
+lemma tapes_at_read': "j < length tps \<Longrightarrow> tps :.: j = read tps ! j"
+  unfolding read_def by simp
+
+lemma read_abbrev: "j < ||cfg|| \<Longrightarrow> read (snd cfg) ! j = cfg <.> j"
+  unfolding read_def by simp
+
+lemma sem:
+  "sem cmd cfg =
+    (let rs = read (snd cfg)
+     in (fst (cmd rs), map (\<lambda>(a, tp). act a tp) (zip (snd (cmd rs)) (snd cfg))))"
+  using sem_def read_def by (metis (no_types, lifting) case_prod_beta)
+
+lemma sem':
+  "sem cmd cfg =
+    (fst (cmd (read (snd cfg))), map (\<lambda>(a, tp). act a tp) (zip (snd (cmd (read (snd cfg)))) (snd cfg)))"
+  using sem_def read_def by (metis (no_types, lifting) case_prod_beta)
+
+lemma sem'':
+  "sem cmd (q, tps) =
+    (fst (cmd (read tps)), map (\<lambda>(a, tp). act a tp) (zip (snd (cmd (read tps))) tps))"
+  using sem' by simp
+
+lemma sem_num_tapes_raw: "proper_command k cmd \<Longrightarrow> k = ||cfg|| \<Longrightarrow> k = ||sem cmd cfg||"
+  using sem_def read_length by (simp add: case_prod_beta)
+
+lemma sem_num_tapes2: "turing_command k Q G cmd \<Longrightarrow> k = ||cfg|| \<Longrightarrow> k = ||sem cmd cfg||"
+  using sem_num_tapes_raw turing_commandD(1) by simp
+
+corollary sem_num_tapes2': "turing_command ||cfg|| Q G cmd \<Longrightarrow> ||cfg|| = ||sem cmd cfg||"
+  using sem_num_tapes2 by simp
+
+corollary sem_num_tapes3: "turing_command ||cfg|| Q G cmd \<Longrightarrow> ||cfg|| = ||sem cmd cfg||"
+  by (simp add: turing_commandD(1) sem_num_tapes_raw)
+
+lemma sem_fst:
+  assumes "cfg' = sem cmd cfg" and "rs = read (snd cfg)"
+  shows "fst cfg' = fst (cmd rs)"
+  using sem by (metis (no_types, lifting) assms(1) assms(2) fstI)
+
+lemma sem_snd:
+  assumes "proper_command k cmd"
+    and "||cfg|| = k"
+    and "rs = read (snd cfg)"
+    and "j < k"
+  shows "sem cmd cfg <!> j = act (snd (cmd rs) ! j) (snd cfg ! j)"
+  using assms sem' read_length by simp
+
+lemma snd_semI:
+  assumes "proper_command k cmd"
+    and "length tps = k"
+    and "length tps' = k"
+    and "\<And>j. j < k \<Longrightarrow> act (cmd (read tps) [!] j) (tps ! j) = tps' ! j"
+  shows "snd (sem cmd (q, tps)) = snd (q', tps')"
+  using assms sem_snd[OF assms(1)] sem_num_tapes_raw by (metis nth_equalityI snd_conv)
+
+lemma sem_snd_tm:
+  assumes "turing_machine k G M"
+    and "length tps = k"
+    and "rs = read tps"
+    and "j < k"
+    and "q < length M"
+  shows "sem (M ! q) (q, tps) <!> j = act (snd ((M ! q) rs) ! j) (tps ! j)"
+  using assms sem_snd turing_machine_def turing_commandD(1) by (metis nth_mem snd_conv)
+
+lemma semI:
+  assumes "proper_command k cmd"
+    and "length tps = k"
+    and "length tps' = k"
+    and "fst (cmd (read tps)) = q'"
+    and "\<And>j. j < k \<Longrightarrow> act (cmd (read tps) [!] j) (tps ! j) = tps' ! j"
+  shows "sem cmd (q, tps) = (q', tps')"
+  using snd_semI[OF assms(1,2,3)] assms(4,5) sem_fst by (metis prod.exhaust_sel snd_conv)
+
+text \<open>
+Commands ignore the state element of the configuration they are applied to.
+\<close>
+
+lemma sem_state_indep:
+  assumes "snd cfg1 = snd cfg2"
+  shows "sem cmd cfg1 = sem cmd cfg2"
+  using sem_def assms by simp
+
+text \<open>
+A few lemmas about @{const exe} and @{const execute}:
+\<close>
+
+lemma exe_lt_length: "fst cfg < length M \<Longrightarrow> exe M cfg = sem (M ! (fst cfg)) cfg"
+  using exe_def by simp
+
+lemma exe_ge_length: "fst cfg \<ge> length M \<Longrightarrow> exe M cfg = cfg"
+  using exe_def by simp
+
+lemma exe_num_tapes:
+  assumes "turing_machine k G M" and "k = ||cfg||"
+  shows "k = ||exe M cfg||"
+  using assms sem_num_tapes2 turing_machine_def exe_def by (metis nth_mem)
+
+lemma exe_num_tapes_proper:
+  assumes "proper_machine k M" and "k = ||cfg||"
+  shows "k = ||exe M cfg||"
+  using assms sem_num_tapes_raw turing_machine_def exe_def by metis
+
+lemma execute_num_tapes_proper:
+  assumes "proper_machine k M" and "k = ||cfg||"
+  shows "k = ||execute M cfg t||"
+  using exe_num_tapes_proper assms by (induction t) simp_all
+
+lemma execute_num_tapes:
+  assumes "turing_machine k G M" and "k = ||cfg||"
+  shows "k = ||execute M cfg t||"
+  using exe_num_tapes assms by (induction t) simp_all
+
+lemma execute_after_halting:
+  assumes "fst (execute M cfg0 t) = length M"
+  shows "execute M cfg0 (t + n) = execute M cfg0 t"
+  by (induction n) (simp_all add: assms exe_def)
+
+lemma execute_after_halting':
+  assumes "fst (execute M cfg0 t) \<ge> length M"
+  shows "execute M cfg0 (t + n) = execute M cfg0 t"
+  by (induction n) (simp_all add: assms exe_ge_length)
+
+corollary execute_after_halting_ge:
+  assumes "fst (execute M cfg0 t) = length M" and "t \<le> t'"
+  shows "execute M cfg0 t' = execute M cfg0 t"
+  using execute_after_halting assms le_Suc_ex by blast
+
+corollary execute_after_halting_ge':
+  assumes "fst (execute M cfg0 t) \<ge> length M" and "t \<le> t'"
+  shows "execute M cfg0 t' = execute M cfg0 t"
+  using execute_after_halting' assms le_Suc_ex by blast
+
+lemma execute_additive:
+  assumes "execute M cfg1 t1 = cfg2" and "execute M cfg2 t2 = cfg3"
+  shows "execute M cfg1 (t1 + t2) = cfg3"
+  using assms by (induction t2 arbitrary: cfg3) simp_all
+
+lemma turing_machine_execute_states:
+  assumes "turing_machine k G M" and "fst cfg \<le> length M" and "||cfg|| = k"
+  shows "fst (execute M cfg t) \<le> length M"
+proof (induction t)
+  case 0
+  then show ?case
+    by (simp add: assms(2))
+next
+  case (Suc t)
+  then show ?case
+    using turing_command_def assms(1,3) exe_def execute.simps(2) execute_num_tapes sem_fst
+      turing_machine_def wf_command_def read_length
+    by (smt (verit, best) nth_mem)
+qed
+
+text \<open>
+While running times are important, usually upper bounds for them suffice. The
+next predicate expresses that a machine \emph{transits} from one configuration
+to another one in at most a certain number of steps.
+\<close>
+
+definition transits :: "machine \<Rightarrow> config \<Rightarrow> nat \<Rightarrow> config \<Rightarrow> bool" where
+  "transits M cfg1 t cfg2 \<equiv> \<exists>t'\<le>t. execute M cfg1 t' = cfg2"
+
+lemma transits_monotone:
+  assumes "t \<le> t'" and "transits M cfg1 t cfg2"
+  shows "transits M cfg1 t' cfg2"
+  using assms dual_order.trans transits_def by auto
+
+lemma transits_additive:
+  assumes "transits M cfg1 t1 cfg2" and "transits M cfg2 t2 cfg3"
+  shows "transits M cfg1 (t1 + t2) cfg3"
+proof-
+  from assms(1) obtain t1' where 1: "t1' \<le> t1" "execute M cfg1 t1' = cfg2"
+    using transits_def by auto
+  from assms(2) obtain t2' where 2: "t2' \<le> t2" "execute M cfg2 t2' = cfg3"
+    using transits_def by auto
+  then have "execute M cfg1 (t1' + t2') = cfg3"
+    using execute_additive 1 by simp
+  moreover have "t1' + t2' \<le> t1 + t2"
+    using "1"(1) "2"(1) by simp
+  ultimately show ?thesis
+    using transits_def "1"(2) "2"(2) by auto
+qed
+
+lemma transitsI:
+  assumes "execute M cfg1 t' = cfg2" and "t' \<le> t"
+  shows "transits M cfg1 t cfg2"
+  unfolding transits_def using assms by auto
+
+lemma execute_imp_transits:
+  assumes "execute M cfg1 t = cfg2"
+  shows "transits M cfg1 t cfg2"
+  unfolding transits_def using assms by auto
+
+text \<open>
+In the vast majority of cases we are only interested in transitions from the
+start state to the halting state. One way to look at it is the machine
+\emph{transforms} a list of tapes to another list of tapes within a certain
+number of steps.
+\<close>
+
+definition transforms :: "machine \<Rightarrow> tape list \<Rightarrow> nat \<Rightarrow> tape list \<Rightarrow> bool" where
+  "transforms M tps t tps' \<equiv> transits M (0, tps) t (length M, tps')"
+
+text \<open>
+The previous predicate will be the standard way in which we express the
+behavior of a (Turing) machine. Consider, for example, the empty machine:
+\<close>
+
+lemma transforms_Nil: "transforms [] tps 0 tps"
+  using transforms_def transits_def by simp
+
+lemma transforms_monotone:
+  assumes "transforms M tps t tps'" and "t \<le> t'"
+  shows "transforms M tps t' tps'"
+  using assms transforms_def transits_monotone by simp
+
+text \<open>
+Most often the tapes will have a start symbol in the first cell followed by
+a finite sequence of symbols.
+\<close>
+
+definition contents :: "symbol list \<Rightarrow> (nat \<Rightarrow> symbol)" ("\<lfloor>_\<rfloor>") where
+  "\<lfloor>xs\<rfloor> i \<equiv> if i = 0 then \<triangleright> else if i \<le> length xs then xs ! (i - 1) else \<box>"
+
+lemma contents_at_0 [simp]: "\<lfloor>zs\<rfloor> 0 = \<triangleright>"
+  using contents_def by simp
+
+lemma contents_inbounds [simp]: "i > 0 \<Longrightarrow> i \<le> length zs \<Longrightarrow> \<lfloor>zs\<rfloor> i = zs ! (i - 1)"
+  using contents_def by simp
+
+lemma contents_outofbounds [simp]: "i > length zs \<Longrightarrow> \<lfloor>zs\<rfloor> i = \<box>"
+  using contents_def by simp
+
+text \<open>
+When Turing machines are used to compute functions, they are started in a
+specific configuration where all tapes have the format just defined and the
+first tape contains the input. This is called the \emph{start
+configuration}~\cite[p.~13]{ccama}.
+\<close>
+
+definition start_config :: "nat \<Rightarrow> symbol list \<Rightarrow> config" where
+  "start_config k xs \<equiv> (0, (\<lfloor>xs\<rfloor>, 0) # replicate (k - 1) (\<lfloor>[]\<rfloor>, 0))"
+
+lemma start_config_length: "k > 0 \<Longrightarrow> ||start_config k xs|| = k"
+  using start_config_def contents_def by simp
+
+lemma start_config1:
+  assumes "cfg = start_config k xs" and "0 < j" and "j < k" and "i > 0"
+  shows "(cfg <:> j) i = \<box>"
+  using start_config_def contents_def assms by simp
+
+lemma start_config2:
+  assumes "cfg = start_config k xs" and "j < k"
+  shows "(cfg <:> j) 0  = \<triangleright>"
+  using start_config_def contents_def assms by (cases "0 = j") simp_all
+
+lemma start_config3:
+  assumes "cfg = start_config k xs" and "i > 0" and "i \<le> length xs"
+  shows "(cfg <:> 0) i = xs ! (i - 1)"
+  using start_config_def contents_def assms by simp
+
+lemma start_config4:
+  assumes "0 < j" and "j < k"
+  shows "snd (start_config k xs) ! j = (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)"
+  using start_config_def contents_def assms by auto
+
+lemma start_config_pos: "j < k \<Longrightarrow> start_config k zs <#> j = 0"
+  using start_config_def by (simp add: nth_Cons')
+
+text \<open>
+We call a symbol \emph{proper} if it is neither the blank symbol nor the
+start symbol.
+\<close>
+
+abbreviation proper_symbols :: "symbol list \<Rightarrow> bool" where
+  "proper_symbols xs \<equiv> \<forall>i<length xs. xs ! i > Suc 0"
+
+lemma proper_symbols_append:
+  assumes "proper_symbols xs" and "proper_symbols ys"
+  shows "proper_symbols (xs @ ys)"
+  using assms prop_list_append by (simp add: nth_append)
+
+lemma proper_symbols_ne0: "proper_symbols xs \<Longrightarrow> \<forall>i<length xs. xs ! i \<noteq> \<box>"
+  by auto
+
+lemma proper_symbols_ne1: "proper_symbols xs \<Longrightarrow> \<forall>i<length xs. xs ! i \<noteq> \<triangleright>"
+  by auto
+
+text \<open>
+We call the symbols \textbf{0} and \textbf{1} \emph{bit symbols}.
+\<close>
+
+abbreviation bit_symbols :: "nat list \<Rightarrow> bool" where
+  "bit_symbols xs \<equiv> \<forall>i<length xs. xs ! i = \<zero> \<or> xs ! i = \<one>"
+
+lemma bit_symbols_append:
+  assumes "bit_symbols xs" and "bit_symbols ys"
+  shows "bit_symbols (xs @ ys)"
+  using assms prop_list_append by (simp add: nth_append)
+
+
+subsubsection \<open>Basic facts about Turing machines\<close>
+
+text \<open>
+A Turing machine with alphabet $G$ started on a symbol sequence over $G$ will
+only ever have symbols from $G$ on any of its tapes.
+\<close>
+
+lemma tape_alphabet:
+  assumes "turing_machine k G M" and "symbols_lt G zs" and "j < k"
+  shows "((execute M (start_config k zs) t) <:> j) i < G"
+  using assms(3)
+proof (induction t arbitrary: i j)
+  case 0
+  have "G \<ge> 2"
+    using turing_machine_def assms(1) by simp
+  then show ?case
+    using start_config_def contents_def 0 assms(2) start_config1 start_config2
+    by (smt One_nat_def Suc_1 Suc_lessD Suc_pred execute.simps(1)
+      fst_conv lessI nat_less_le neq0_conv nth_Cons_0 snd_conv)
+next
+  case (Suc t)
+  let ?cfg = "execute M (start_config k zs) t"
+  have *: "execute M (start_config k zs) (Suc t) = exe M ?cfg"
+    by simp
+  show ?case
+  proof (cases "fst ?cfg \<ge> length M")
+    case True
+    then have "execute M (start_config k zs) (Suc t) = ?cfg"
+      using * exe_def by simp
+    then show ?thesis
+      using Suc by simp
+  next
+    case False
+    then have **: "execute M (start_config k zs) (Suc t) = sem (M ! (fst ?cfg)) ?cfg"
+      using * exe_def by simp
+    let ?rs = "config_read ?cfg"
+    let ?cmd = "M ! (fst ?cfg)"
+    let ?sas = "?cmd ?rs"
+    let ?cfg' = "sem ?cmd ?cfg"
+    have "\<forall>j<length ?rs. ?rs ! j < G"
+      using Suc assms(1) execute_num_tapes start_config_length read_abbrev read_length by auto
+    moreover have len: "length ?rs = k"
+      using assms(1) assms(3) execute_num_tapes start_config_def read_length by auto
+    moreover have 2: "turing_command k (length M) G ?cmd"
+      using assms(1) turing_machine_def False leI by simp
+    ultimately have sas: "\<forall>j<length ?rs. ?sas [.] j < G"
+      using turing_command_def by simp
+    have "?cfg' <!> j = act (?sas [!] j) (?cfg <!> j)"
+      using Suc.prems 2 len read_length sem_snd turing_commandD(1) by metis
+    then have "?cfg' <:> j = (?cfg <:> j)(?cfg <#> j := ?sas [.] j)"
+      using act by simp
+    then have "(?cfg' <:> j) i < G"
+      by (simp add: len Suc sas)
+    then show ?thesis
+      using ** by simp
+  qed
+qed
+
+corollary read_alphabet:
+  assumes "turing_machine k G M" and "symbols_lt G zs"
+  shows "\<forall>i<k. config_read (execute M (start_config k zs) t) ! i < G"
+  using assms tape_alphabet execute_num_tapes start_config_length read_abbrev
+  by simp
+
+corollary read_alphabet':
+  assumes "turing_machine k G M" and "symbols_lt G zs"
+  shows "symbols_lt G (config_read (execute M (start_config k zs) t))"
+  using read_alphabet assms execute_num_tapes start_config_length read_length turing_machine_def
+  by (metis neq0_conv not_numeral_le_zero)
+
+corollary read_alphabet_set:
+  assumes "turing_machine k G M" and "symbols_lt G zs"
+  shows "\<forall>h\<in>set (config_read (execute M (start_config k zs) t)). h < G"
+  using read_alphabet'[OF assms] by (metis in_set_conv_nth)
+
+text \<open>
+The contents of the input tape never change.
+\<close>
+
+lemma input_tape_constant:
+  assumes "turing_machine k G M" and "k = ||cfg||"
+  shows "execute M cfg t <:> 0 = execute M cfg 0 <:> 0"
+proof (induction t)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc t)
+  let ?cfg = "execute M cfg t"
+  have 1: "execute M cfg (Suc t) = exe M ?cfg"
+    by simp
+  have 2: "length (read (snd ?cfg)) = k"
+    using execute_num_tapes assms read_length by simp
+  have k: "k > 0"
+    using assms(1) turing_machine_def by simp
+  show ?case
+  proof (cases "fst ?cfg < length M")
+    case True
+    then have 3: "turing_command k (length M) G (M ! fst ?cfg)"
+      using turing_machine_def assms(1) by simp
+    then have "(M ! fst ?cfg) (read (snd ?cfg)) [.] 0 = read (snd ?cfg) ! 0"
+      using turing_command_def 2 k by auto
+    then have 4: "(M ! fst ?cfg) (read (snd ?cfg)) [.] 0 = ?cfg <.> 0"
+      using 2 k read_abbrev read_length by auto
+    have "execute M cfg (Suc t) <:> 0 = sem (M ! fst ?cfg) ?cfg <:> 0"
+      using True exe_def by simp
+    also have "... = fst (act (((M ! fst ?cfg) (read (snd ?cfg))) [!] 0) (?cfg <!> 0))"
+      using sem_snd 2 3 k read_length turing_commandD(1) by metis
+    also have "... = (?cfg <:> 0) ((?cfg <#> 0):=(((M ! fst ?cfg) (read (snd ?cfg))) [.] 0))"
+      using act by simp
+    also have "... = (?cfg <:> 0) ((?cfg <#> 0):=?cfg <.> 0)"
+      using 4 by simp
+    also have "... = ?cfg <:> 0"
+      by simp
+    finally have "execute M cfg (Suc t) <:> 0 = ?cfg <:> 0" .
+    then show ?thesis
+      using Suc by simp
+  next
+    case False
+    then have "execute M cfg (Suc t) = ?cfg"
+      using exe_def by simp
+    then show ?thesis
+      using Suc by simp
+  qed
+qed
+
+text \<open>
+A head position cannot be greater than the number of steps the machine has been
+running.
+\<close>
+
+lemma head_pos_le_time:
+  assumes "turing_machine k G M" and "j < k"
+  shows "execute M (start_config k zs) t <#> j \<le> t"
+proof (induction t)
+  case 0
+  have "0 < k"
+    using assms(1) turing_machine_def by simp
+  then have "execute M (start_config k zs) 0 <#> j = 0"
+    using start_config_def assms(2) start_config_pos by simp
+  then show ?case
+    by simp
+next
+  case (Suc t)
+  have *: "execute M (start_config k zs) (Suc t) = exe M (execute M (start_config k zs) t)"
+      (is "_ = exe M ?cfg")
+    by simp
+  show ?case
+  proof (cases "fst ?cfg = length M")
+    case True
+    then have "execute M (start_config k zs) (Suc t) = ?cfg"
+      using * exe_def by simp
+    then show ?thesis
+      using Suc by simp
+  next
+    case False
+    then have less: "fst ?cfg < length M"
+      using assms(1) turing_machine_def
+      by (simp add: start_config_def le_neq_implies_less turing_machine_execute_states)
+    then have "exe M ?cfg = sem (M ! (fst ?cfg)) ?cfg"
+      using exe_def by simp
+    moreover have "proper_command k (M ! (fst ?cfg))"
+      using assms(1) turing_commandD(1) less turing_machine_def nth_mem by blast
+    ultimately have "exe M ?cfg <!> j = act (snd ((M ! (fst ?cfg)) (config_read ?cfg)) ! j) (?cfg <!> j)"
+      using assms(1,2) execute_num_tapes start_config_length sem_snd by auto
+    then have "exe M ?cfg <#> j \<le> Suc (?cfg <#> j)"
+      using act_pos_le_Suc assms(1,2) execute_num_tapes start_config_length by auto
+    then show ?thesis
+      using * Suc.IH by simp
+  qed
+qed
+
+lemma head_pos_le_halting_time:
+  assumes "turing_machine k G M"
+    and "fst (execute M (start_config k zs) T) = length M"
+    and "j < k"
+  shows "execute M (start_config k zs) t <#> j \<le> T"
+  using assms execute_after_halting_ge[OF assms(2)] head_pos_le_time[OF assms(1,3)]
+  by (metis nat_le_linear order_trans)
+
+text \<open>
+A tape cannot contain non-blank symbols at a position larger than the number of
+steps the Turing machine has been running, except on the input tape.
+\<close>
+
+lemma blank_after_time:
+  assumes "i > t" and "j < k" and "0 < j" and "turing_machine k G M"
+  shows "(execute M (start_config k zs) t <:> j) i = \<box>"
+  using assms(1)
+proof (induction t)
+  case 0
+  have "execute M (start_config k zs) 0 = start_config k zs"
+    by simp
+  then show ?case
+    using start_config1 assms turing_machine_def by simp
+next
+  case (Suc t)
+  have "k \<ge> 2"
+    using assms(2,3) by simp
+  let ?icfg = "start_config k zs"
+  have *: "execute M ?icfg (Suc t) = exe M (execute M ?icfg t)"
+    by simp
+  show ?case
+  proof (cases "fst (execute M ?icfg t) \<ge> length M")
+    case True
+    then have "execute M ?icfg (Suc t) = execute M ?icfg t"
+      using * exe_def by simp
+    then show ?thesis
+      using Suc by simp
+  next
+    case False
+    then have "execute M ?icfg (Suc t) <:> j = sem (M ! (fst (execute M ?icfg t))) (execute M ?icfg t) <:> j"
+        (is "_ = sem ?cmd ?cfg <:> j")
+      using exe_lt_length * by simp
+    also have "... = fst (map (\<lambda>(a, tp). act a tp) (zip (snd (?cmd (read (snd ?cfg)))) (snd ?cfg)) ! j)"
+      using sem' by simp
+    also have "... = fst (act (snd (?cmd (read (snd ?cfg))) ! j) (snd ?cfg ! j))"
+      (is "_ = fst (act ?h (snd ?cfg ! j))")
+    proof -
+      have "||?cfg|| = k"
+        using assms(2) execute_num_tapes[OF assms(4)] start_config_length turing_machine_def
+        by simp
+      moreover have "length (snd (?cmd (read (snd ?cfg)))) = k"
+        using assms(4) execute_num_tapes[OF assms(4)] start_config_length turing_machine_def
+          read_length False turing_command_def wf_command_def
+        by simp
+      ultimately show ?thesis
+        using assms by simp
+    qed
+    finally have "execute M ?icfg (Suc t) <:> j = fst (act ?h (snd ?cfg ! j))" .
+    moreover have "i \<noteq> ?cfg <#> j"
+      using head_pos_le_time[OF assms(4,2)] Suc Suc_lessD leD by blast
+    ultimately have "(execute M ?icfg (Suc t) <:> j) i = fst (?cfg <!> j) i"
+      using act_changes_at_most_pos by (metis prod.collapse)
+    then show ?thesis
+      using Suc Suc_lessD by presburger
+  qed
+qed
+
+
+subsection \<open>Computing a function\label{s:tm-basic-comp}\<close>
+
+text \<open>
+Turing machines are supposed to compute functions. The functions in question map
+bit strings to bit strings. We model such strings as lists of Booleans and
+denote the bits by @{text \<bbbO>} and @{text \<bbbI>}.
+\<close>
+
+type_synonym string = "bool list"
+
+notation False ("\<bbbO>") and True ("\<bbbI>")
+
+text \<open>
+This keeps the more abstract level of computable functions separate from the
+level of concrete implementations as Turing machines, which can use an arbitrary
+alphabet. We use the term ``string'' only for bit strings, on which functions
+operate, and the terms ``symbol sequence'' or ``symbols'' for the things written
+on the tapes of Turing machines. We translate between the two levels in a
+straightforward way:
+\<close>
+
+abbreviation string_to_symbols :: "string \<Rightarrow> symbol list" where
+  "string_to_symbols x \<equiv> map (\<lambda>b. if b then \<one> else \<zero>) x"
+
+abbreviation symbols_to_string :: "symbol list \<Rightarrow> string" where
+  "symbols_to_string zs \<equiv> map (\<lambda>z. z = \<one>) zs"
+
+proposition
+  "string_to_symbols [\<bbbO>, \<bbbI>] = [\<zero>, \<one>]"
+  "symbols_to_string [\<zero>, \<one>] = [\<bbbO>, \<bbbI>]"
+  by simp_all
+
+lemma bit_symbols_to_symbols:
+  assumes "bit_symbols zs"
+  shows "string_to_symbols (symbols_to_string zs) = zs"
+  using assms by (intro nth_equalityI) auto
+
+lemma symbols_to_string_to_symbols: "symbols_to_string (string_to_symbols x) = x"
+  by (intro nth_equalityI) simp_all
+
+lemma proper_symbols_to_symbols: "proper_symbols (string_to_symbols zs)"
+  by simp
+
+abbreviation string_to_contents :: "string \<Rightarrow> (nat \<Rightarrow> symbol)" where
+  "string_to_contents x \<equiv>
+    \<lambda>i. if i = 0 then \<triangleright> else if i \<le> length x then (if x ! (i - 1) then \<one> else \<zero>) else \<box>"
+
+lemma contents_string_to_contents: "string_to_contents xs = \<lfloor>string_to_symbols xs\<rfloor>"
+  using contents_def by auto
+
+lemma bit_symbols_to_contents:
+  assumes "bit_symbols ns"
+  shows "\<lfloor>ns\<rfloor> = string_to_contents (symbols_to_string ns)"
+  using assms bit_symbols_to_symbols contents_string_to_contents by simp
+
+text \<open>
+Definition~1.3 in the textbook~\cite{ccama} says that for a Turing machine $M$
+to compute a function $f\colon\bbOI^*\to\bbOI^*$ on input $x$, ``it halts with
+$f(x)$ written on its output tape.'' My initial interpretation of this phrase,
+and the one formalized below, was that the output is written \emph{after} the
+start symbol $\triangleright$ in the same fashion as the input is given on the
+input tape. However after inspecting the Turing machine in Example~1.1, I now
+believe the more likely meaning is that the output \emph{overwrites} the start
+symbol, although Example~1.1 precedes Definition~1.3 and might not be subject to
+it.
+
+One advantage of the interpretation with start symbol intact is that the output
+tape can then be used unchanged as the input of another Turing machine, a
+property we exploit in Section~\ref{s:tm-composing}. Otherwise one would have to
+find the start cell of the output tape and either copy the contents to another
+tape with start symbol or shift the string to the right and restore the start
+symbol.  One way to find the start cell is to move the tape head left while
+``marking'' the cells until one reaches an already marked cell, which can only
+happen when the head is in the start cell, where ``moving left'' does not
+actually move the head. This process will take time linear in the length of the
+output and thus will not change the asymptotic running time of the machine.
+Therefore the choice of interpretation is purely one of convenience.
+
+\null
+\<close>
+
+definition halts :: "machine \<Rightarrow> config \<Rightarrow> bool" where
+  "halts M cfg \<equiv> \<exists>t. fst (execute M cfg t) = length M"
+
+lemma halts_impl_le_length:
+  assumes "halts M cfg"
+  shows "fst (execute M cfg t) \<le> length M"
+  using assms execute_after_halting_ge' halts_def by (metis linear)
+
+definition running_time :: "machine \<Rightarrow> config \<Rightarrow> nat" where
+  "running_time M cfg \<equiv> LEAST t. fst (execute M cfg t) = length M"
+
+lemma running_timeD:
+  assumes "running_time M cfg = t" and "halts M cfg"
+  shows "fst (execute M cfg t) = length M"
+    and "\<And>t'. t' < t \<Longrightarrow> fst (execute M cfg t') \<noteq> length M"
+  using assms running_time_def halts_def
+    not_less_Least[of _ "\<lambda>t. fst (execute M cfg t) = length M"]
+    LeastI[of "\<lambda>t. fst (execute M cfg t) = length M"]
+  by auto
+
+definition halting_config :: "machine \<Rightarrow> config \<Rightarrow> config" where
+  "halting_config M cfg \<equiv> execute M cfg (running_time M cfg)"
+
+abbreviation start_config_string :: "nat \<Rightarrow> string \<Rightarrow> config" where
+  "start_config_string k x \<equiv> start_config k (string_to_symbols x)"
+
+text \<open>
+Another, inconsequential, difference to the textbook definition is that we
+designate the second tape, rather than the last tape, as the output tape. This
+means that the indices for the input and output tape are fixed at~0 and~1,
+respectively, regardless of the total number of tapes. Next is our definition of
+a $k$-tape Turing machine $M$ computing a function $f$ in $T$-time:
+\<close>
+
+definition computes_in_time :: "nat \<Rightarrow> machine \<Rightarrow> (string \<Rightarrow> string) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" where
+  "computes_in_time k M f T \<equiv> \<forall>x.
+    halts M (start_config_string k x) \<and>
+    running_time M (start_config_string k x) \<le> T (length x) \<and>
+    halting_config M (start_config_string k x) <:> 1 = string_to_contents (f x)"
+
+lemma computes_in_time_mono:
+  assumes "computes_in_time k M f T" and "\<And>n. T n \<le> T' n"
+  shows "computes_in_time k M f T'"
+  using assms computes_in_time_def halts_def running_time_def halting_config_def execute_after_halting_ge
+  by (meson dual_order.trans)
+
+text \<open>
+The definition of @{const computes_in_time} can be expressed with @{const
+transforms} as well, which will be more convenient for us.
+\<close>
+
+lemma halting_config_execute:
+  assumes "fst (execute M cfg t) = length M"
+  shows "halting_config M cfg = execute M cfg t"
+proof-
+  have 1: "t \<ge> running_time M cfg"
+    using assms running_time_def by (simp add: Least_le)
+  then have "fst (halting_config M cfg) = length M"
+    using assms LeastI[of "\<lambda>t. fst (execute M cfg t) = length M" t]
+    by (simp add: halting_config_def running_time_def)
+  then show ?thesis
+    using execute_after_halting_ge 1 halting_config_def by metis
+qed
+
+lemma transforms_halting_config:
+  assumes "transforms M tps t tps'"
+  shows "halting_config M (0, tps) = (length M, tps')"
+  using assms transforms_def halting_config_def halting_config_execute transits_def
+  by (metis fst_eqD)
+
+lemma computes_in_time_execute:
+  assumes "computes_in_time k M f T"
+  shows "execute M (start_config_string k x) (T (length x)) <:> 1 = string_to_contents (f x)"
+proof -
+  let ?t = "running_time M (start_config_string k x)"
+  let ?cfg = "start_config_string k x"
+  have "execute M ?cfg ?t = halting_config M ?cfg"
+    using halting_config_def by simp
+  then have "fst (execute M ?cfg ?t) = length M"
+    using assms computes_in_time_def running_timeD(1) by blast
+  moreover have "?t \<le> T (length x)"
+    using computes_in_time_def assms by simp
+  ultimately have "execute M ?cfg ?t = execute M ?cfg (T (length x)) "
+    using execute_after_halting_ge by presburger
+  moreover have "execute M ?cfg ?t <:> 1 = string_to_contents (f x)"
+    using computes_in_time_def halting_config_execute assms halting_config_def by simp
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma transforms_running_time:
+  assumes "transforms M tps t tps'"
+  shows "running_time M (0, tps) \<le> t"
+  using running_time_def transforms_def transits_def
+  by (smt Least_le[of _ t] assms execute_after_halting_ge fst_conv)
+
+text \<open>
+This is the alternative characterization of @{const computes_in_time}:
+\<close>
+
+lemma computes_in_time_alt:
+  "computes_in_time k M f T =
+    (\<forall>x. \<exists>tps.
+      tps ::: 1 = string_to_contents (f x) \<and>
+      transforms M (snd (start_config_string k x)) (T (length x)) tps)"
+  (is "?lhs = ?rhs")
+proof
+  show "?lhs \<Longrightarrow> ?rhs"
+  proof
+    fix x :: string
+    let ?cfg = "start_config_string k x"
+    assume "computes_in_time k M f T"
+    then have
+      1: "halts M ?cfg" and
+      2: "running_time M ?cfg \<le> T (length x)" and
+      3: "halting_config M ?cfg <:> 1 = string_to_contents (f x)"
+      using computes_in_time_def by simp_all
+    define cfg where "cfg = halting_config M ?cfg"
+    then have "transits M ?cfg (T (length x)) cfg"
+      using 2 halting_config_def transits_def by auto
+    then have "transforms M (snd ?cfg) (T (length x)) (snd cfg)"
+      using transits_def transforms_def start_config_def
+      by (metis (no_types, lifting) "1" cfg_def halting_config_def prod.collapse running_timeD(1) snd_conv)
+    moreover have "snd cfg ::: 1 = string_to_contents (f x)"
+      using cfg_def 3 by simp
+    ultimately show "\<exists>tps. tps ::: 1 = string_to_contents (f x) \<and>
+        transforms M (snd (start_config_string k x)) (T (length x)) tps"
+      by auto
+  qed
+  show "?rhs \<Longrightarrow> ?lhs"
+    unfolding computes_in_time_def
+  proof
+    assume rhs: ?rhs
+    fix x :: string
+    let ?cfg = "start_config_string k x"
+    obtain tps where tps:
+      "tps ::: 1 = string_to_contents (f x)"
+      "transforms M (snd ?cfg) (T (length x)) tps"
+      using rhs by auto
+    then have "transits M ?cfg (T (length x)) (length M, tps)"
+      using transforms_def start_config_def by simp
+    then have 1: "halts M ?cfg"
+      using halts_def transits_def by (metis fst_eqD)
+    moreover have 2: "running_time M ?cfg \<le> T (length x)"
+      using tps(2) transforms_running_time start_config_def by simp
+    moreover have 3: "halting_config M ?cfg <:> 1 = string_to_contents (f x)"
+    proof -
+      have "halting_config M ?cfg = (length M, tps)"
+        using transforms_halting_config[OF tps(2)] start_config_def by simp
+      then show ?thesis
+        using tps(1) by simp
+    qed
+    ultimately show "halts M ?cfg \<and> running_time M ?cfg \<le> T (length x) \<and> halting_config M ?cfg <:> 1 = string_to_contents (f x)"
+      by simp
+  qed
+qed
+
+lemma computes_in_timeD:
+  fixes x
+  assumes "computes_in_time k M f T"
+  shows "\<exists>tps. tps ::: 1 = string_to_contents (f x) \<and>
+       transforms M (snd (start_config k (string_to_symbols x))) (T (length x)) tps"
+  using assms computes_in_time_alt by simp
+
+lemma computes_in_timeI [intro]:
+  assumes "\<And>x. \<exists>tps. tps ::: 1 = string_to_contents (f x) \<and>
+      transforms M (snd (start_config k (string_to_symbols x))) (T (length x)) tps"
+  shows "computes_in_time k M f T"
+  using assms computes_in_time_alt by simp
+
+text \<open>
+As an example, the function mapping every string to the empty string is
+computable within any time bound by the empty Turing machine.
+\<close>
+
+lemma computes_Nil_empty:
+  assumes "k \<ge> 2"
+  shows "computes_in_time k [] (\<lambda>x. []) T"
+proof
+  fix x :: string
+  let ?tps = "snd (start_config_string k x)"
+  let ?f = "\<lambda>x. []"
+  have "?tps ::: 1 = string_to_contents (?f x)"
+    using start_config4 assms by auto
+  moreover have "transforms [] ?tps (T (length x)) ?tps"
+    using transforms_Nil transforms_monotone by blast
+  ultimately show "\<exists>tps. tps ::: 1 = string_to_contents (?f x) \<and> transforms [] ?tps (T (length x)) tps"
+    by auto
+qed
+
+
+subsection \<open>Pairing strings\label{s:tm-basic-pair}\<close>
+
+text \<open>
+In order to define the computability of functions with two arguments, we need a
+way to encode a pair of strings as one string. The idea is to write the two
+strings with a separator, for example,
+$\bbbO\bbbI\bbbO\bbbO\#\bbbI\bbbI\bbbI\bbbO$ and then encode every symbol
+$\bbbO, \bbbI, \#$ by two bits from $\bbOI$. We slightly deviate from Arora and
+Barak's encoding~\cite[p.~2]{ccama} and map $\bbbO$ to $\bbbO\bbbO$, $\bbbI$ to
+$\bbbO\bbbI$, and \# to $\bbbI\bbbI$, the idea being that the first bit
+signals whether the second bit is to be taken literally or as a special
+character. Our example turns into
+$\bbbO\bbbO\bbbO\bbbI\bbbO\bbbO\bbbO\bbbO\bbbI\bbbI\bbbO\bbbI\bbbO\bbbI\bbbO\bbbI\bbbO\bbbO$.
+
+\null
+\<close>
+
+abbreviation bitenc :: "string \<Rightarrow> string" where
+  "bitenc x \<equiv> concat (map (\<lambda>h. [\<bbbO>, h]) x)"
+
+definition string_pair :: "string \<Rightarrow> string \<Rightarrow> string" ("\<langle>_, _\<rangle>") where
+  "\<langle>x, y\<rangle> \<equiv> bitenc x @ [\<bbbI>, \<bbbI>] @ bitenc y"
+
+text \<open>
+Our example:
+\<close>
+
+proposition "\<langle>[\<bbbO>, \<bbbI>, \<bbbO>, \<bbbO>], [\<bbbI>, \<bbbI>, \<bbbI>, \<bbbO>]\<rangle> = [\<bbbO>, \<bbbO>, \<bbbO>, \<bbbI>, \<bbbO>, \<bbbO>, \<bbbO>, \<bbbO>, \<bbbI>, \<bbbI>, \<bbbO>, \<bbbI>, \<bbbO>, \<bbbI>, \<bbbO>, \<bbbI>, \<bbbO>, \<bbbO>]"
+  using string_pair_def by simp
+
+lemma length_string_pair: "length \<langle>x, y\<rangle> = 2 * length x + 2 * length y + 2"
+proof -
+  have "length (concat (map (\<lambda>h. [\<bbbO>, h]) z)) = 2 * length z" for z
+    by (induction z) simp_all
+  then show ?thesis
+    using string_pair_def by simp
+qed
+
+lemma length_bitenc: "length (bitenc z) = 2 * length z"
+  by (induction z) simp_all
+
+lemma bitenc_nth:
+  assumes "i < length zs"
+  shows "bitenc zs ! (2 * i) = \<bbbO>"
+    and "bitenc zs ! (2 * i + 1) = zs ! i"
+proof -
+  let ?f = "\<lambda>h. [\<bbbO>, h]"
+  let ?xs = "concat (map ?f zs)"
+
+  have eqtake: "bitenc (take i zs) = take (2 * i) (bitenc zs)"
+      if "i \<le> length zs" for i zs
+  proof -
+    have "take (2 * i) (bitenc zs) = take (2 * i) (bitenc (take i zs @ drop i zs))"
+      by simp
+    then have "take (2 * i) (bitenc zs) = take (2 * i) (bitenc (take i zs) @ (bitenc (drop i zs)))"
+      by (metis concat_append map_append)
+    then show ?thesis
+      using length_bitenc that by simp
+  qed
+
+  have eqdrop: "bitenc (drop i zs) = drop (2 * i) (bitenc zs)"
+      if "i < length zs" for i
+  proof -
+    have "drop (2 * i) (bitenc zs) = drop (2 * i) (bitenc (take i zs @ drop i zs))"
+      by simp
+    then have "drop (2 * i) (bitenc zs) = drop (2 * i) (bitenc (take i zs) @ bitenc (drop i zs))"
+      by (metis concat_append map_append)
+    then show ?thesis
+      using length_bitenc that by simp
+  qed
+
+  have take2: "take 2 (drop (2 * i) (bitenc zs)) = ?f (zs ! i)" if "i < length zs" for i
+  proof -
+    have 1: "1 \<le> length (drop i zs)"
+      using that by simp
+    have "take 2 (drop (2*i) (bitenc zs)) = take 2 (bitenc (drop i zs))"
+      using that eqdrop by simp
+    also have "... = bitenc (take 1 (drop i zs))"
+      using 1 eqtake by simp
+    also have "... = bitenc [zs ! i]"
+      using that by (metis Cons_nth_drop_Suc One_nat_def take0 take_Suc_Cons)
+    also have "... = ?f (zs ! i)"
+      by simp
+    finally show ?thesis .
+  qed
+
+  show "bitenc zs ! (2 * i) = \<bbbO>"
+  proof -
+    have "bitenc zs ! (2 * i) = drop (2 * i) (bitenc zs) ! 0"
+      using assms drop0 length_bitenc by simp
+    also have "... = take 2 (drop (2 * i) (bitenc zs)) ! 0"
+      using eqdrop by simp
+    also have "... = ?f (zs ! i) ! 0"
+      using assms take2 by simp
+    also have "... = \<bbbO>"
+      by simp
+    finally show ?thesis .
+  qed
+
+  show "bitenc zs ! (2*i + 1) = zs ! i"
+  proof -
+    have "bitenc zs ! (2*i+1) = drop (2 * i) (bitenc zs) ! 1"
+      using assms length_bitenc by simp
+    also have "... = take 2 (drop (2*i) (bitenc zs)) ! 1"
+      using eqdrop by simp
+    also have "... = ?f (zs ! i) ! 1"
+      using assms(1) take2 by simp
+    also have "... = zs ! i"
+      by simp
+    finally show ?thesis .
+  qed
+qed
+
+lemma string_pair_first_nth:
+  assumes "i < length x"
+  shows "\<langle>x, y\<rangle> ! (2 * i) = \<bbbO>"
+    and "\<langle>x, y\<rangle> ! (2 * i + 1) = x ! i"
+proof -
+  have "\<langle>x, y\<rangle> ! (2*i) = concat (map (\<lambda>h. [\<bbbO>, h]) x) ! (2*i)"
+    using string_pair_def length_bitenc by (simp add: assms nth_append)
+  then show "\<langle>x, y\<rangle> ! (2 * i) = \<bbbO>"
+    using bitenc_nth(1) assms by simp
+  have "2 * i + 1 < 2 * length x"
+    using assms by simp
+  then have "\<langle>x, y\<rangle> ! (2*i+1) = concat (map (\<lambda>h. [\<bbbO>, h]) x) ! (2*i+1)"
+    using string_pair_def length_bitenc[of x] assms nth_append
+    by force
+  then show "\<langle>x, y\<rangle> ! (2 * i + 1) = x ! i"
+    using bitenc_nth(2) assms by simp
+qed
+
+lemma string_pair_sep_nth:
+  shows "\<langle>x, y\<rangle> ! (2 * length x) = \<bbbI>"
+    and "\<langle>x, y\<rangle> ! (2 * length x + 1) = \<bbbI>"
+  using string_pair_def length_bitenc
+  by (metis append_Cons nth_append_length) (simp add: length_bitenc nth_append string_pair_def)
+
+lemma string_pair_second_nth:
+  assumes "i < length y"
+  shows "\<langle>x, y\<rangle> ! (2 * length x + 2 + 2 * i) = \<bbbO>"
+    and "\<langle>x, y\<rangle> ! (2 * length x + 2 + 2 * i + 1) = y ! i"
+proof -
+  have "\<langle>x, y\<rangle> ! (2 * length x + 2 + 2*i) = concat (map (\<lambda>h. [\<bbbO>, h]) y) ! (2*i)"
+    using string_pair_def length_bitenc by (simp add: assms nth_append)
+  then show "\<langle>x, y\<rangle> ! (2 * length x + 2 + 2 * i) = \<bbbO>"
+    using bitenc_nth(1) assms by simp
+  have "2 * i + 1 < 2 * length y"
+    using assms by simp
+  then have "\<langle>x, y\<rangle> ! (2 * length x + 2 + 2*i+1) = concat (map (\<lambda>h. [\<bbbO>, h]) y) ! (2*i+1)"
+    using string_pair_def length_bitenc[of x] assms nth_append
+    by force
+  then show "\<langle>x, y\<rangle> ! (2 * length x + 2 + 2 * i + 1) = y ! i"
+    using bitenc_nth(2) assms by simp
+qed
+
+lemma string_pair_inj:
+  assumes "\<langle>x1, y1\<rangle> = \<langle>x2, y2\<rangle>"
+  shows "x1 = x2 \<and> y1 = y2"
+proof
+  show "x1 = x2"
+  proof (rule ccontr)
+    assume neq: "x1 \<noteq> x2"
+    consider "length x1 = length x2" | "length x1 < length x2" | "length x1 > length x2"
+      by linarith
+    then show False
+    proof (cases)
+      case 1
+      then obtain i where i: "i < length x1" "x1 ! i \<noteq> x2 ! i"
+        using neq list_eq_iff_nth_eq by blast
+      then have "\<langle>x1, y1\<rangle> ! (2 * i + 1) = x1 ! i" and "\<langle>x2, y2\<rangle> ! (2 * i + 1) = x2 ! i"
+        using 1 string_pair_first_nth by simp_all
+      then show False
+        using assms i(2) by simp
+    next
+      case 2
+      let ?i = "length x1"
+      have "\<langle>x1, y1\<rangle> ! (2 * ?i) = \<bbbI>"
+        using string_pair_sep_nth by simp
+      moreover have "\<langle>x2, y2\<rangle> ! (2 * ?i) = \<bbbO>"
+        using string_pair_first_nth 2 by simp
+      ultimately show False
+        using assms by simp
+    next
+      case 3
+      let ?i = "length x2"
+      have "\<langle>x2, y2\<rangle> ! (2 * ?i) = \<bbbI>"
+        using string_pair_sep_nth by simp
+      moreover have "\<langle>x1, y1\<rangle> ! (2 * ?i) = \<bbbO>"
+        using string_pair_first_nth 3 by simp
+      ultimately show False
+        using assms by simp
+    qed
+  qed
+  then have len_x_eq: "length x1 = length x2"
+    by simp
+  then have len_y_eq: "length y1 = length y2"
+    using assms length_string_pair
+    by (smt (verit) Suc_1 Suc_mult_cancel1 add_left_imp_eq add_right_cancel)
+  show "y1 = y2"
+  proof (rule ccontr)
+    assume neq: "y1 \<noteq> y2"
+    then obtain i where i: "i < length y1" "y1 ! i \<noteq> y2 ! i"
+      using list_eq_iff_nth_eq len_y_eq by blast
+    then have "\<langle>x1, y1\<rangle> ! (2 * length x1 + 2 + 2 * i + 1) = y1 ! i" and
+        "\<langle>x2, y2\<rangle> ! (2 * length x2 + 2 + 2 * i + 1) = y2 ! i"
+      using string_pair_second_nth len_y_eq by simp_all
+    then show False
+      using assms i(2) len_x_eq by simp
+  qed
+qed
+
+text \<open>
+Turing machines have to deal with pairs of symbol sequences rather than strings.
+\<close>
+
+abbreviation pair :: "string \<Rightarrow> string \<Rightarrow> symbol list" ("\<langle>_; _\<rangle>") where
+  "\<langle>x; y\<rangle> \<equiv> string_to_symbols \<langle>x, y\<rangle>"
+
+lemma symbols_lt_pair: "symbols_lt 4 \<langle>x; y\<rangle>"
+  by simp
+
+lemma length_pair: "length \<langle>x; y\<rangle> = 2 * length x + 2 * length y + 2"
+  by (simp add: length_string_pair)
+
+lemma pair_inj:
+  assumes "\<langle>x1; y1\<rangle> = \<langle>x2; y2\<rangle>"
+  shows "x1 = x2 \<and> y1 = y2"
+  using string_pair_inj assms symbols_to_string_to_symbols by metis
+
+
+subsection \<open>Big-Oh and polynomials\label{s:tm-basic-bigoh}\<close>
+
+text \<open>
+The Big-Oh notation is standard~\cite[Definition~0.2]{ccama}. It can be defined
+with $c$ ranging over real or natural numbers. We choose natural numbers for
+simplicity.
+\<close>
+
+definition big_oh :: "(nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" where
+  "big_oh g f \<equiv> \<exists>c m. \<forall>n>m. g n \<le> c * f n"
+
+text \<open>
+Some examples:
+\<close>
+
+proposition "big_oh (\<lambda>n. n) (\<lambda>n. n)"
+  using big_oh_def by auto
+
+proposition "big_oh (\<lambda>n. n) (\<lambda>n. n * n)"
+  using big_oh_def by auto
+
+proposition "big_oh (\<lambda>n. 42 * n) (\<lambda>n. n * n)"
+proof-
+  have "\<forall>n>0::nat. 42 * n \<le> 42 * n * n"
+    by simp
+  then have "\<exists>(c::nat)>0. \<forall>n>0. 42 * n \<le> c * n * n"
+    using zero_less_numeral by blast
+  then show ?thesis
+    using big_oh_def by auto
+qed
+
+proposition "\<not> big_oh (\<lambda>n. n * n) (\<lambda>n. n)" (is "\<not> big_oh ?g ?f")
+proof
+  assume "big_oh (\<lambda>n. n * n) (\<lambda>n. n)"
+  then obtain c m where "\<forall>n>m. ?g n \<le> c * ?f n"
+    using big_oh_def by auto
+  then have 1: "\<forall>n>m. n * n \<le> c * n"
+    by auto
+  define nn where "nn = max (m + 1) (c + 1)"
+  then have 2: "nn > m"
+    by simp
+  then have "nn * nn > c * nn"
+    by (simp add: nn_def max_def)
+  with 1 2 show False
+    using not_le by blast
+qed
+
+text \<open>
+Some lemmas helping with polynomial upper bounds.
+\<close>
+
+lemma pow_mono:
+  fixes n d1 d2 :: nat
+  assumes "d1 \<le> d2" and "n > 0"
+  shows "n ^ d1 \<le> n ^ d2"
+  using assms by (simp add: Suc_leI power_increasing)
+
+lemma pow_mono':
+  fixes n d1 d2 :: nat
+  assumes "d1 \<le> d2" and "0 < d1"
+  shows "n ^ d1 \<le> n ^ d2"
+  using assms by (metis dual_order.eq_iff less_le_trans neq0_conv pow_mono power_eq_0_iff)
+
+lemma linear_le_pow:
+  fixes n d1 :: nat
+  assumes "0 < d1"
+  shows "n \<le> n ^ d1"
+  using assms by (metis One_nat_def gr_implies_not0 le_less_linear less_Suc0 self_le_power)
+
+text \<open>
+The next definition formalizes the phrase ``polynomially bounded'' and the term
+``polynomial'' in ``polynomial running-time''. This is often written ``$f(n) =
+n^{O(1)}$'' (for example, Arora and Barak~\cite[Example 0.3]{ccama}).
+\<close>
+
+definition big_oh_poly :: "(nat \<Rightarrow> nat) \<Rightarrow> bool" where
+  "big_oh_poly f \<equiv> \<exists>d. big_oh f (\<lambda>n. n ^ d)"
+
+lemma big_oh_poly: "big_oh_poly f \<longleftrightarrow> (\<exists>d c n\<^sub>0. \<forall>n>n\<^sub>0. f n \<le> c * n ^ d)"
+  using big_oh_def big_oh_poly_def by auto
+
+lemma big_oh_polyI:
+  assumes "\<And>n. n > n\<^sub>0 \<Longrightarrow> f n \<le> c * n ^ d"
+  shows "big_oh_poly f"
+  using assms big_oh_poly by auto
+
+lemma big_oh_poly_const: "big_oh_poly (\<lambda>n. c)"
+proof -
+  let ?c = "max 1 c"
+  have "(\<lambda>n. c) n \<le> ?c * n ^ 1" if "n > 0" for n
+  proof -
+    have "c \<le> n * ?c"
+      by (metis (no_types) le_square max.cobounded2 mult.assoc mult_le_mono nat_mult_le_cancel_disj that)
+    then show ?thesis
+      by (simp add: mult.commute)
+  qed
+  then show ?thesis
+    using big_oh_polyI[of 0 _ ?c] by simp
+qed
+
+lemma big_oh_poly_poly: "big_oh_poly (\<lambda>n. n ^ d)"
+  using big_oh_polyI[of 0 _ 1 d] by simp
+
+lemma big_oh_poly_id: "big_oh_poly (\<lambda>n. n)"
+  using big_oh_poly_poly[of 1] by simp
+
+lemma big_oh_poly_le:
+  assumes "big_oh_poly f" and "\<And>n. g n \<le> f n"
+  shows "big_oh_poly g"
+  using assms big_oh_polyI by (metis big_oh_poly le_trans)
+
+lemma big_oh_poly_sum:
+  assumes "big_oh_poly f1" and "big_oh_poly f2"
+  shows "big_oh_poly (\<lambda>n. f1 n + f2 n)"
+proof-
+  obtain d1 c1 m1 where 1: "\<forall>n>m1. f1 n \<le> c1 * n ^ d1"
+    using big_oh_poly assms(1) by blast
+  obtain d2 c2 m2 where 2: "\<forall>n>m2. f2 n \<le> c2 * n ^ d2"
+    using big_oh_poly assms(2) by blast
+  let ?f3 = "\<lambda>n. f1 n + f2 n"
+  let ?c3 = "max c1 c2"
+  let ?m3 = "max m1 m2"
+  let ?d3 = "max d1 d2"
+  have "\<forall>n>?m3. f1 n \<le> ?c3 * n ^ d1"
+    using 1 by (simp add: max.coboundedI1 nat_mult_max_left)
+  moreover have "\<forall>n>?m3. n ^ d1 \<le> n^?d3"
+    using pow_mono by simp
+  ultimately have *: "\<forall>n>?m3. f1 n \<le> ?c3 * n^?d3"
+    using order_subst1 by fastforce
+  have "\<forall>n>?m3. f2 n \<le> ?c3 * n ^ d2"
+    using 2 by (simp add: max.coboundedI2 nat_mult_max_left)
+  moreover have "\<forall>n>?m3. n ^ d2 \<le> n ^ ?d3"
+    using pow_mono by simp
+  ultimately have "\<forall>n>?m3. f2 n \<le> ?c3 * n ^ ?d3"
+    using order_subst1 by fastforce
+  then have "\<forall>n>?m3. f1 n + f2 n \<le> ?c3 * n ^ ?d3 + ?c3 * n ^ ?d3"
+    using * by fastforce
+  then have "\<forall>n>?m3. f1 n + f2 n \<le> 2 * ?c3 * n ^ ?d3"
+    by auto
+  then have "\<exists>d c m. \<forall>n>m. ?f3 n \<le> c * n ^ d"
+    by blast
+  then show ?thesis
+    using big_oh_poly by simp
+qed
+
+lemma big_oh_poly_prod:
+  assumes "big_oh_poly f1" and "big_oh_poly f2"
+  shows "big_oh_poly (\<lambda>n. f1 n * f2 n)"
+proof-
+  obtain d1 c1 m1 where 1: "\<forall>n>m1. f1 n \<le> c1 * n ^ d1"
+    using big_oh_poly assms(1) by blast
+  obtain d2 c2 m2 where 2: "\<forall>n>m2. f2 n \<le> c2 * n ^ d2"
+    using big_oh_poly assms(2) by blast
+  let ?f3 = "\<lambda>n. f1 n * f2 n"
+  let ?c3 = "max c1 c2"
+  let ?m3 = "max m1 m2"
+  have "\<forall>n>?m3. f1 n \<le> ?c3 * n ^ d1"
+    using 1 by (simp add: max.coboundedI1 nat_mult_max_left)
+  moreover have "\<forall>n>?m3. n ^ d1 \<le> n ^ d1"
+    using pow_mono by simp
+  ultimately have *: "\<forall>n>?m3. f1 n \<le> ?c3 * n ^ d1"
+    using order_subst1 by fastforce
+  have "\<forall>n>?m3. f2 n \<le> ?c3 * n ^ d2"
+    using 2 by (simp add: max.coboundedI2 nat_mult_max_left)
+  moreover have "\<forall>n>?m3. n ^ d2 \<le> n ^ d2"
+    using pow_mono by simp
+  ultimately have "\<forall>n>?m3. f2 n \<le> ?c3 * n ^ d2"
+    using order_subst1 by fastforce
+  then have "\<forall>n>?m3. f1 n * f2 n \<le> ?c3 * n ^ d1 * ?c3 * n ^ d2"
+    using * mult_le_mono by (metis mult.assoc)
+  then have "\<forall>n>?m3. f1 n * f2 n \<le> ?c3 * ?c3 * n ^ d1 * n ^ d2"
+    by (simp add: semiring_normalization_rules(16))
+  then have "\<forall>n>?m3. f1 n * f2 n \<le> ?c3 * ?c3 * n ^ (d1 + d2)"
+    by (simp add: mult.assoc power_add)
+  then have "\<exists>d c m. \<forall>n>m. ?f3 n \<le> c * n ^ d"
+    by blast
+  then show ?thesis
+    using big_oh_poly by simp
+qed
+
+lemma big_oh_poly_offset:
+  assumes "big_oh_poly f"
+  shows "\<exists>b c d. d > 0 \<and> (\<forall>n. f n \<le> b + c * n ^ d)"
+proof -
+  obtain d c m where dcm: "\<forall>n>m. f n \<le> c * n ^ d"
+    using assms big_oh_poly by auto
+  have *: "f n \<le> c * n ^ Suc d" if "n > m" for n
+  proof -
+    have "n > 0"
+      using that by simp
+    then have "n ^ d \<le> n ^ Suc d"
+      by simp
+    then have "c * n ^ d \<le> c * n ^ Suc d"
+      by simp
+    then show "f n \<le> c * n ^ Suc d"
+      using dcm order_trans that by blast
+  qed
+  define b :: nat where "b = Max {f n | n. n \<le> m}"
+  then have "y \<le> b" if "y \<in> {f n | n. n \<le> m}" for y
+    using that by simp
+  then have "f n \<le> b" if "n \<le> m" for n
+    using that by auto
+  then have "f n \<le> b + c * n ^ Suc d" for n
+    using * by (meson trans_le_add1 trans_le_add2 verit_comp_simplify1(3))
+  then show ?thesis
+    using * dcm(1) by blast
+qed
+
+lemma big_oh_poly_composition:
+  assumes "big_oh_poly f1" and "big_oh_poly f2"
+  shows "big_oh_poly (f2 \<circ> f1)"
+proof-
+  obtain d1 c1 m1 where 1: "\<forall>n>m1. f1 n \<le> c1 * n ^ d1"
+    using big_oh_poly assms(1) by blast
+  obtain d2 c2 b where 2: "\<forall>n. f2 n \<le> b + c2 * n ^ d2"
+    using big_oh_poly_offset assms(2) by blast
+  define c where "c = c2 * c1 ^ d2"
+  have 3: "\<forall>n>m1. f1 n \<le> c1 * n ^ d1"
+    using 1 by simp
+  have "\<forall>n>m1. f2 n \<le> b + c2 * n ^ d2"
+    using 2 by simp
+  { fix n
+    assume "n > m1"
+    then have 4: "(f1 n) ^ d2 \<le> (c1 * n ^ d1) ^ d2"
+      using 3 by (simp add: power_mono)
+    have "f2 (f1 n) \<le> b + c2 * (f1 n) ^ d2"
+      using 2 by simp
+    also have "... \<le> b + c2 * (c1 * n ^ d1) ^ d2"
+      using 4 by simp
+    also have "... = b + c2 * c1 ^ d2 * n ^ (d1 * d2)"
+      by (simp add: power_mult power_mult_distrib)
+    also have "... = b + c * n ^ (d1 * d2)"
+      using c_def by simp
+    also have "... \<le> b * n ^ (d1 * d2) + c * n ^ (d1 * d2)"
+      using `n > m1` by simp
+    also have "... \<le> (b + c) * n ^ (d1 * d2)"
+      by (simp add: comm_semiring_class.distrib)
+    finally have "f2 (f1 n) \<le> (b + c) * n ^ (d1 * d2)" .
+  }
+  then show ?thesis
+    using big_oh_polyI[of m1 _ "b + c" "d1 * d2"] by simp
+qed
+
+lemma big_oh_poly_pow:
+  fixes f :: "nat \<Rightarrow> nat" and d :: nat
+  assumes "big_oh_poly f"
+  shows "big_oh_poly (\<lambda>n. f n ^ d)"
+proof -
+  let ?g = "\<lambda>n. n ^ d"
+  have "big_oh_poly ?g"
+    using big_oh_poly_poly by simp
+  moreover have "(\<lambda>n. f n ^ d) = ?g \<circ> f"
+    by auto
+  ultimately show ?thesis
+    using assms big_oh_poly_composition by simp
+qed
+
+text \<open>
+The textbook does not give an explicit definition of polynomials. It treats them
+as functions between natural numbers. So assuming the coefficients are natural
+numbers too, seems natural. We justify this choice when defining $\NP$ in
+Section~\ref{s:TC-NP}.
+
+\null
+\<close>
+
+definition polynomial :: "(nat \<Rightarrow> nat) \<Rightarrow> bool" where
+  "polynomial f \<equiv> \<exists>cs. \<forall>n. f n = (\<Sum>i\<leftarrow>[0..<length cs]. cs ! i * n ^ i)"
+
+lemma const_polynomial: "polynomial (\<lambda>_. c)"
+proof -
+  let ?cs = "[c]"
+  have "\<forall>n. (\<lambda>_. c) n = (\<Sum>i\<leftarrow>[0..<length ?cs]. ?cs ! i * n ^ i)"
+    by simp
+  then show ?thesis
+    using polynomial_def by blast
+qed
+
+lemma polynomial_id: "polynomial id"
+proof -
+  let ?cs = "[0, 1::nat]"
+  have "\<forall>n::nat. id n = (\<Sum>i\<leftarrow>[0..<length ?cs]. ?cs ! i * n ^ i)"
+    by simp
+  then show ?thesis
+    using polynomial_def by blast
+qed
+
+lemma big_oh_poly_polynomial:
+  fixes f :: "nat \<Rightarrow> nat"
+  assumes "polynomial f"
+  shows "big_oh_poly f"
+proof -
+  have "big_oh_poly (\<lambda>n. (\<Sum>i\<leftarrow>[0..<length cs]. cs ! i * n ^ i))" for cs
+  proof (induction "length cs" arbitrary: cs)
+    case 0
+    then show ?case
+      using big_oh_poly_const by simp
+  next
+    case (Suc len)
+    let ?cs = "butlast cs"
+    have len: "length ?cs = len"
+      using Suc by simp
+    {
+      fix n :: nat
+      have "(\<Sum>i\<leftarrow>[0..<length cs]. cs ! i * n ^ i) = (\<Sum>i\<leftarrow>[0..<Suc len]. cs ! i * n ^ i)"
+        using Suc by simp
+      also have "... = (\<Sum>i\<leftarrow>[0..<len]. cs ! i * n ^ i) + cs ! len * n ^ len"
+        using Suc(2)
+        by (metis (mono_tags, lifting) Nat.add_0_right list.simps(8) list.simps(9) map_append
+          sum_list.Cons sum_list.Nil sum_list_append upt_Suc zero_le)
+      also have "... = (\<Sum>i\<leftarrow>[0..<len]. ?cs ! i * n ^ i) + cs ! len * n ^ len"
+        using Suc(2) len by (metis (no_types, lifting) atLeastLessThan_iff map_eq_conv nth_butlast set_upt)
+      finally have "(\<Sum>i\<leftarrow>[0..<length cs]. cs ! i * n ^ i) = (\<Sum>i\<leftarrow>[0..<len]. ?cs ! i * n ^ i) + cs ! len * n ^ len" .
+    }
+    then have "(\<lambda>n. \<Sum>i\<leftarrow>[0..<length cs]. cs ! i * n ^ i) = (\<lambda>n. (\<Sum>i\<leftarrow>[0..<len]. ?cs ! i * n ^ i) + cs ! len * n ^ len)"
+      by simp
+    moreover have "big_oh_poly (\<lambda>n. cs ! len * n ^ len)"
+      using big_oh_poly_poly big_oh_poly_prod big_oh_poly_const by simp
+    moreover have "big_oh_poly (\<lambda>n. (\<Sum>i\<leftarrow>[0..<len]. ?cs ! i * n ^ i))"
+      using Suc len by blast
+    ultimately show "big_oh_poly (\<lambda>n. \<Sum>i\<leftarrow>[0..<length cs]. cs ! i * n ^ i)"
+      using big_oh_poly_sum by simp
+  qed
+  moreover obtain cs where "f = (\<lambda>n. (\<Sum>i\<leftarrow>[0..<length cs]. cs ! i * n ^ i))"
+    using assms polynomial_def by blast
+  ultimately show ?thesis
+    by simp
+qed
+
+
+section \<open>Increasing the alphabet or the number of tapes\label{s:tm-trans}\<close>
+
+text \<open>
+For technical reasons it is sometimes necessary to add tapes to a machine or to
+formally enlarge its alphabet such that it matches another machine's tape number
+or alphabet size without changing the behavior of the machine. The primary use
+of this is when composing machines with unequal alphabets or tape numbers (see
+Section~\ref{s:tm-composing}).
+\<close>
+
+subsection \<open>Enlarging the alphabet\<close>
+
+text \<open>
+A Turing machine over alphabet $G$ is not necessarily a Turing machine over a
+larger alphabet $G' > G$ because reading a symbol in $\{G, \dots, G'-1\}$ the TM
+may write a symbol $\geq G'$. This is easy to remedy by modifying the TM to do
+nothing when it reads a symbol $\geq G$. It then formally satisfies the alphabet
+restriction property of Turing commands. This is rather crude, because the new
+TM loops infinitely on encountering a ``forbidden'' symbol, but it is good
+enough for our purposes.
+
+The next function performs this transformation on a TM $M$ over alphabet $G$.
+The resulting machine is a Turing machine for every alphabet size $G' \ge G$.
+\<close>
+
+definition enlarged :: "nat \<Rightarrow> machine \<Rightarrow> machine" where
+  "enlarged G M \<equiv> map (\<lambda>cmd rs. if symbols_lt G rs then cmd rs else (0, map (\<lambda>r. (r, Stay)) rs)) M"
+
+lemma length_enlarged: "length (enlarged G M) = length M"
+  using enlarged_def by simp
+
+lemma enlarged_nth:
+  assumes "symbols_lt G gs" and "i < length M"
+  shows "(M ! i) gs = (enlarged G M ! i) gs"
+  using assms enlarged_def by simp
+
+lemma enlarged_write:
+  assumes "length gs = k" and "i < length M" and "turing_machine k G M"
+  shows "length (snd ((M ! i) gs)) = length (snd ((enlarged G M ! i) gs))"
+proof (cases "symbols_lt G gs")
+  case True
+  then show ?thesis
+    using assms enlarged_def by simp
+next
+  case False
+  then have "(enlarged G M ! i) gs = (0, map (\<lambda>r. (r, Stay)) gs)"
+    using assms enlarged_def by auto
+  then show ?thesis
+    using assms turing_commandD(1) turing_machine_def by (metis length_map nth_mem snd_conv)
+qed
+
+lemma turing_machine_enlarged:
+  assumes "turing_machine k G M" and "G' \<ge> G"
+  shows "turing_machine k G' (enlarged G M)"
+proof
+  let ?M = "enlarged G M"
+  show "2 \<le> k" and "4 \<le> G'"
+    using assms turing_machine_def by simp_all
+  show "turing_command k (length ?M) G' (?M ! i)"
+      if i: "i < length ?M" for i
+  proof
+    have len: "length ?M = length M"
+      using enlarged_def by simp
+    then have 1: "turing_command k (length M) G (M ! i)"
+      using assms(1) that turing_machine_def by simp
+    show "\<And>gs. length gs = k \<Longrightarrow> length ([!!] (?M ! i) gs) = length gs"
+      using enlarged_write that 1 len assms(1) by (metis turing_commandD(1))
+    show "(?M ! i) gs [.] j < G'"
+        if "length gs = k" "(\<And>i. i < length gs \<Longrightarrow> gs ! i < G')" "j < length gs"
+        for gs j
+    proof (cases "symbols_lt G gs")
+      case True
+      then have "(?M ! i) gs = (M ! i) gs"
+        using enlarged_def i by simp
+      moreover have "(M ! i) gs [.] j < G"
+        using "1" turing_commandD(2) that(1,3) True by simp
+      ultimately show ?thesis
+        using assms(2) by simp
+    next
+      case False
+      then have "(?M ! i) gs = (0, map (\<lambda>r. (r, Stay)) gs)"
+        using enlarged_def i by auto
+      then show ?thesis
+        using that by simp
+    qed
+    show "(?M ! i) gs [.] 0 = gs ! 0" if "length gs = k" and "k > 0" for gs
+    proof (cases "symbols_lt G gs")
+      case True
+      then show ?thesis
+        using enlarged_def i "1" turing_command_def that by simp
+    next
+      case False
+      then have "(?M ! i) gs = (0, map (\<lambda>r. (r, Stay)) gs)"
+        using that enlarged_def i by auto
+      then show ?thesis
+        using assms(1) turing_machine_def that by simp
+    qed
+    show "[*] ((?M ! i) gs) \<le> length ?M" if "length gs = k" for gs
+    proof (cases "symbols_lt G gs")
+      case True
+      then show ?thesis
+        using enlarged_def i that assms(1) turing_machine_def "1" turing_commandD(4) enlarged_nth len
+        by (metis (no_types, lifting))
+    next
+      case False
+      then show ?thesis
+        using that enlarged_def i by auto
+    qed
+  qed
+qed
+
+text \<open>
+The enlarged machine has the same behavior as the original machine when started
+on symbols over the original alphabet $G$.
+\<close>
+
+lemma execute_enlarged:
+  assumes "turing_machine k G M" and "symbols_lt G zs"
+  shows "execute (enlarged G M) (start_config k zs) t = execute M (start_config k zs) t"
+proof (induction t)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc t)
+  let ?M = "enlarged G M"
+  have "execute ?M (start_config k zs) (Suc t) = exe ?M (execute ?M (start_config k zs) t)"
+    by simp
+  also have "... = exe ?M (execute M (start_config k zs) t)"
+      (is "_ = exe ?M ?cfg")
+    using Suc by simp
+  also have "... = execute M (start_config k zs) (Suc t)"
+  proof (cases "fst ?cfg < length M")
+    case True
+    then have "exe ?M ?cfg = sem (?M ! (fst ?cfg)) ?cfg"
+        (is "_ = sem ?cmd ?cfg")
+      using exe_lt_length length_enlarged by simp
+    then have "exe ?M ?cfg =
+        (fst (?cmd (config_read ?cfg)),
+         map (\<lambda>(a, tp). act a tp) (zip (snd (?cmd (config_read ?cfg))) (snd ?cfg)))"
+      using sem' by simp
+    moreover have "symbols_lt G (config_read ?cfg)"
+      using read_alphabet' assms by auto
+    ultimately have "exe ?M ?cfg =
+        (fst ((M ! (fst ?cfg)) (config_read ?cfg)),
+         map (\<lambda>(a, tp). act a tp) (zip (snd ((M ! (fst ?cfg)) (config_read ?cfg))) (snd ?cfg)))"
+      using True enlarged_nth by auto
+    then have "exe ?M ?cfg = exe M ?cfg"
+      using sem' by (simp add: True exe_lt_length)
+    then show ?thesis
+      using Suc by simp
+  next
+    case False
+    then show ?thesis
+      using Suc enlarged_def exe_def by auto
+  qed
+  finally show ?case .
+qed
+
+lemma transforms_enlarged:
+  assumes "turing_machine k G M"
+    and "symbols_lt G zs"
+    and "transforms M (snd (start_config k zs)) t tps1"
+  shows "transforms (enlarged G M) (snd (start_config k zs)) t tps1"
+proof -
+  let ?tps = "snd (start_config k zs)"
+  have "\<exists>t'\<le>t. execute M (start_config k zs) t' = (length M, tps1)"
+    using assms(3) transforms_def transits_def start_config_def by simp
+  then have "\<exists>t'\<le>t. execute (enlarged G M) (start_config k zs) t' = (length M, tps1)"
+    using assms(1,2) transforms_def transits_def execute_enlarged by auto
+  moreover have "length M = length (enlarged G M)"
+    using enlarged_def by simp
+  ultimately show ?thesis
+    using start_config_def transforms_def transitsI by auto
+qed
+
+
+subsection \<open>Increasing the number of tapes\<close>
+
+text \<open>
+We can add tapes to a Turing machine in such a way that on the additional tapes
+the machine does nothing. While the new tapes could go anywhere, we only
+consider appending them at the end or inserting them at the beginning.
+\<close>
+
+
+subsubsection \<open>Appending tapes at the end\<close>
+
+text \<open>
+The next function turns a $k$-tape Turing machine into a $k'$-tape Turing
+machine (for $k' \geq k$) by appending $k' - k$ tapes at the end.
+\<close>
+
+definition append_tapes :: "nat \<Rightarrow> nat \<Rightarrow> machine \<Rightarrow> machine" where
+  "append_tapes k k' M \<equiv>
+    map (\<lambda>cmd rs. (fst (cmd (take k rs)), snd (cmd (take k rs)) @ (map (\<lambda>i. (rs ! i, Stay)) [k..<k']))) M"
+
+lemma length_append_tapes: "length (append_tapes k k' M) = length M"
+  unfolding append_tapes_def by simp
+
+lemma append_tapes_nth:
+  assumes "i < length M" and "length gs = k'"
+  shows "(append_tapes k k' M ! i) gs =
+         (fst ((M ! i) (take k gs)), snd ((M ! i) (take k gs)) @ (map (\<lambda>j. (gs ! j, Stay)) [k..<k']))"
+  unfolding append_tapes_def using assms(1) by simp
+
+lemma append_tapes_tm:
+  assumes "turing_machine k G M" and "k' \<ge> k"
+  shows "turing_machine k' G (append_tapes k k' M)"
+proof
+  let ?M = "append_tapes k k' M"
+  show "2 \<le> k'"
+    using assms turing_machine_def by simp
+  show "4 \<le> G"
+    using assms(1) turing_machine_def by simp
+  show "turing_command k' (length ?M) G (?M ! i)" if "i < length ?M" for i
+  proof
+    have "i < length M"
+      using that by (simp add: append_tapes_def)
+    then have turing_command: "turing_command k (length M) G (M ! i)"
+      using assms(1) that turing_machine_def by simp
+    have ith: "append_tapes k k' M ! i =
+        (\<lambda>rs. (fst ((M ! i) (take k rs)), snd ((M ! i) (take k rs)) @ (map (\<lambda>j. (rs ! j, Stay)) [k..<k'])))"
+      unfolding append_tapes_def using `i < length M` by simp
+    show "\<And>gs. length gs = k' \<Longrightarrow> length ([!!] (append_tapes k k' M ! i) gs) = length gs"
+      using assms(2) ith turing_command turing_commandD by simp
+    show "(append_tapes k k' M ! i) gs [.] j < G"
+      if "length gs = k'" "\<And>i. i < length gs \<Longrightarrow> gs ! i < G" "j < length gs"
+      for j gs
+    proof (cases "j < k")
+      case True
+      let ?gs = "take k gs"
+      have len: "length ?gs = k"
+        using that(1) assms(2) by simp
+      have "\<And>i. i < length ?gs \<Longrightarrow> ?gs ! i < G"
+        using that(2) by simp
+      then have "\<forall>i'<length ?gs. (M ! i) ?gs [.] i' < G"
+        using turing_commandD(2)[OF turing_command len] by simp
+      then show ?thesis
+        using ith that turing_commandD(1)[OF turing_command len] by (simp add: nth_append)
+    next
+      case False
+      then have "j \<ge> k"
+        by simp
+      have *: "length (snd ((M ! i) (take k gs))) = k"
+        using turing_commandD(1)[OF turing_command] assms(2) that(1) by auto
+      have "(append_tapes k k' M ! i) gs [.] j =
+          fst ((snd ((M ! i) (take k gs)) @ (map (\<lambda>j. (gs ! j, Stay)) [k..<k'])) ! j)"
+        using ith by simp
+      also have "... = fst ((map (\<lambda>j. (gs ! j, Stay)) [k..<k']) ! (j - k))"
+        using * that `j \<ge> k` by (simp add: False nth_append)
+      also have "... = fst (gs ! j, Stay)"
+        by (metis False \<open>k \<le> j\<close> add_diff_inverse_nat diff_less_mono length_upt nth_map nth_upt that(1,3))
+      also have "... = gs ! j"
+        by simp
+      also have "... < G"
+        using that(2,3) by simp
+      finally show ?thesis
+        by simp
+    qed
+    show "(append_tapes k k' M ! i) gs [.] 0 = gs ! 0" if "length gs = k'" for gs
+    proof -
+      have "k > 0"
+        using assms(1) turing_machine_def by simp
+      then have 1: "(M ! i) rs [.] 0 = rs ! 0" if "length rs = k" for rs
+        using turing_commandD(3)[OF turing_command that] that by simp
+      have len: "length (take k gs) = k"
+        by (simp add: assms(2) min_absorb2 that(1))
+      then have *: "length (snd ((M ! i) (take k gs))) = k"
+        using turing_commandD(1)[OF turing_command] by auto
+      have "(append_tapes k k' M ! i) gs [.] 0 =
+          fst ((snd ((M ! i) (take k gs)) @ (map (\<lambda>j. (gs ! j, Stay)) [k..<k'])) ! 0)"
+        using ith by simp
+      also have "... = fst (snd ((M ! i) (take k gs)) ! 0)"
+        using * by (simp add: nth_append `0 < k`)
+      finally show ?thesis
+        using 1 len \<open>0 < k\<close> by simp
+    qed
+    show "[*] ((append_tapes k k' M ! i) gs) \<le> length (append_tapes k k' M)" if "length gs = k'" for gs
+    proof -
+      have "length (take k gs) = k"
+        using assms(2) that by simp
+      then have 1: "fst ((M ! i) (take k gs)) \<le> length M"
+        using turing_commandD[OF turing_command] \<open>i < length M\<close> assms(1) turing_machine_def by blast
+      moreover have "fst ((append_tapes k k' M ! i) gs) = fst ((M ! i) (take k gs))"
+        using ith by simp
+      ultimately show "fst ((append_tapes k k' M ! i) gs) \<le> length (append_tapes k k' M)"
+        using length_append_tapes by metis
+    qed
+  qed
+qed
+
+lemma execute_append_tapes:
+  assumes "turing_machine k G M" and "k' \<ge> k" and "length tps = k'"
+  shows "execute (append_tapes k k' M) (q, tps) t =
+     (fst (execute M (q, take k tps) t), snd (execute M (q, take k tps) t) @ drop k tps)"
+proof (induction t)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc t)
+  let ?M = "append_tapes k k' M"
+  let ?cfg = "execute M (q, take k tps) t"
+  let ?cfg' = "execute M (q, take k tps) (Suc t)"
+  have "execute ?M (q, tps) (Suc t) = exe ?M (execute ?M (q, tps) t)"
+    by simp
+  also have "... = exe ?M (fst ?cfg, snd ?cfg @ drop k tps)"
+    using Suc by simp
+  also have "... = (fst ?cfg', snd ?cfg' @ drop k tps)"
+  proof (cases "fst ?cfg < length ?M")
+    case True
+    have "sem (?M ! (fst ?cfg)) (fst ?cfg, snd ?cfg @ drop k tps) = (fst ?cfg', snd ?cfg' @ drop k tps)"
+    proof (rule semI)
+      have "turing_machine k' G (append_tapes k k' M)"
+        using append_tapes_tm[OF assms(1,2)] by simp
+      then show 1: "proper_command k' (append_tapes k k' M ! fst (execute M (q, take k tps) t))"
+        using True turing_machine_def turing_commandD by (metis nth_mem)
+      show 2: "length (snd ?cfg @ drop k tps) = k'"
+        using assms execute_num_tapes by fastforce
+      show "length (snd ?cfg' @ drop k tps) = k'"
+        by (metis (no_types, lifting) append_take_drop_id assms execute_num_tapes
+          length_append length_take min_absorb2 snd_conv)
+      show "fst ((?M ! fst ?cfg) (read (snd ?cfg @ drop k tps))) = fst ?cfg'"
+      proof -
+        have less': "fst ?cfg < length M"
+          using True by (simp add: length_append_tapes)
+        let ?tps = "snd ?cfg @ drop k tps"
+        have "length (snd ?cfg) = k"
+          using assms execute_num_tapes by fastforce
+        then have take2: "take k ?tps = snd ?cfg"
+          by simp
+        let ?rs = "read ?tps"
+        have len: "length ?rs = k'"
+          using 2 read_length by simp
+        have take2': "take k ?rs = read (snd ?cfg)"
+          using read_def take2 by (metis (mono_tags, lifting) take_map)
+        have "fst ((?M ! fst ?cfg) ?rs) =
+            fst (fst ((M ! fst ?cfg) (take k ?rs)), snd ((M ! fst ?cfg) (take k ?rs)) @ (map (\<lambda>j. (?rs ! j, Stay)) [k..<k']))"
+          using append_tapes_nth[OF less' len] by simp
+        also have "... = fst ((M ! fst ?cfg) (read (snd ?cfg)))"
+          using take2' by simp
+        also have "... = fst (exe M ?cfg)"
+          by (simp add: exe_def less' sem_fst)
+        finally show ?thesis
+          by simp
+      qed
+      show "(act ((?M ! fst ?cfg) (read (snd ?cfg @ drop k tps)) [!] j) ((snd ?cfg @ drop k tps) ! j) =
+            (snd ?cfg' @ drop k tps) ! j)"
+          if "j < k'" for j
+      proof -
+        have less': "fst ?cfg < length M"
+          using True by (simp add: length_append_tapes)
+        let ?tps = "snd ?cfg @ drop k tps"
+        have len2: "length (snd ?cfg) = k"
+          using assms execute_num_tapes by fastforce
+        then have take2: "take k ?tps = snd ?cfg"
+          by simp
+        from len2 have len2': "length (snd ((M ! fst ?cfg) (read (snd ?cfg)))) = k"
+          using assms(1) turing_commandD(1) less' read_length turing_machine_def by (metis nth_mem)
+        let ?rs = "read ?tps"
+        have len: "length ?rs = k'"
+          using 2 read_length by simp
+        have take2': "take k ?rs = read (snd ?cfg)"
+          using read_def take2 by (metis (mono_tags, lifting) take_map)
+        have "act ((?M ! fst ?cfg) ?rs [!] j) (?tps ! j) =
+            act ((fst ((M ! fst ?cfg) (take k ?rs)), snd ((M ! fst ?cfg) (take k ?rs)) @ (map (\<lambda>j. (?rs ! j, Stay)) [k..<k'])) [!] j) (?tps ! j)"
+          using append_tapes_nth[OF less' len] by simp
+        also have "... = act
+             ((fst ((M ! fst ?cfg) (read (snd ?cfg))), snd ((M ! fst ?cfg) (read (snd ?cfg))) @ (map (\<lambda>j. (?rs ! j, Stay)) [k..<k'])) [!] j)
+             (?tps ! j)"
+          using take2' by simp
+        also have "... = act
+             ((snd ((M ! fst ?cfg) (read (snd ?cfg))) @ (map (\<lambda>j. (?rs ! j, Stay)) [k..<k'])) ! j)
+             (?tps ! j)"
+          by simp
+        also have "... = (snd ?cfg' @ drop k tps) ! j"
+        proof (cases "j < k")
+          case True
+          then have tps: "?tps ! j = snd ?cfg ! j"
+            by (simp add: len2 nth_append)
+          have "(snd ?cfg' @ drop k tps) ! j = (snd (exe M ?cfg) @ drop k tps) ! j"
+            by simp
+          also have "... = snd (exe M ?cfg) ! j"
+            using assms(1) True by (metis exe_num_tapes len2 nth_append)
+          also have "... = snd (sem (M ! fst ?cfg) ?cfg) ! j"
+            by (simp add: exe_lt_length less')
+          also have "... = act (snd ((M ! fst ?cfg) (read (snd ?cfg))) ! j) (?tps ! j)"
+          proof -
+            have "proper_command k (M ! (fst ?cfg))"
+              using turing_commandD(1) turing_machine_def assms(1) less' nth_mem by blast
+            then show ?thesis
+              using sem_snd True tps len2 by simp
+          qed
+          finally show ?thesis
+              using len2' True by (simp add: nth_append)
+        next
+          case False
+          then have tps: "?tps ! j = tps ! j"
+            using len2 by (metis (no_types, lifting) "2" append_take_drop_id assms(3) length_take nth_append take2)
+          from False have gt2: "j \<ge> k"
+            by simp
+          have len': "length (snd ?cfg') = k"
+            using assms(1) exe_num_tapes len2 by auto
+          have rs: "?rs ! j = read tps ! j"
+            using tps by (metis (no_types, lifting) "2" assms(3) that nth_map read_def)
+          have "act ((snd ((M ! fst ?cfg) (read (snd ?cfg))) @ (map (\<lambda>j. (?rs ! j, Stay)) [k..<k'])) ! j) (?tps ! j) =
+               act ((map (\<lambda>j. (?rs ! j, Stay)) [k..<k']) ! (j - k)) (?tps ! j)"
+            using False len2 len2' by (simp add: nth_append)
+          also have "... = act (?rs ! j, Stay) (?tps ! j)"
+            by (metis (no_types, lifting) False add_diff_inverse_nat diff_less_mono gt2 that length_upt nth_map nth_upt)
+          also have "... = act (?rs ! j, Stay) (tps ! j)"
+            using tps by simp
+          also have "... = act (read tps ! j, Stay) (tps ! j)"
+            using rs by simp
+          also have "... = tps ! j"
+            using act_Stay assms(3) that by simp
+          also have "... = (snd (exe M ?cfg) @ drop k tps) ! j"
+            using len'
+            by (metis (no_types, lifting) "2" False append_take_drop_id assms(3) execute.simps(2) len2 length_take nth_append take2)
+          also have "... = (snd ?cfg' @ drop k tps) ! j"
+            by simp
+          finally show ?thesis
+            by simp
+        qed
+        finally show "act ((?M ! fst ?cfg) ?rs [!] j) (?tps ! j) = (snd ?cfg' @ drop k tps) ! j" .
+      qed
+    qed
+    then show ?thesis
+      using exe_def True by simp
+  next
+    case False
+    then show ?thesis
+      using assms by (simp add: exe_ge_length length_append_tapes)
+  qed
+  finally show "execute ?M (q, tps) (Suc t) = (fst ?cfg', snd ?cfg' @ drop k tps)" .
+qed
+
+lemma execute_append_tapes':
+  assumes "turing_machine k G M" and "length tps = k"
+  shows "execute (append_tapes k (k + length tps') M) (q, tps @ tps') t =
+     (fst (execute M (q, tps) t), snd (execute M (q, tps) t) @ tps')"
+  using assms execute_append_tapes by simp
+
+lemma transforms_append_tapes:
+  assumes "turing_machine k G M"
+    and "length tps0 = k"
+    and "transforms M tps0 t tps1"
+  shows "transforms (append_tapes k (k + length tps') M) (tps0 @ tps') t (tps1 @ tps')"
+    (is "transforms ?M _ _ _")
+proof -
+  have "execute M (0, tps0) t = (length M, tps1)"
+    using assms(3) transforms_def transits_def by (metis (no_types, opaque_lifting) execute_after_halting_ge fst_conv)
+  then have "execute ?M (0, tps0 @ tps') t = (length M, tps1 @ tps')"
+    using assms(1,2) execute_append_tapes' by simp
+  moreover have "length M = length ?M"
+    by (simp add: length_append_tapes)
+  ultimately show ?thesis
+    by (simp add: execute_imp_transits transforms_def)
+qed
+
+
+subsubsection \<open>Inserting tapes at the beginning\<close>
+
+text \<open>
+The next function turns a $k$-tape Turing machine into a $(k + d)$-tape Turing
+machine by inserting $d$ tapes at the beginning.
+\<close>
+
+definition prepend_tapes :: "nat \<Rightarrow> machine \<Rightarrow> machine" where
+  "prepend_tapes d M \<equiv>
+    map (\<lambda>cmd rs. (fst (cmd (drop d rs)), map (\<lambda>h. (h, Stay)) (take d rs) @ snd (cmd (drop d rs)))) M"
+
+lemma prepend_tapes_at:
+  assumes "i < length M"
+  shows "(prepend_tapes d M ! i) gs =
+    (fst ((M ! i) (drop d gs)), map (\<lambda>h. (h, Stay)) (take d gs) @ snd ((M ! i) (drop d gs)))"
+  using assms prepend_tapes_def by simp
+
+lemma prepend_tapes_tm:
+  assumes "turing_machine k G M"
+  shows "turing_machine (d + k) G (prepend_tapes d M)"
+proof
+  show "2 \<le> d + k"
+    using assms turing_machine_def by simp
+  show "4 \<le> G"
+    using assms turing_machine_def by simp
+  let ?M = "prepend_tapes d M"
+  show "turing_command (d + k) (length ?M) G (?M ! i)" if "i < length ?M" for i
+  proof
+    have len: "i < length M"
+      using that prepend_tapes_def by simp
+    then have *: "(?M ! i) gs = (fst ((M ! i) (drop d gs)), map (\<lambda>h. (h, Stay)) (take d gs) @ snd ((M ! i) (drop d gs)))"
+        if "length gs = d + k" for gs
+      using prepend_tapes_def that by simp
+    have tc: "turing_command k (length M) G (M ! i)"
+      using that turing_machine_def len assms by simp
+    show "length (snd ((?M ! i) gs)) = length gs" if "length gs = d + k" for gs
+      using * that turing_commandD[OF tc] by simp
+    show "(?M ! i) gs [.] j < G"
+        if "length gs = d + k" "(\<And>i. i < length gs \<Longrightarrow> gs ! i < G)" "j < length gs"
+        for gs j
+    proof (cases "j < d")
+      case True
+      have "(?M ! i) gs [.] j = fst ((map (\<lambda>h. (h, Stay)) (take d gs) @ snd ((M ! i) (drop d gs))) ! j)"
+        using * that(1) by simp
+      also have "... = fst (map (\<lambda>h. (h, Stay)) (take d gs) ! j)"
+        using True that(1) by (simp add: nth_append)
+      also have "... = gs ! j"
+        by (simp add: True that(3))
+      finally have "(?M ! i) gs [.] j = gs ! j" .
+      then show ?thesis
+        using that(2,3) by simp
+    next
+      case False
+      have "(?M ! i) gs [.] j = fst ((map (\<lambda>h. (h, Stay)) (take d gs) @ snd ((M ! i) (drop d gs))) ! j)"
+        using * that(1) by simp
+      also have "... = fst (snd ((M ! i) (drop d gs)) ! (j - d))"
+        using False that(1)
+        by (metis (no_types, lifting) add_diff_cancel_left' append_take_drop_id
+          diff_add_inverse2 length_append length_drop length_map nth_append)
+      also have "... < G"
+        using False that turing_commandD[OF tc] by simp
+      finally show ?thesis
+        by simp
+    qed
+    show "(?M ! i) gs [.] 0 = gs ! 0" if "length gs = d + k" and "d + k > 0" for gs
+    proof (cases "d = 0")
+      case True
+      then have "(?M ! i) gs [.] 0 = fst (snd ((M ! i) gs) ! 0)"
+        using * that(1) by simp
+      then show ?thesis
+        using True that turing_commandD[OF tc] by simp
+    next
+      case False
+      then have "(?M ! i) gs [.] 0 = fst ((map (\<lambda>h. (h, Stay)) (take d gs)) ! 0)"
+        using * that(1) by (simp add: nth_append)
+      also have "... = fst ((map (\<lambda>h. (h, Stay)) gs) ! 0)"
+        using False by (metis gr_zeroI nth_take take_map)
+      also have "... = gs ! 0"
+        using False that by simp
+      finally show ?thesis
+        by simp
+    qed
+    show "[*] ((?M ! i) gs) \<le> length ?M" if "length gs = d + k" for gs
+    proof -
+      have "fst ((?M ! i) gs) = fst ((M ! i) (drop d gs))"
+        using that * by simp
+      moreover have "length (drop d gs) = k"
+        using that by simp
+      ultimately have "fst ((?M ! i) gs) \<le> length M"
+        using turing_commandD(4)[OF tc] by fastforce
+      then show "fst ((?M ! i) gs) \<le> length ?M"
+        using prepend_tapes_def by simp
+    qed
+  qed
+qed
+
+definition shift_cfg :: "tape list \<Rightarrow> config \<Rightarrow> config" where
+  "shift_cfg tps cfg \<equiv> (fst cfg, tps @ snd cfg)"
+
+lemma execute_prepend_tapes:
+  assumes "turing_machine k G M" and "length tps = d" and "||cfg0|| = k"
+  shows "execute (prepend_tapes d M) (shift_cfg tps cfg0) t = shift_cfg tps (execute M cfg0 t)"
+proof (induction t)
+  case 0
+  show ?case
+    by simp
+next
+  case (Suc t)
+  let ?M = "prepend_tapes d M"
+  let ?scfg = "shift_cfg tps cfg0"
+  let ?scfg' = "execute ?M ?scfg t"
+  let ?cfg' = "execute M cfg0 t"
+  have fst: "fst ?cfg' = fst ?scfg'"
+    using shift_cfg_def Suc.IH by simp
+  have len: "||?cfg'|| = k"
+    using assms(1,3) execute_num_tapes read_length by auto
+  have len_s: "||?scfg'|| = d + k"
+    using prepend_tapes_tm[OF assms(1)] shift_cfg_def assms(2,3) execute_num_tapes read_length
+    by (metis length_append snd_conv)
+  let ?srs = "read (snd ?scfg')"
+  let ?rs = "read (snd ?cfg')"
+  have len_rs: "length ?rs = k"
+    using assms(1,3) execute_num_tapes read_length by auto
+  moreover have len_srs: "length ?srs = k + d"
+    using prepend_tapes_tm[OF assms(1)] shift_cfg_def assms(2,3)
+    by (metis add.commute execute_num_tapes length_append read_length snd_conv)
+  ultimately have srs_rs: "drop d ?srs = ?rs"
+    using Suc shift_cfg_def read_def by simp
+  have *: "execute ?M ?scfg (Suc t) = exe ?M ?scfg'"
+    by simp
+  show ?case
+  proof (cases "fst ?scfg' \<ge> length ?M")
+    case True
+    then show ?thesis
+      using * Suc exe_ge_length shift_cfg_def prepend_tapes_def by auto
+  next
+    case running: False
+    then have scmd: "?M ! (fst ?scfg') =
+      (\<lambda>gs. (fst ((M ! (fst ?scfg')) (drop d gs)), map (\<lambda>h. (h, Stay)) (take d gs) @ snd ((M ! (fst ?scfg')) (drop d gs))))"
+      (is "?scmd = _")
+      using prepend_tapes_at prepend_tapes_def by auto
+    then have cmd: "?M ! (fst ?scfg') =
+      (\<lambda>gs. (fst ((M ! (fst ?cfg')) (drop d gs)), map (\<lambda>h. (h, Stay)) (take d gs) @ snd ((M ! (fst ?cfg')) (drop d gs))))"
+      using fst by simp
+    let ?cmd = "M ! (fst ?cfg')"
+
+    have "execute ?M ?scfg (Suc t) = sem (?M ! (fst ?scfg')) ?scfg'"
+      using running * exe_lt_length by simp
+    then have lhs: "execute ?M ?scfg (Suc t) =
+        (fst (?scmd ?srs), map (\<lambda>(a, tp). act a tp) (zip (snd (?scmd ?srs)) (snd ?scfg')))"
+        (is "_ = ?lhs")
+      using sem' by simp
+
+    have "shift_cfg tps (execute M cfg0 (Suc t)) = shift_cfg tps (exe M ?cfg')"
+      by simp
+    also have "... = shift_cfg tps (sem (M ! (fst ?cfg')) ?cfg')"
+      using exe_lt_length running fst prepend_tapes_def by auto
+    also have "... = shift_cfg tps
+        (fst (?cmd ?rs), map (\<lambda>(a, tp). act a tp) (zip (snd (?cmd ?rs)) (snd ?cfg')))"
+      using sem' by simp
+    also have "... = (fst (?cmd ?rs), tps @ map (\<lambda>(a, tp). act a tp) (zip (snd (?cmd ?rs)) (snd ?cfg')))"
+      using shift_cfg_def by simp
+    finally have rhs: "shift_cfg tps (execute M cfg0 (Suc t)) =
+       (fst (?cmd ?rs), tps @ map (\<lambda>(a, tp). act a tp) (zip (snd (?cmd ?rs)) (snd ?cfg')))"
+      (is "_ = ?rhs") .
+
+    have "?lhs = ?rhs"
+    proof standard+
+      show "fst (?scmd ?srs) = fst (?cmd ?rs)"
+        using srs_rs cmd by simp
+      show "map (\<lambda>(a, tp). act a tp) (zip (snd (?scmd ?srs)) (snd ?scfg')) =
+          tps @ map (\<lambda>(a, tp). act a tp) (zip (snd (?cmd ?rs)) (snd ?cfg'))"
+          (is "?l = ?r")
+      proof (rule nth_equalityI)
+        have lenl: "length ?l = d + k"
+          using lhs execute_num_tapes assms prepend_tapes_tm len_s
+          by (smt (z3) length_append shift_cfg_def snd_conv)
+        moreover have "length ?r = d + k"
+          using rhs execute_num_tapes assms shift_cfg_def
+          by (metis (mono_tags, lifting) length_append snd_conv)
+        ultimately show "length ?l = length ?r"
+          by simp
+        show "?l ! j = ?r ! j" if "j < length ?l" for j
+        proof (cases "j < d")
+          case True
+          let ?at = "zip (snd (?scmd ?srs)) (snd ?scfg') ! j"
+          have "?l ! j = act (fst ?at) (snd ?at)"
+            using that by simp
+          moreover have "fst ?at = snd (?scmd ?srs) ! j"
+            using that by simp
+          moreover have "snd ?at = snd ?scfg' ! j"
+            using that by simp
+          ultimately have "?l ! j = act (snd (?scmd ?srs) ! j) (snd ?scfg' ! j)"
+            by simp
+          moreover have "snd ?scfg' ! j = tps ! j"
+            using shift_cfg_def assms(2) by (metis (no_types, lifting) Suc.IH True nth_append snd_conv)
+          moreover have "snd (?scmd ?srs) ! j = (?srs ! j, Stay)"
+          proof -
+            have "snd (?scmd ?srs) = map (\<lambda>h. (h, Stay)) (take d ?srs) @ snd ((M ! (fst ?scfg')) (drop d ?srs))"
+              using scmd by simp
+            then have "snd (?scmd ?srs) ! j = map (\<lambda>h. (h, Stay)) (take d ?srs) ! j"
+              using len_srs lenl True that
+              by (smt (z3) add.commute length_map length_take min_less_iff_conj nth_append)
+            then show ?thesis
+              using len_srs True by simp
+          qed
+          moreover have "?r ! j = tps ! j"
+            using True assms(2) by (simp add: nth_append)
+          ultimately show ?thesis
+            using len_s that lenl by (metis act_Stay)
+        next
+          case False
+          have jle: "j < d + k"
+            using lenl that by simp
+          have jle': "j - d < k"
+            using lenl that False by simp
+
+          let ?at = "zip (snd (?scmd ?srs)) (snd ?scfg') ! j"
+          have "?l ! j = act (fst ?at) (snd ?at)"
+            using that by simp
+          moreover have "fst ?at = snd (?scmd ?srs) ! j"
+            using that by simp
+          moreover have "snd ?at = snd ?scfg' ! j"
+            using that by simp
+          ultimately have "?l ! j = act (snd (?scmd ?srs) ! j) (snd ?scfg' ! j)"
+            by simp
+          moreover have "snd ?scfg' ! j = snd ?cfg' ! (j - d)"
+            using shift_cfg_def assms(2) Suc False jle by (metis nth_append snd_conv)
+          moreover have "snd (?scmd ?srs) ! j = snd (?cmd ?rs) ! (j - d)"
+          proof -
+            have "snd (?scmd ?srs) = map (\<lambda>h. (h, Stay)) (take d ?srs) @ snd ((M ! (fst ?cfg')) (drop d ?srs))"
+              using cmd by simp
+            then have "snd (?scmd ?srs) ! j = snd ((M ! (fst ?cfg')) (drop d ?srs)) ! (j - d)"
+              using len_srs lenl False that len_rs
+              by (smt (z3) Nat.add_diff_assoc add.right_neutral add_diff_cancel_left' append_take_drop_id
+                le_add1 length_append length_map nth_append srs_rs)
+            then have "snd (?scmd ?srs) ! j = snd (?cmd ?rs) ! (j - d)"
+              using srs_rs by simp
+            then show ?thesis
+              by simp
+          qed
+          moreover have "?r ! j = act (snd (?cmd ?rs) ! (j - d)) (snd ?cfg' ! (j - d))"
+          proof -
+            have "fst (execute M cfg0 t) < length M"
+              using running fst prepend_tapes_def by simp
+            then have len1: "length (snd (?cmd ?rs)) = k"
+              using assms(1) len_rs turing_machine_def[of k G M] turing_commandD(1) by fastforce
+            have "?r ! j = map (\<lambda>(a, tp). act a tp) (zip (snd (?cmd ?rs)) (snd ?cfg')) ! (j - d)"
+              using assms(2) False by (simp add: nth_append)
+            also have "... = act (snd (?cmd ?rs) ! (j - d)) (snd ?cfg' ! (j - d))"
+              using len1 len jle' by simp
+            finally show ?thesis
+              by simp
+          qed
+          ultimately show ?thesis
+            by simp
+        qed
+      qed
+    qed
+    then show ?thesis
+      using lhs rhs by simp
+  qed
+qed
+
+lemma transforms_prepend_tapes:
+  assumes "turing_machine k G M"
+    and "length tps = d"
+    and "length tps0 = k"
+    and "transforms M tps0 t tps1"
+  shows "transforms (prepend_tapes d M) (tps @ tps0) t (tps @ tps1)"
+proof -
+  have "\<exists>t'\<le>t. execute M (0, tps0) t' = (length M, tps1)"
+    using assms(4) transforms_def transits_def by simp
+  then have "\<exists>t'\<le>t. execute (prepend_tapes d M) (shift_cfg tps (0, tps0)) t' = shift_cfg tps (length M, tps1)"
+    using assms transforms_def transits_def execute_prepend_tapes shift_cfg_def by auto
+  moreover have "length M = length (prepend_tapes d M)"
+    using prepend_tapes_def by simp
+  ultimately show ?thesis
+    using shift_cfg_def transforms_def transitsI by auto
+qed
+
+end
\ No newline at end of file
diff --git a/thys/Cook_Levin/Combinations.thy b/thys/Cook_Levin/Combinations.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Combinations.thy
@@ -0,0 +1,1009 @@
+section \<open>Combining Turing machines\label{s:tm-combining}\<close>
+
+theory Combinations
+  imports Basics "HOL-Eisbach.Eisbach"
+begin
+
+text \<open>
+This section describes how we can combine Turing machines in the way of
+traditional control structures found in structured programming, namely
+sequences, branching, and iterating. This allows us to build complex Turing
+machines from simpler ones and analyze their behavior and running time.  Thanks
+to some syntactic sugar the result may even look like a programming language,
+but it is really more like a ``construction kit'' than a ``true'' programming
+language with small and big step semantics or Hoare rules. Instead we will
+merely have some lemmas for proving @{const transforms} statements for the
+combined machines.
+
+The remaining sections of this chapter will provide us with concrete Turing
+machines to combine.
+\<close>
+
+
+subsection \<open>Relocated machines\<close>
+
+text \<open>
+If we use a Turing machine $M$ as part of another TM and there are $q$ commands
+before $M$, then $M$'s target states will be off by $q$. This can be fixed by
+adding $q$ to all target states of all commands in $M$, an operation we call
+\emph{relocation}.
+\<close>
+
+definition relocate_cmd :: "nat \<Rightarrow> command \<Rightarrow> command" where
+  "relocate_cmd q cmd rs \<equiv> (fst (cmd rs) + q, snd (cmd rs))"
+
+lemma relocate_cmd_head: "relocate_cmd q cmd rs [~] j = cmd rs [~] j"
+  using relocate_cmd_def by simp
+
+lemma sem_relocate_cmd: "sem (relocate_cmd q cmd) cfg = (sem cmd cfg) <+=> q"
+proof-
+  let ?cmd' = "relocate_cmd q cmd"
+  let ?rs = "read (snd cfg)"
+  have "?cmd' ?rs = (fst (cmd ?rs) + q, snd (cmd ?rs))"
+    by (simp add: relocate_cmd_def)
+  then show ?thesis
+    using sem by (metis (no_types, lifting) fst_conv snd_conv)
+qed
+
+definition relocate :: "nat \<Rightarrow> machine \<Rightarrow> machine" where
+  "relocate q M \<equiv> map (relocate_cmd q) M"
+
+lemma relocate:
+  assumes "M' = relocate q M" and "i < length M"
+  shows "(M' ! i) r = (fst ((M ! i) r) + q, snd ((M ! i) r))"
+  using assms relocate_def relocate_cmd_def by simp
+
+lemma sem_relocate:
+  assumes "M' = relocate q M" and "i < length M"
+  shows "sem (M' ! i) cfg = sem (M ! i) cfg <+=> q"
+  using assms relocate_def sem_relocate_cmd by simp
+
+lemma turing_command_relocate_cmd:
+  assumes "turing_command k Q G cmd"
+  shows "turing_command k (Q + q) G (relocate_cmd q cmd)"
+  using assms relocate_cmd_def turing_commandD by auto
+
+lemma turing_command_relocate:
+  assumes "M' = relocate q M" and "turing_machine k G M" and "i < length M"
+  shows "turing_command k (length M + q) G (M' ! i)"
+proof
+  fix gs :: "symbol list"
+  assume gs: "length gs = k"
+  have tc: "turing_command k (length M) G (M ! i)"
+    using turing_machine_def assms(2,3) by simp
+  show "length ([!!] (M' ! i) gs) = length gs"
+    using gs turing_commandD(1)[OF tc] assms(1,3) relocate by simp
+  show "(M' ! i) gs [.] 0 = gs ! 0" if "k > 0"
+    using gs turing_commandD(3)[OF tc] assms(1,3) relocate that by simp
+  show "[*] ((M' ! i) gs) \<le> length M + q"
+    using gs turing_commandD(4)[OF tc] assms(1,3) relocate by simp
+  show "(\<And>i. i < length gs \<Longrightarrow> gs ! i < G) \<Longrightarrow>
+       j < length gs \<Longrightarrow> (M' ! i) gs [.] j < G" for j
+    using gs turing_commandD(2)[OF tc] assms(1,3) relocate by simp
+qed
+
+lemma length_relocate: "length (relocate q M) = length M"
+  by (simp add: relocate_def)
+
+lemma relocate_jump_targets:
+  assumes "turing_machine k G M"
+    and "M' = relocate q M"
+    and "i < length M"
+    and "length rs = k"
+  shows "fst ((M' ! i) rs) \<le> length M + q"
+  using turing_machine_def relocate_def assms relocate
+  by (metis turing_commandD(4) diff_add_inverse2 fst_conv le_diff_conv nth_mem)
+
+lemma relocate_zero: "relocate 0 M = M"
+  unfolding relocate_def relocate_cmd_def by simp
+
+
+subsection \<open>Sequences\<close>
+
+text \<open>
+To execute two Turing machines sequentially we concatenate the two machines,
+relocating the second one by the length of the first one. In this way the
+halting state of the first machine becomes the start state of the second
+machine.
+\<close>
+
+definition turing_machine_sequential :: "machine \<Rightarrow> machine \<Rightarrow> machine" (infixl ";;" 55) where
+  "M1 ;; M2 \<equiv> M1 @ (relocate (length M1) M2)"
+
+text \<open>
+If the number of tapes and the alphabet size match, the concatenation of two
+Turing machines is again a Turing machine.
+\<close>
+
+lemma turing_machine_sequential_turing_machine [intro, simp]:
+  assumes "turing_machine k G M1" and "turing_machine k G M2"
+  shows "turing_machine k G (M1 ;; M2)" (is "turing_machine k G ?M")
+proof
+  show 1: "k \<ge> 2"
+    using assms(1) turing_machine_def by simp
+  show 2: "G \<ge> 4"
+    using assms(1) turing_machine_def by simp
+  have len: "length ?M = length M1 + length M2"
+    using relocate_def turing_machine_sequential_def by simp
+  show 3: "turing_command k (length ?M) G (?M ! i)" if "i < length ?M" for i
+  proof (cases "i < length M1")
+    case True
+    then show ?thesis
+      using turing_machineD[OF assms(1)] turing_machine_sequential_def len turing_command_mono
+      by (metis (no_types, lifting) le_add1 nth_append)
+  next
+    case False
+    then have "i - (length M1) < length M2" (is "?i < length M2")
+      using False that len by simp
+    then have "turing_command k (length ?M) G ((relocate (length M1) M2) ! ?i)"
+      using assms(2) turing_command_relocate len by (simp add: add.commute)
+    moreover have "?M ! i = (relocate (length M1) M2) ! ?i"
+      using False by (simp add: nth_append turing_machine_sequential_def)
+    ultimately show ?thesis
+      by simp
+  qed
+qed
+
+lemma turing_machine_sequential_empty: "turing_machine_sequential [] M = M"
+  unfolding turing_machine_sequential_def using relocate_zero by simp
+
+lemma turing_machine_sequential_nth:
+  assumes "M = M1 ;; M2" and "p < length M2"
+  shows "M ! (p + length M1) = relocate_cmd (length M1) (M2 ! p)"
+proof-
+  let ?r = "relocate (length M1) M2"
+  have "M = M1 @ ?r"
+    using assms(1) turing_machine_sequential_def by simp
+  then have "M ! (p + length M1) = ?r ! p"
+    by (simp add: nth_append)
+  then show ?thesis
+    using assms(2) relocate_def by simp
+qed
+
+lemma turing_machine_sequential_nth':
+  assumes "M = M1 ;; M2" and "length M1 \<le> q" and "q < length M"
+  shows "M ! q = relocate_cmd (length M1) (M2 ! (q - length M1))"
+  using assms turing_machine_sequential_nth length_relocate turing_machine_sequential_def
+  by (metis (no_types, lifting) add.assoc diff_add length_append less_add_eq_less)
+
+lemma "length_turing_machine_sequential":
+  "length (turing_machine_sequential M1 M2) = length M1 + length M2"
+  using turing_machine_sequential_def relocate_def by simp
+
+lemma exe_relocate:
+  "exe (M1 ;; M2) (cfg <+=> length M1) = (exe M2 cfg) <+=> length M1 "
+  using sem_relocate_cmd sem_state_indep exe_def turing_machine_sequential_nth length_turing_machine_sequential
+  by (smt (verit, ccfv_SIG) add.commute diff_add_inverse2 fst_conv le_add2 less_diff_conv2 snd_conv)
+
+lemma execute_pre_append:
+  assumes "halts M1 cfg" and "fst cfg = 0" and "t \<le> running_time M1 cfg "
+  shows "execute ((M0 ;; M1) @ M2) (cfg <+=> length M0) t = (execute M1 cfg t) <+=> length M0"
+  using assms(3)
+proof (induction t)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc t)
+  let ?l0 = "length M0"
+  let ?M = "(M0 ;; M1) @ M2"
+  let ?cfg_t = "execute ?M (cfg <+=> ?l0) t"
+  let ?cfg1_t = "execute M1 cfg t"
+  let ?cmd1 = "M1 ! (fst ?cfg1_t)"
+  let ?cmd = "?M ! (fst ?cfg_t)"
+  have *: "?cfg1_t <+=> ?l0 = ?cfg_t"
+    using Suc by simp
+  then have "fst (?cfg1_t <+=> ?l0) = fst ?cfg_t"
+    by simp
+  then have 2: "fst ?cfg1_t + ?l0 = fst ?cfg_t"
+    by simp
+  from * have sndeq: "snd ?cfg1_t = snd ?cfg_t"
+    by (metis snd_conv)
+  have "fst (execute M1 cfg t) \<le> length M1"
+    using halts_impl_le_length assms(1) halts_def by blast
+  moreover have "fst ?cfg1_t \<noteq> length M1"
+    using Suc.prems running_time_def wellorder_Least_lemma(2) by fastforce
+  ultimately have 1: "fst ?cfg1_t < length M1"
+    by simp
+  with 2 have "relocate_cmd ?l0 ?cmd1 = (M0 ;; M1) ! (fst ?cfg1_t + ?l0)"
+    by (metis turing_machine_sequential_nth)
+  then have "relocate_cmd ?l0 ?cmd1 = ?M ! (fst ?cfg1_t + ?l0)"
+    by (simp add: "1" nth_append length_turing_machine_sequential)
+  then have 3: "relocate_cmd ?l0 ?cmd1 = ?cmd"
+    using 2 by simp
+  with 1 have "execute M1 cfg (Suc t) = sem ?cmd1 ?cfg1_t"
+    by (simp add: exe_def)
+  then have "(execute M1 cfg (Suc t)) <+=> ?l0 = (sem ?cmd1 ?cfg1_t) <+=> ?l0"
+    by simp
+  then have "(execute M1 cfg (Suc t)) <+=> ?l0 = (sem (relocate_cmd ?l0 ?cmd1) ?cfg1_t)"
+    using sem_relocate_cmd by simp
+  then have rhs: "(execute M1 cfg (Suc t)) <+=> ?l0 = sem ?cmd ?cfg1_t"
+    using 3 by simp
+  have "execute ?M (cfg <+=> ?l0) (Suc t) = exe ?M ?cfg_t"
+    by simp
+  moreover have "fst ?cfg_t < length ?M"
+    using 1 2 by (simp add: length_turing_machine_sequential)
+  ultimately have lhs: "execute ?M (cfg <+=> ?l0) (Suc t) = sem ?cmd ?cfg_t"
+    by (simp add: exe_lt_length)
+  have "sem ?cmd ?cfg_t = sem ?cmd ?cfg1_t"
+    using sem_state_indep sndeq by fastforce
+  with lhs rhs show ?case
+    by simp
+qed
+
+lemma transits_pre_append':
+  assumes "transforms M1 tps t tps'"
+  shows "transits ((M0 ;; M1) @ M2) (length M0, tps) t (length M0 + length M1, tps')"
+proof-
+  let ?rt = "running_time M1 (0, tps)"
+  let ?M = "(M0 ;; M1) @ M2"
+  have "?rt \<le> t"
+    using assms transforms_running_time by simp
+  have "fst (execute M1 (0, tps) t) = length M1"
+    using assms(1) execute_after_halting_ge halting_config_def transforms_halting_config transforms_running_time
+    by (metis (no_types, opaque_lifting) fst_conv)
+  then have *: "halts M1 (0, tps)"
+    using halts_def by auto
+  have "transits M1 (0, tps) t (length M1, tps')"
+    using assms(1) transits_def by (simp add: transforms_def)
+  then have "execute M1 (0, tps) ?rt = (length M1, tps')"
+    using assms(1) halting_config_def transforms_halting_config by auto
+  moreover have "execute ?M (length M0, tps) ?rt = (execute M1 (0, tps) ?rt) <+=> length M0"
+    using execute_pre_append * by auto
+  ultimately have "execute ?M (length M0, tps) ?rt = (length M1, tps') <+=> length M0"
+    by simp
+  then have "execute ?M (length M0, tps) ?rt = (length M0 + length M1, tps')"
+    by simp
+  then show ?thesis
+    using \<open>?rt \<le> t\<close> transits_def by blast
+qed
+
+corollary transits_prepend:
+  assumes "transforms M1 tps t tps'"
+  shows "transits (M0 ;; M1) (length M0, tps) t (length M0 + length M1, tps')"
+  using transits_pre_append' assms by (metis append_Nil2)
+
+corollary transits_append:
+  assumes "transforms M1 tps t tps'"
+  shows "transits (M1 @ M2) (0, tps) t (length M1, tps')"
+  using transits_pre_append' turing_machine_sequential_empty assms
+  by (metis gen_length_def length_code list.size(3))
+
+corollary execute_append:
+  assumes "fst cfg = 0" and "halts M1 cfg" and "t \<le> running_time M1 cfg"
+  shows "execute (M1 @ M2) cfg t = execute M1 cfg t"
+  using assms execute_pre_append turing_machine_sequential_empty
+  by (metis add.right_neutral list.size(3) prod.collapse)
+
+lemma execute_sequential:
+  assumes "execute M1 cfg1 t1 = cfg1'"
+    and "fst cfg1 = 0"
+    and "t1 = running_time M1 cfg1"
+    and "execute M2 cfg2 t2 = cfg2'"
+    and "cfg1' = cfg2 <+=> length M1"
+    and "halts M1 cfg1"
+  shows "execute (M1 ;; M2) cfg1 (t1 + t2) = cfg2' <+=> length M1"
+proof-
+  let ?M = "M1 ;; M2"
+  have 1: "execute ?M cfg1 t1 = cfg1'"
+    using execute_append assms turing_machine_sequential_def by simp
+  then have 2: "execute ?M cfg1 (t1 + t2) = execute ?M cfg1' t2"
+    using execute_additive by simp
+  have "execute M2 cfg2 t2 = cfg2' \<Longrightarrow> execute ?M cfg1' t2 = cfg2' <+=> length M1" for t2
+  proof (induction t2 arbitrary: cfg2')
+    case 0
+    then show ?case
+      using 1 assms(5) by simp
+  next
+    case (Suc t2)
+    let ?cfg = "execute M2 cfg2 t2"
+    have "execute ?M cfg1' (Suc t2) = exe ?M (execute ?M cfg1' t2)"
+      by simp
+    then have "execute ?M cfg1' (Suc t2) = exe ?M (?cfg <+=> length M1)"
+      using Suc by simp
+    moreover have "execute M2 cfg2 (Suc t2) = exe M2 ?cfg"
+      by simp
+    ultimately show ?case
+      using exe_relocate Suc.prems by metis
+  qed
+  then show ?thesis
+    using assms(4) 2 by simp
+qed
+
+text \<open>
+The semantics and running time of the @{text ";;"} operator:
+\<close>
+
+lemma transforms_turing_machine_sequential:
+  assumes "transforms M1 tps1 t1 tps2" and "transforms M2 tps2 t2 tps3"
+  shows "transforms (M1 ;; M2) tps1 (t1 + t2) tps3"
+proof-
+  let ?M = "M1 ;; M2"
+  let ?cfg1 = "(0, tps1)"
+  let ?cfg1' = "(length M1, tps2)"
+  let ?t1 = "running_time M1 ?cfg1"
+  let ?cfg2 = "(0, tps2)"
+  let ?cfg2' = "(length M2, tps3)"
+  let ?t2 = "running_time M2 ?cfg2"
+  have "fst (execute M1 ?cfg1 ?t1) = length M1"
+    using assms(1) halting_config_def transforms_halting_config by (metis fst_conv)
+  then have *: "halts M1 ?cfg1"
+    using halts_def by auto
+  have "execute M1 ?cfg1 ?t1 = ?cfg1'"
+    using assms(1) halting_config_def transforms_halting_config by auto
+  moreover have "fst ?cfg1 = 0"
+    by simp
+  moreover have "execute M2 ?cfg2 ?t2 = ?cfg2'"
+    using assms(2) halting_config_def transforms_halting_config by auto
+  moreover have "?cfg1' = ?cfg2 <+=> length M1"
+    by simp
+  ultimately have "execute ?M ?cfg1 (?t1 + ?t2) = ?cfg2' <+=> length M1"
+    using execute_sequential * by blast
+  then have "execute ?M ?cfg1 (?t1 + ?t2) = (length ?M, tps3)"
+    by (simp add: length_turing_machine_sequential)
+  then have "transits ?M ?cfg1 (?t1 + ?t2) (length ?M, tps3)"
+    using transits_def by blast
+  moreover have "?t1 + ?t2 \<le> t1 + t2"
+    using add_le_mono assms(1,2) transforms_running_time by blast
+  ultimately have "transits ?M ?cfg1 (t1 + t2) (length ?M, tps3)"
+    using transits_monotone by simp
+  then show ?thesis
+    using transforms_def by simp
+qed
+
+corollary transforms_tm_sequentialI:
+  assumes "transforms M1 tps1 t1 tps2" and "transforms M2 tps2 t2 tps3" and "t12 = t1 + t2"
+  shows "transforms (M1 ;; M2) tps1 t12 tps3"
+  using assms transforms_turing_machine_sequential by simp
+
+
+subsection \<open>Branches\<close>
+
+text \<open>
+A branching Turing machine consists of a condition and two Turing machines, one
+for each of the branches. The condition can be any predicate over the list of
+symbols read from the tapes. The branching TM thus needs to perform conditional
+jumps, for which we will have the following command:
+\<close>
+
+definition cmd_jump :: "(symbol list \<Rightarrow> bool) \<Rightarrow> state \<Rightarrow> state \<Rightarrow> command" where
+  "cmd_jump cond q1 q2 rs \<equiv> (if cond rs then q1 else q2, map (\<lambda>r. (r, Stay)) rs)"
+
+lemma turing_command_jump_1:
+  assumes "q1 \<le> q2" and "k > 0"
+  shows "turing_command k q2 G (cmd_jump cond q1 q2)"
+  using assms cmd_jump_def turing_commandI by simp
+
+lemma turing_command_jump_2:
+  assumes "q2 \<le> q1" and "k > 0"
+  shows "turing_command k q1 G (cmd_jump cond q1 q2)"
+  using assms cmd_jump_def turing_commandI by simp
+
+lemma sem_jump_snd: "snd (sem (cmd_jump cond q1 q2) cfg) = snd cfg"
+proof-
+  let ?k = "||cfg||"
+  let ?cmd = "cmd_jump cond q1 q2"
+  let ?cfg' = "sem ?cmd cfg"
+  let ?rs = "read (snd cfg)"
+  have 1: "proper_command ?k ?cmd"
+    using cmd_jump_def by simp
+  then have len: "||?cfg'|| = ||cfg||"
+    using sem_num_tapes_raw by simp
+  have "snd ?cfg' ! i = act (snd (?cmd ?rs) ! i) (snd cfg ! i)" if "i < ||cfg||" for i
+    using sem_snd 1 that by simp
+  moreover have "snd (?cmd ?rs) ! i = (?rs!i, Stay)" if "i < ||cfg||" for i
+    using cmd_jump_def by (simp add: read_length that)
+  ultimately have "snd ?cfg' ! i = act (?rs ! i, Stay) (snd cfg ! i)" if "i < ||cfg||" for i
+    using that by simp
+  then have "snd ?cfg' ! i = snd cfg ! i" if "i < ||cfg||" for i
+    using that act_Stay by simp
+  then show "snd ?cfg' = snd cfg"
+    using len nth_equalityI by force
+qed
+
+lemma sem_jump_fst1:
+  assumes "cond (read (snd cfg))"
+  shows "fst (sem (cmd_jump cond q1 q2) cfg) = q1"
+  using cmd_jump_def sem assms by simp
+
+lemma sem_jump_fst2:
+  assumes "\<not> cond (read (snd cfg))"
+  shows "fst (sem (cmd_jump cond q1 q2) cfg) = q2"
+  using cmd_jump_def sem assms by simp
+
+lemma sem_jump:
+  "sem (cmd_jump cond q1 q2) cfg = (if cond (config_read cfg) then q1 else q2, snd cfg)"
+  using sem_def sem_jump_snd cmd_jump_def by simp
+
+lemma transits_jump:
+  "transits [cmd_jump cond q1 q2] (0, tps) 1 (if cond (read tps) then q1 else q2, tps)"
+  using transits_def sem_jump exe_def by auto
+
+definition turing_machine_branch :: "(symbol list \<Rightarrow> bool) \<Rightarrow> machine \<Rightarrow> machine \<Rightarrow> machine"
+  ("IF _ THEN _ ELSE _ ENDIF" 60)
+where
+  "IF cond THEN M1 ELSE M2 ENDIF \<equiv>
+    [cmd_jump cond 1 (length M1 + 2)] @
+    (relocate 1 M1) @
+    [cmd_jump (\<lambda>_. True) (length M1 + length M2 + 2) 0] @
+    (relocate (length M1 + 2) M2)"
+
+lemma turing_machine_branch_len:
+  "length (IF cond THEN M1 ELSE M2 ENDIF) = length M1 + length M2 + 2"
+  unfolding turing_machine_branch_def by (simp add: relocate_def)
+
+text \<open>
+If the Turing machines for both branches have the same number of tapes and
+the same alphabet size, the branching machine is a Turing machine, too.
+\<close>
+
+lemma turing_machine_branch_turing_machine:
+  assumes "turing_machine k G M1" and "turing_machine k G M2"
+  shows "turing_machine k G (IF cond THEN M1 ELSE M2 ENDIF)"
+    (is "turing_machine _ _ ?M")
+proof
+  show "k \<ge> 2"
+    using assms(2) turing_machine_def by simp
+  show "G \<ge> 4"
+    using assms(2) turing_machine_def by simp
+  let ?C1 = "[cmd_jump cond 1 (length M1 + 2)]"
+  let ?C2 = "relocate 1 M1"
+  let ?C3 = "[cmd_jump (\<lambda>_. True) (length M1 + length M2 + 2) 0]"
+  let ?C4 = "relocate (length M1 + 2) M2"
+  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
+    using turing_machine_branch_def by simp
+  have len: "length ?M = length M1 + length M2 + 2"
+    using turing_machine_branch_len by simp
+  have "k > 0"
+    using `k \<ge> 2` by simp
+  show "turing_command k (length ?M) G (?M ! i)" if "i < length ?M" for i
+  proof -
+    consider
+        "i < length ?C1"
+      | "length ?C1 \<le> i \<and> i < length (?C1 @ ?C2)"
+      | "length (?C1 @ ?C2) \<le> i \<and> i < length (?C1 @ ?C2 @ ?C3)"
+      | "length (?C1 @ ?C2 @ ?C3) \<le> i \<and> i < length ?M"
+      using `i < length ?M` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "turing_command k (length M1 + 2) G (?C1 ! i)"
+        using turing_command_jump_1 `k > 0` by simp
+      then have "turing_command k (length ?M) G (?C1 ! i)"
+        using turing_command_mono len by simp
+      then show ?thesis
+        using parts 1 by simp
+    next
+      case 2
+      then have "i - length ?C1 < length ?C2"
+        by auto
+      then have "turing_command k (length M1 + 1) G (?C2 ! (i - length ?C1))"
+        using turing_command_relocate assms length_relocate by metis
+      then have "turing_command k (length ?M) G (?C2 ! (i - length ?C1))"
+        using turing_command_mono len by simp
+      then have "turing_command k (length ?M) G ((?C1 @ ?C2) ! i)"
+        using 2 by simp
+      then show ?thesis
+        using parts 2 by (metis (no_types, lifting) append.assoc nth_append)
+    next
+      case 3
+      then have "turing_command k (length ?M) G (?C3 ! (i - length (?C1 @ ?C2)))"
+        using turing_command_jump_2 len `k > 0` by simp
+      then have "turing_command k (length ?M) G ((?C1 @ ?C2 @ ?C3) ! i)"
+        using 3 by (metis (no_types, lifting) append.assoc diff_is_0_eq' less_numeral_extra(3) nth_append zero_less_diff)
+      then show ?thesis
+        using parts 3 by (smt (verit, best) append.assoc nth_append)
+    next
+      case 4
+      then have "i - length (?C1 @ ?C2 @ ?C3) < length ?C4"
+        by (simp add: len less_diff_conv2 length_relocate)
+      then have "turing_command k (length ?M) G (?C4 ! (i - length (?C1 @ ?C2 @ ?C3)))"
+        using turing_command_relocate assms by (smt (verit, ccfv_SIG) add.assoc add.commute len length_relocate)
+      then show ?thesis
+        using parts 4 by (metis (no_types, lifting) append.assoc le_simps(3) not_less_eq_eq nth_append)
+    qed
+  qed
+qed
+
+text \<open>
+If the condition is true, the branching TM executes $M_1$ and requires two extra
+steps: one for evaluating the condition and one for the unconditional jump to
+the halting state.
+\<close>
+
+lemma transforms_branch_true:
+  assumes "transforms M1 tps t tps'" and "cond (read tps)"
+  shows "transforms (IF cond THEN M1 ELSE M2 ENDIF) tps (t + 2) tps'"
+    (is "transforms ?M _ _ _")
+proof-
+  let ?C1 = "[cmd_jump cond 1 (length M1 + 2)]"
+  let ?C2 = "relocate 1 M1"
+  let ?C3 = "[cmd_jump (\<lambda>_. True) (length M1 + length M2 + 2) 0]"
+  let ?C4 = "relocate (length M1 + 2) M2"
+  let ?C34 = "?C3 @ ?C4"
+  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
+    using turing_machine_branch_def by simp
+  then have "?M = ?C1 @ ?C2 @ ?C34"
+    by simp
+  moreover have "?C1 @ ?C2 = ?C1 ;; M1"
+    using turing_machine_sequential_def by simp
+  ultimately have parts2: "?M = (?C1 ;; M1) @ ?C34"
+    by simp
+  have "execute ?M (0, tps) 1 = exe ?M (0, tps)"
+    by simp
+  also have "... = sem (?M ! 0) (0, tps)"
+    using exe_def by (simp add: turing_machine_branch_len)
+  also have "... = sem (?C1 ! 0) (0, tps)"
+    by (simp add: parts)
+  also have "... = sem (cmd_jump cond 1 (length M1 + 2)) (0, tps)"
+    by simp
+  also have "... = (1, tps)"
+    using sem_jump by (simp add: assms(2))
+  finally have "execute ?M (0, tps) 1 = (1, tps)" .
+  then have phase1: "transits ?M (0, tps) 1 (1, tps)"
+    using transits_def by auto
+  have "length ?C1 = 1"
+    by simp
+  moreover have "transits ((?C1 ;; M1) @ ?C34) (length ?C1, tps) t (length ?C1 + length M1, tps')"
+    using transits_pre_append' assms by blast
+  ultimately have "transits ?M (1, tps) t (1 + length M1, tps')"
+    using parts2 by simp
+  with phase1 have "transits ?M (0, tps) (t + 1) (1 + length M1, tps')"
+    using transits_additive by fastforce
+  then have phase2: "transits ?M (0, tps) (t + 1) (length (?C1 @ ?C2), tps')"
+    by (simp add: relocate_def)
+  let ?cfg = "(length (?C1 @ ?C2), tps')"
+  have *: "?M ! (length (?C1 @ ?C2)) = ?C3 ! 0"
+    using parts by simp
+  then have "execute ?M ?cfg 1 = exe ?M ?cfg"
+    by simp
+  also have "... = sem (cmd_jump (\<lambda>_. True) (length M1 + length M2 + 2) 0) ?cfg"
+    using exe_def relocate_def turing_machine_branch_len * by (simp add: Suc_le_lessD)
+  also have "... = (length M1 + length M2 + 2, snd ?cfg)"
+    using sem_jump by simp
+  also have "... = (length ?M, tps')"
+    by (simp add: turing_machine_branch_len)
+  finally have "execute ?M ?cfg 1 = (length ?M, tps')" .
+  then have "transits ?M ?cfg 1 (length ?M, tps')"
+    using transits_def by auto
+  with phase2 have "transits ?M (0, tps) (t + 2) (length ?M, tps')"
+    using transits_additive by fastforce
+  then show ?thesis
+    by (simp add: transforms_def)
+qed
+
+text \<open>
+If the condition is false, the branching TM executes $M_2$ and requires one
+extra step to evaluate the condition.
+\<close>
+
+lemma transforms_branch_false:
+  assumes "transforms M2 tps t tps'" and "\<not> cond (read tps)"
+  shows "transforms (IF cond THEN M1 ELSE M2 ENDIF) tps (t + 1) tps'"
+    (is "transforms ?M _ _ _")
+proof-
+  let ?C1 = "[cmd_jump cond 1 (length M1 + 2)]"
+  let ?C2 = "relocate 1 M1"
+  let ?C3 = "[cmd_jump (\<lambda>_. True) (length M1 + length M2 + 2) 0]"
+  let ?C4 = "relocate (length M1 + 2) M2"
+  let ?C123 = "?C1 @ ?C2 @ ?C3"
+  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
+    using turing_machine_branch_def by simp
+  moreover have len123: "length ?C123 = length M1 + 2"
+    by (simp add: length_relocate)
+  ultimately have seq: "?M = ?C123 ;; M2"
+    by (simp add: turing_machine_sequential_def)
+  have "execute ?M (0, tps) 1 = exe ?M (0, tps)"
+    by simp
+  also have "... = sem (?M ! 0) (0, tps)"
+    using exe_def by (simp add: turing_machine_branch_len)
+  also have "... = sem (cmd_jump cond 1 (length M1 + 2)) (0, tps)"
+    by (simp add: parts)
+  also have "... = (length M1 + 2, tps)"
+    using assms(2) sem_jump by simp
+  also have "... = (length ?C123, tps)"
+    using len123 by simp
+  finally have "execute ?M (0, tps) 1 = (length ?C123, tps)" .
+  then have phase1: "transits ?M (0, tps) 1 (length ?C123, tps)"
+    using transits_def by blast
+  have "?M ! (length ?C123) = ?C4 ! 0"
+    by (simp add: nth_append parts length_relocate)
+  have "transits (?C123 ;; M2) (length ?C123, tps) t (length ?C123 + length M2, tps')"
+    using transits_prepend assms by blast
+  then have "transits ?M (length ?C123, tps) t (length ?M, tps')"
+    by (simp add: seq length_turing_machine_sequential)
+  with phase1 have "transits ?M (0, tps) (t + 1) (length ?M, tps')"
+    using transits_additive by fastforce
+  then show ?thesis
+    using transforms_def by simp
+qed
+
+text \<open>
+The behavior and running time of the branching Turing machine:
+\<close>
+
+lemma transforms_branch_full:
+  assumes "c \<Longrightarrow> transforms M1 tps tT tpsT"
+    and "\<not> c \<Longrightarrow> transforms M2 tps tF tpsF"
+    and "c \<Longrightarrow> tT + 2 \<le> t"
+    and "\<not> c \<Longrightarrow> tF + 1 \<le> t"
+    and "c = cond (read tps)"
+    and "tps' = (if c then tpsT else tpsF)"
+  shows "transforms (IF cond THEN M1 ELSE M2 ENDIF) tps t tps'"
+proof -
+  have "transforms (IF cond THEN M1 ELSE M2 ENDIF)
+      tps
+      (if c then tT + 2 else tF + 1)
+      (if c then tpsT else tpsF)"
+    using assms(1,2,5) transforms_branch_true transforms_branch_false by simp
+  moreover have "(if c then tT + 2 else tF + 1) \<le> t"
+    using assms(3,4) by simp
+  ultimately show ?thesis
+    using transforms_monotone assms(6) by presburger
+qed
+
+corollary transforms_branchI:
+  assumes "cond (read tps) \<Longrightarrow> transforms M1 tps tT tpsT"
+    and "\<not> cond (read tps) \<Longrightarrow> transforms M2 tps tF tpsF"
+    and "cond (read tps) \<Longrightarrow> tT + 2 \<le> t"
+    and "\<not> cond (read tps) \<Longrightarrow> tF + 1 \<le> t"
+    and "cond (read tps) \<Longrightarrow> tps' = tpsT"
+    and "\<not> cond (read tps) \<Longrightarrow> tps' = tpsF"
+  shows "transforms (IF cond THEN M1 ELSE M2 ENDIF) tps t tps'"
+  using transforms_branch_full assms by (smt (z3))
+
+
+subsection \<open>Loops\<close>
+
+text \<open>
+The loops are while loops consisting of a head and a body. The body is a Turing
+machine that is executed in every iteration as long as the condition in the
+head of the loop evaluates to true. The condition is of the same form as in
+branching TMs, namely a predicate over the symbols read from the tapes.
+Sometimes this is not expressive enough, and so we allow a Turing machine as
+part of the loop head that is run prior to evaluating the condition. In most
+cases, however, this TM is empty.
+\<close>
+
+definition turing_machine_loop :: "machine \<Rightarrow> (symbol list \<Rightarrow> bool) \<Rightarrow> machine \<Rightarrow> machine"
+  ("WHILE _ ; _ DO _ DONE" 60)
+where
+  "WHILE M1 ; cond DO M2 DONE \<equiv>
+    M1 @
+    [cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)] @
+    (relocate (length M1 + 1) M2) @
+    [cmd_jump (\<lambda>_. True) 0 0]"
+
+text \<open>
+Intuitively the Turing machine @{term "WHILE M1 ; cond DO M2 DONE"}
+first executes @{term M1} and then checks the condition @{term cond}. If it is
+true, it executes @{term M2} and jumps back to the start state; otherwise it
+jumps to the halting state.
+\<close>
+
+lemma turing_machine_loop_len:
+  "length (WHILE M1 ; cond DO M2 DONE) = length M1 + length M2 + 2"
+  unfolding turing_machine_loop_def by (simp add: relocate_def)
+
+text \<open>
+If both Turing machines have the same number of tapes and alphabet size,
+then so does the looping Turing machine.
+\<close>
+
+lemma turing_machine_loop_turing_machine:
+  assumes "turing_machine k G M1" and "turing_machine k G M2"
+  shows "turing_machine k G (WHILE M1 ; cond DO M2 DONE)"
+    (is "turing_machine _ _ ?M")
+proof
+  show 1: "k \<ge> 2"
+    using assms(1) turing_machine_def by simp
+  show 2: "G \<ge> 4"
+    using assms(1) turing_machine_def by simp
+  let ?C1 = "M1"
+  let ?C2 = "[cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)]"
+  let ?C3 = "relocate (length M1 + 1) M2"
+  let ?C4 = "[cmd_jump (\<lambda>_. True) 0 0]"
+  let ?C34 = "?C3 @ ?C4"
+  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
+    using turing_machine_loop_def by simp
+  have len: "length ?M = length M1 + length M2 + 2"
+    using turing_machine_loop_len by simp
+  have "k > 0"
+    using `k \<ge> 2` by simp
+
+  show "turing_command k (length ?M) G (?M ! i)" if "i < length ?M" for i
+  proof -
+    consider
+        "i < length ?C1"
+      | "length ?C1 \<le> i \<and> i < length (?C1 @ ?C2)"
+      | "length (?C1 @ ?C2) \<le> i \<and> i < length (?C1 @ ?C2 @ ?C3)"
+      | "length (?C1 @ ?C2 @ ?C3) \<le> i \<and> i < length ?M"
+      using `i < length ?M` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "turing_command k (length M1) G (?C1 ! i)"
+        using turing_machineD(3) assms by simp
+      then have "turing_command k (length ?M) G (?C1 ! i)"
+        using turing_command_mono len by simp
+      then show ?thesis
+        using parts 1 by (simp add: nth_append)
+    next
+      case 2
+      then have "turing_command k (length M1 + length M2 + 2) G (?C2 ! (i - length ?C1))"
+        using turing_command_jump_1 `0 < k` by simp
+      then have "turing_command k (length ?M) G (?C2 ! (i - length ?C1))"
+        using len by simp
+      then have "turing_command k (length ?M) G ((?C1 @ ?C2) ! i)"
+        using "2" le_add_diff_inverse by (simp add: nth_append)
+      then show ?thesis
+        using 2 parts by (simp add: nth_append)
+    next
+      case 3
+      then have "turing_command k (length M2 + (length M1 + 1)) G (?C3 ! (i - length (?C1 @ ?C2)))"
+        using turing_command_relocate length_relocate assms(2)
+        by (smt (verit, best) add.commute add.left_commute add_less_cancel_left le_add_diff_inverse length_append)
+      then have "turing_command k (length ?M) G (?C3 ! (i - length (?C1 @ ?C2)))"
+        using turing_command_mono len by simp
+      then have "turing_command k (length ?M) G ((?C1 @ ?C2 @ ?C3) ! i)"
+        using 3 by (simp add: nth_append)
+      then show ?thesis
+        using parts 3 by (smt (verit) append.assoc nth_append)
+    next
+      case 4
+      then have "turing_command k 0 G (?C4 ! (i - length (?C1 @ ?C2 @ ?C3)))"
+        using turing_command_jump_1 `0 < k` len length_relocate by simp
+      then have "turing_command k (length ?M) G (?C4 ! (i - length (?C1 @ ?C2 @ ?C3)))"
+        using turing_command_mono by blast
+      then show ?thesis
+        using parts 4 by (metis (no_types, lifting) append.assoc nth_append verit_comp_simplify1(3))
+    qed
+  qed
+qed
+
+lemma transits_turing_machine_loop_cond_false:
+  assumes "transforms M1 tps t1 tps'" and "\<not> cond (read tps')"
+  shows "transits
+            (WHILE M1 ; cond DO M2 DONE)
+            (0, tps)
+            (t1 + 1)
+            (length M1 + length M2 + 2, tps')"
+    (is "transits ?M _ _ _")
+proof-
+  let ?C1 = "M1"
+  let ?C2 = "[cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)]"
+  let ?C3 = "relocate (length M1 + 1) M2"
+  let ?C4 = "[cmd_jump (\<lambda>_. True) 0 0]"
+  let ?C34 = "?C3 @ ?C4"
+  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
+    using turing_machine_loop_def by simp
+  then have "?M = ?C1 @ (?C2 @ ?C3 @ ?C4)"
+    by simp
+  then have "transits ?M (0, tps) t1 (length ?C1, tps')"
+    using assms transits_append by simp
+  moreover have "transits ?M (length M1, tps') 1 (length M1 + length M2 + 2, tps')"
+  proof-
+    have *: "?M ! (length ?C1) = cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)"
+      using turing_machine_loop_def by simp
+    have "execute ?M (length ?C1, tps') 1 = exe ?M (length ?C1, tps')"
+      by simp
+    also have "... = sem (?M ! (length ?C1)) (length ?C1, tps')"
+      by (simp add: exe_lt_length turing_machine_loop_len)
+    also have "... = sem (cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)) (length ?C1, tps')"
+      using * by simp
+    also have "... = (length M1 + length M2 + 2, tps')"
+      using sem_jump assms(2) by simp
+    finally have "execute ?M (length ?C1, tps') 1 = (length M1 + length M2 + 2, tps')" .
+    then show ?thesis
+      using transits_def by auto
+  qed
+  ultimately show "transits ?M (0, tps) (t1 + 1) (length M1 + length M2 + 2, tps')"
+    using transits_additive by blast
+qed
+
+lemma transits_turing_machine_loop_cond_true:
+  assumes "transforms M1 tps t1 tps'"
+    and "transforms M2 tps' t2 tps''"
+    and "cond (read tps')"
+  shows "transits
+            (WHILE M1 ; cond DO M2 DONE)
+            (0, tps)
+            (t1 + t2 + 2)
+            (0, tps'')"
+    (is "transits ?M _ _ _")
+proof-
+  let ?C1 = "M1"
+  let ?C2 = "[cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)]"
+  let ?C3 = "relocate (length M1 + 1) M2"
+  let ?C4 = "[cmd_jump (\<lambda>_. True) 0 0]"
+  let ?C34 = "?C3 @ ?C4"
+  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
+    using turing_machine_loop_def by simp
+  then have "?M = ?C1 @ (?C2 @ ?C3 @ ?C4)"
+    by simp
+  then have "transits ?M (0, tps) t1 (length ?C1, tps')"
+    using assms(1,3) transits_append by simp
+  moreover have "transits ?M (length ?C1, tps') 1 (length ?C1 + 1, tps')"
+  proof-
+    have *: "?M ! (length ?C1) = cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)"
+      using turing_machine_loop_def by simp
+    have "execute ?M (length ?C1, tps') 1 = exe ?M (length ?C1, tps')"
+      by simp
+    also have "... = sem (?M ! (length ?C1)) (length ?C1, tps')"
+      by (simp add: exe_lt_length turing_machine_loop_len)
+    also have "... = sem (cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)) (length ?C1, tps')"
+      using * by simp
+    also have "... = (length M1 + 1, tps')"
+      using sem_jump assms(3) by simp
+    finally have "execute ?M (length ?C1, tps') 1 = (length M1 + 1, tps')" .
+    then show ?thesis
+      using transits_def by auto
+  qed
+  ultimately have "transits ?M (0, tps) (t1 + 1) (length M1 + 1, tps')"
+    using transits_additive by blast
+  moreover have "transits ?M (length M1 + 1, tps') t2 (length M1 + length M2 + 1, tps'')"
+  proof-
+    have "?M = ((?C1 @ ?C2) ;; M2) @ ?C4"
+      by (simp add: parts turing_machine_sequential_def)
+    moreover have "length (?C1 @ ?C2) = length M1 + 1"
+      by simp
+    ultimately have "transits ?M (length M1 + 1, tps') t2 (length M1 + 1 + length M2, tps'')"
+      using assms transits_pre_append' by metis
+    then show ?thesis
+      by simp
+  qed
+  ultimately have "transits ?M (0, tps) (t1 + t2 + 1) (length M1 + length M2 + 1, tps'')"
+    using transits_additive by fastforce
+  moreover have "transits ?M (length M1 + length M2 + 1, tps'') 1 (0, tps'')"
+  proof-
+    have *: "?M ! (length M1 + length M2 + 1) = cmd_jump (\<lambda>_. True) 0 0"
+      by (simp add: nth_append parts length_relocate)
+    have "execute ?M (length M1 + length M2 + 1, tps'') 1 = exe ?M (length M1 + length M2 + 1, tps'')"
+      by simp
+    also have "... = sem (?M ! (length M1 + length M2 + 1)) (length M1 + length M2 + 1, tps'')"
+      by (simp add: exe_lt_length turing_machine_loop_len)
+    also have "... = sem (cmd_jump (\<lambda>_. True) 0 0) (length M1 + length M2 + 1, tps'')"
+      using * by simp
+    also have "... = (0, tps'')"
+      using sem_jump by simp
+    finally have "execute ?M (length M1 + length M2 + 1, tps'') 1 = (0, tps'')" .
+    then show ?thesis
+      using transits_def by auto
+  qed
+  ultimately show "transits ?M (0, tps) (t1 + t2 + 2) (0, tps'')"
+    using transits_additive by fastforce
+qed
+
+text \<open>
+In this article we will only encounter while loops that are in fact for loops,
+that is, where the number of iterations is known beforehand. Moreover, using the
+same time bound for every iteration will lead to a good enough upper bound for
+the entire loop.
+
+The @{const transforms} rule for a loop with $m$ iterations where the running
+time of both TMs is bounded by a constant:
+\<close>
+
+lemma transforms_loop_for:
+  fixes m t1 t2 :: nat
+    and M1 M2 :: machine
+    and tps :: "nat \<Rightarrow> tape list"
+    and tps' :: "nat \<Rightarrow> tape list"
+  assumes "\<And>i. i \<le> m \<Longrightarrow> transforms M1 (tps i) t1 (tps' i)"
+  assumes "\<And>i. i < m \<Longrightarrow> transforms M2 (tps' i) t2 (tps (Suc i))"
+    and "\<And>i. i < m \<Longrightarrow> cond (read (tps' i))"
+    and "\<not> cond (read (tps' m))"
+  assumes "ttt \<ge> m * (t1 + t2 + 2) + t1 + 1"
+  shows "transforms
+            (WHILE M1 ; cond DO M2 DONE)
+            (tps 0)
+            ttt
+            (tps' m)"
+proof -
+  define M where "M = WHILE M1 ; cond DO M2 DONE"
+  define t where "t = t1 + t2 + 2"
+  have "transits M (0, tps 0) (i * t) (0, tps i)" if "i \<le> m" for i
+    using that
+  proof (induction i)
+    case 0
+    then show ?case
+      using transits_def by simp
+  next
+    case (Suc i)
+    then have "i < m"
+      by simp
+    then have "transits M (0, tps i) t (0, tps (Suc i))"
+      using M_def t_def assms transits_turing_machine_loop_cond_true by (metis le_eq_less_or_eq)
+    moreover have "transits M (0, tps 0) (i * t) (0, tps i)"
+      using Suc by simp
+    ultimately have "transits M (0, tps 0) (i * t + t) (0, tps (Suc i))"
+      using transits_additive by simp
+    then show ?case
+      by (metis add.commute mult_Suc)
+  qed
+  then have "transits M (0, tps 0) (m * t) (0, tps m)"
+    by simp
+  moreover have "transits M (0, tps m) (t1 + 1) (length M1 + length M2 + 2, tps' m)"
+    using assms(1,4) transits_turing_machine_loop_cond_false M_def by simp
+  ultimately have "transits M (0, tps 0) (m * t + t1 + 1) (length M1 + length M2 + 2, tps' m)"
+    using transits_additive by fastforce
+  then show ?thesis
+    using transforms_def turing_machine_loop_len M_def assms(5) t_def transits_monotone
+    by auto
+qed
+
+text \<open>
+The rule becomes even simpler in the common case in which the Turing machine in
+the loop head is empty.
+\<close>
+
+lemma transforms_loop_simple:
+  fixes m t :: nat
+    and M :: machine
+    and tps :: "nat \<Rightarrow> tape list"
+  assumes "\<And>i. i < m \<Longrightarrow> transforms M (tps i) t (tps (Suc i))"
+    and "\<And>i. i < m \<Longrightarrow> cond (read (tps i))"
+    and "\<not> cond (read (tps m))"
+  assumes "ttt \<ge> m * (t + 2) + 1"
+  shows "transforms
+            (WHILE [] ; cond DO M DONE)
+            (tps 0)
+            ttt
+            (tps m)"
+  using transforms_loop_for[where ?tps'=tps and ?cond=cond and ?t1.0=0, OF _ assms(1) _ assms(3)]
+    transforms_Nil assms(2,4)
+  by simp
+
+
+subsection \<open>A proof method\<close>
+
+text \<open>
+Statements about the behavior and running time of Turing machines, expressed via
+the predicate @{const transforms}, are the most common ones we are going to
+prove. The following proof method applies introduction rules for this
+predicate. These rules are either the ones we proved for the control structures
+(sequence, branching, loop) or the ones describing the semantics of concrete
+Turing machines. The rules of the second kind are collected in the attribute
+@{text transforms_intros}.
+
+Applying such a rule usually leaves three kinds of goals: some simple ones
+requiring only instantiation of schematic variables; one for the equality of two
+tape lists; and one for the time bound. For the last two goals the proof method
+offers parameters @{term tps} and @{term time}, respectively.
+
+I have to admit that most of the details of the proof method were determined by
+trial and error.
+
+\null
+\<close>
+
+named_theorems transforms_intros
+declare transforms_Nil [transforms_intros]
+
+method tform uses tps time declares transforms_intros =
+  (
+   ((rule transforms_tm_sequentialI)+
+    | rule transforms_branchI
+    | rule transforms_loop_simple
+    | rule transforms_loop_for
+    | rule transforms_intros)
+   ; (rule transforms_intros)?
+   ; (simp only:; fail)?
+   ; ((use tps in simp; fail) | (use time in simp; fail))?
+   ; (match conclusion in "left = right" for left right :: "tape list"
+        \<Rightarrow> \<open>(fastforce simp add: tps list_update_swap; fail)\<close>)?
+   ; (match conclusion in "left = right" for left right :: nat
+        \<Rightarrow> \<open>(use time in simp; fail)?\<close>)?
+  )
+
+text \<open>
+These lemmas are sometimes helpful for proving the equality of tape lists:
+\<close>
+
+lemma list_update_swap_less: "i' < i \<Longrightarrow> ys[i := x, i' := x'] = ys[i' := x', i := x]"
+  by (simp add: list_update_swap)
+
+lemma nth_list_update_neq': "j \<noteq> i \<Longrightarrow> xs[i := x] ! j = xs ! j"
+  by simp
+
+end
diff --git a/thys/Cook_Levin/Composing.thy b/thys/Cook_Levin/Composing.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Composing.thy
@@ -0,0 +1,786 @@
+section \<open>Composing functions\label{s:tm-composing}\<close>
+
+theory Composing
+  imports Elementary
+begin
+
+text \<open>
+For a Turing machine $M_1$ computing $f_1$ in time $T_1$ and a TM $M_2$
+computing $f_2$ in time $T_2$ there is a TM $M$ computing $f_2 \circ f_1$ in
+time $O(T_1(n) + \max_{m \le T_1(n)} T_2(m))$. If $T_1$ is monotone
+the time bound is $O(T_1 + T_2 \circ T_1)$; if $T_1$ and $T_2$ are
+polynomially bounded the running-time of $M$ is polynomially bounded, too.
+
+The Turing machines $M_1$ and $M_2$ can have both a different alphabet and
+number of tapes, so generally they cannot be composed by the $;;$ operator. To
+get around this we enlarge the alphabet and prepend and append tapes, so $M$ has
+as many tapes as $M_1$ and $M_2$ combined. The following function returns the
+combined Turing machine $M$.
+
+\null
+\<close>
+
+definition "compose_machines k1 G1 M1 k2 G2 M2 \<equiv>
+  enlarged G1 (append_tapes k1 (k1 + k2) M1) ;;
+  tm_start 1 ;;
+  tm_cp_until 1 k1 {\<box>} ;;
+  tm_erase_cr 1 ;;
+  tm_start k1 ;;
+  prepend_tapes k1 (enlarged G2 M2) ;;
+  tm_cr (k1 + 1) ;;
+  tm_cp_until (k1 + 1) 1 {\<box>}"
+
+locale compose =
+  fixes k1 k2 G1 G2 :: nat
+    and M1 M2 :: machine
+    and T1 T2 :: "nat \<Rightarrow> nat"
+    and f1 f2 :: "string \<Rightarrow> string"
+  assumes tm_M1: "turing_machine k1 G1 M1"
+    and tm_M2: "turing_machine k2 G2 M2"
+    and computes1: "computes_in_time k1 M1 f1 T1"
+    and computes2: "computes_in_time k2 M2 f2 T2"
+begin
+
+definition "tm1 \<equiv> enlarged G1 (append_tapes k1 (k1 + k2) M1)"
+definition "tm2 \<equiv> tm1 ;; tm_start 1"
+definition "tm3 \<equiv> tm2 ;; tm_cp_until 1 k1 {\<box>}"
+definition "tm4 \<equiv> tm3 ;; tm_erase_cr 1"
+definition "tm5 \<equiv> tm4 ;; tm_start k1"
+definition "tm56 \<equiv> prepend_tapes k1 (enlarged G2 M2)"
+definition "tm6 \<equiv> tm5 ;; tm56"
+definition "tm7 \<equiv> tm6 ;; tm_cr (k1 + 1)"
+definition "tm8 \<equiv> tm7 ;; tm_cp_until (k1 + 1) 1 {\<box>}"
+
+definition G :: nat where
+  "G \<equiv> max G1 G2"
+
+lemma G1: "G1 \<le> G" and G2: "G2 \<le> G"
+  using G_def by simp_all
+
+lemma k_ge: "k1 \<ge> 2" "k2 \<ge> 2"
+  using tm_M1 tm_M2 turing_machine_def by simp_all
+
+lemma tm1_tm: "turing_machine (k1 + k2) G tm1"
+  unfolding tm1_def using turing_machine_enlarged append_tapes_tm tm_M1 G1 by simp
+
+lemma tm2_tm: "turing_machine (k1 + k2) G tm2"
+  unfolding tm2_def using tm1_tm tm_start_tm turing_machine_def by blast
+
+lemma tm3_tm: "turing_machine (k1 + k2) G tm3"
+  unfolding tm3_def
+  using tm2_tm tm_cp_until_tm turing_machine_def k_ge turing_machine_sequential_turing_machine
+  by (metis add_leD1 less_add_same_cancel1 less_le_trans less_numeral_extra(1) nat_1_add_1)
+
+lemma tm4_tm: "turing_machine (k1 + k2) G tm4"
+  unfolding tm4_def
+  using tm3_tm tm_erase_cr_tm turing_machine_def turing_machine_sequential_turing_machine
+  by (metis Suc_1 Suc_le_lessD tm_erase_cr_tm zero_less_one)
+
+lemma tm5_tm: "turing_machine (k1 + k2) G tm5"
+  unfolding tm5_def
+  using tm4_tm tm_start_tm turing_machine_def turing_machine_sequential_turing_machine
+  by auto
+
+lemma tm6_tm: "turing_machine (k1 + k2) G tm6"
+  unfolding tm6_def
+  using tm5_tm tm56_def turing_machine_enlarged prepend_tapes_tm tm_M2 G2
+  by simp
+
+lemma tm7_tm: "turing_machine (k1 + k2) G tm7"
+  unfolding tm7_def using tm6_tm tm_cr_tm turing_machine_def by blast
+
+lemma tm8_tm: "turing_machine (k1 + k2) G tm8"
+  unfolding tm8_def
+  using tm7_tm tm_cp_until_tm turing_machine_def turing_machine_sequential_turing_machine k_ge(2)
+  by (metis add.commute add_less_cancel_right add_strict_increasing nat_1_add_1
+    verit_comp_simplify1(3) zero_less_one)
+
+context
+  fixes x :: string
+begin
+
+definition "zs \<equiv> string_to_symbols x"
+
+lemma bit_symbols_zs: "bit_symbols zs"
+  using zs_def by simp
+
+abbreviation "n \<equiv> length x"
+
+lemma length_zs [simp]: "length zs = n"
+  using zs_def by simp
+
+definition "tps0 \<equiv> snd (start_config (k1 + k2) zs)"
+
+definition tps1a :: "tape list" where
+  "tps1a \<equiv> SOME tps. tps ::: 1 = string_to_contents (f1 x) \<and>
+       transforms M1 (snd (start_config k1 (string_to_symbols x))) (T1 n) tps"
+
+lemma tps1a_aux:
+  "tps1a ::: 1 = string_to_contents (f1 x)"
+  "transforms M1 (snd (start_config k1 (string_to_symbols x))) (T1 n) tps1a"
+  using tps1a_def someI_ex[OF computes_in_timeD[OF computes1, of x]]
+  by simp_all
+
+lemma tps1a:
+  "tps1a ::: 1 = string_to_contents (f1 x)"
+  "transforms M1 (snd (start_config k1 zs)) (T1 n) tps1a"
+  using tps1a_aux zs_def by simp_all
+
+lemma length_tps1a [simp]: "length tps1a = k1"
+  using tps1a(2) tm_M1 start_config_length execute_num_tapes transforms_def transits_def turing_machine_def
+  by (smt (verit, del_insts) Suc_1 add_pos_pos less_le_trans less_numeral_extra(1) plus_1_eq_Suc snd_conv)
+
+definition tps1b :: "tape list" where
+  "tps1b \<equiv> replicate k2 (\<lfloor>[]\<rfloor>, 0)"
+
+definition tps1 :: "tape list" where
+  "tps1 \<equiv> tps1a @ tps1b"
+
+lemma tps1_at_1: "tps1 ! 1 = tps1a ! 1"
+  using tps1_def length_tps1a k_ge by (metis Suc_1 Suc_le_lessD nth_append)
+
+lemma tps1_at_1': "tps1 ::: 1 = string_to_contents (f1 x)"
+  using tps1_at_1 tps1a by simp
+
+lemma tps1_pos_le: "tps1 :#: 1 \<le> T1 n"
+proof -
+  have "execute M1 (start_config k1 zs) (T1 n) = (length M1, tps1a)"
+    using transforms_def transits_def tps1a(2)
+    by (metis (no_types, lifting) execute_after_halting_ge fst_conv start_config_def snd_conv)
+  moreover have "execute M1 (start_config k1 zs) (T1 n) <#> 1 \<le> T1 n"
+    using head_pos_le_time[OF tm_M1, of 1] k_ge by fastforce
+  ultimately show ?thesis
+    using tps1_at_1 by simp
+qed
+
+lemma length_f1_x: "length (f1 x) \<le> T1 n"
+proof -
+  have "execute M1 (start_config k1 zs) (T1 n) = (length M1, tps1a)"
+    using transforms_def transits_def tps1a(2)
+    by (metis (no_types, lifting) execute_after_halting_ge fst_conv start_config_def snd_conv)
+  moreover have "(execute M1 (start_config k1 zs) (T1 n) <:> 1) i = \<box>" if "i > T1 n" for i
+    using blank_after_time[OF that _ _ tm_M1] k_ge(1) by simp
+  ultimately have "(tps1a ::: 1) i = \<box>" if "i > T1 n" for i
+    using that by simp
+  then have "(string_to_contents (f1 x)) i = \<box>" if "i > T1 n" for i
+    using that tps1a(1) by simp
+  then have "length (string_to_symbols (f1 x)) \<le> T1 n"
+    by (metis length_map order_refl verit_comp_simplify1(3) zero_neq_numeral zero_neq_one)
+  then show ?thesis
+    by simp
+qed
+
+lemma start_config_append:
+  "start_config (k1 + k2) zs = (0, snd (start_config k1 zs) @ tps1b)"
+proof
+  have "k1 > 0"
+    using tm_M1 turing_machine_def by simp
+  show "fst (start_config (k1 + k2) zs) = fst (0, snd (start_config k1 zs) @ tps1b)"
+    using start_config_def by simp
+  show "snd (start_config (k1 + k2) zs) = snd (0, snd (start_config k1 zs) @ tps1b)"
+    (is "?l = ?r")
+  proof (rule nth_equalityI)
+    have len: "||start_config k1 zs|| = k1"
+      using start_config_length by (simp add: \<open>0 < k1\<close>)
+    show "length ?l = length ?r"
+      using start_config_length tps1b_def tm_M1 turing_machine_def by simp
+    show "?l ! j = ?r ! j" if "j < length ?l" for j
+    proof (cases "j < k1")
+      case True
+      show ?thesis
+      proof (cases "j = 0")
+        case True
+        then show ?thesis
+          using start_config_def `k1 > 0` by simp
+      next
+        case False
+        then have 1: "?l ! j = (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)"
+          using start_config_def `k1 > 0` True by auto
+        have "?r ! j = snd (start_config k1 zs) ! j"
+          using True len by (simp add: nth_append)
+        then have "?r ! j = (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)"
+          using start_config4 `k1 > 0` False True by simp
+        then show ?thesis
+          using 1 by simp
+      qed
+    next
+      case False
+      then have j: "j < k1 + k2" "k1 \<le> j"
+        using that \<open>0 < k1\<close> add_gr_0 start_config_length by simp_all
+      then have "?r ! j = (\<lfloor>[]\<rfloor>, 0)"
+        using tps1b_def by (simp add: False len nth_append)
+      moreover have "?l ! j = (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)"
+        using start_config4 `k1 > 0` j by simp
+      ultimately show ?thesis
+        by auto
+    qed
+  qed
+qed
+
+lemma tm1 [transforms_intros]: "transforms tm1 tps0 (T1 n) tps1"
+proof -
+  let ?M = "append_tapes k1 (k1 + length tps1b) M1"
+  have len: "||start_config k1 zs|| = k1"
+    using start_config_length[of k1 zs] tm_M1 turing_machine_def by simp
+  have "transforms ?M (snd (start_config k1 zs) @ tps1b) (T1 n) (tps1a @ tps1b)"
+    using transforms_append_tapes[OF tm_M1 len tps1a(2), of tps1b] .
+  moreover have "tps0 = snd (start_config k1 zs) @ tps1b"
+    unfolding tps0_def using start_config_append by simp
+  ultimately have *: "transforms ?M tps0 (T1 n) tps1"
+    using tps1_def by simp
+
+  have "symbols_lt G1 zs"
+    using bit_symbols_zs tm_M1 turing_machine_def by auto
+  moreover have "turing_machine (k1 + k2) G1 ?M"
+    using append_tapes_tm[OF tm_M1, of "k1 + k2"] by (simp add: tps1b_def)
+  ultimately have "transforms (enlarged G1 ?M) tps0 (T1 n) tps1"
+    using transforms_enlarged * tps0_def by simp
+  then show ?thesis
+    using tm1_def tps1b_def by simp
+qed
+
+lemma clean_string_to_contents: "clean_tape (string_to_contents xs, i)"
+  using clean_tape_def by simp
+
+definition tps2 :: "tape list" where
+  "tps2 \<equiv> tps1 [1 := tps1 ! 1 |#=| 0]"
+
+lemma length_tps2 [simp]: "length tps2 = k1 + k2"
+  using tps2_def tps1_def by (simp add: tps1b_def)
+
+lemma tm2:
+  assumes "t = Suc (T1 n + tps1 :#: Suc 0)"
+  shows "transforms tm2 tps0 t tps2"
+  unfolding tm2_def
+proof (tform tps: assms tps2_def)
+  show "1 < length tps1"
+    using tm_M1 turing_machine_def tps1_def by simp
+  show "clean_tape (tps1 ! 1)"
+      using tps1a(1) tps1_at_1 clean_tape_def by simp
+qed
+
+corollary tm2' [transforms_intros]:
+  assumes "t = Suc (2 * T1 n)"
+  shows "transforms tm2 tps0 t tps2"
+  using assms tm2 tps1_pos_le transforms_monotone by simp
+
+definition tps3 :: "tape list" where
+  "tps3 \<equiv> tps2 [1 := tps2 ! 1 |#=| (Suc (length (f1 x))), k1 := tps2 ! 1 |#=| (Suc (length (f1 x)))]"
+
+lemma tm3:
+  assumes "t = Suc (Suc (2 * T1 n + Suc (length (f1 x))))"
+  shows "transforms tm3 tps0 t tps3"
+  unfolding tm3_def
+proof (tform tps: k_ge)
+  have "Suc 0 < k1 + k2" "0 < k2"
+    using k_ge by simp_all
+  then have *: "tps2 ! 1 = tps1 ! 1 |#=| 0"
+    using tps2_def by (simp add: tps1_def tps1b_def)
+  let ?i = "Suc (length (f1 x))"
+  show "rneigh (tps2 ! 1) {0} ?i"
+    using * tps1_at_1 tps1a by (intro rneighI) auto
+  show "tps3 = tps2
+    [1 := tps2 ! 1 |+| Suc (length (f1 x)),
+     k1 := implant (tps2 ! 1) (tps2 ! k1) (Suc (length (f1 x)))]"
+  proof -
+    have "tps2 ! 1 |#=| (Suc (length (f1 x))) = tps2 ! 1 |#=| Suc (tps2 :#: 1 + length (f1 x))"
+      by (metis "*" One_nat_def add_Suc plus_1_eq_Suc snd_conv)
+    moreover have "tps2 ! 1 |#=| ?i = implant (tps2 ! 1) (tps2 ! k1) ?i"
+    proof
+      have 1: "tps2 ! 1 = (string_to_contents (f1 x), 0)"
+        using tps1_at_1' * by simp
+      have "tps1 ! k1 = (\<lfloor>[]\<rfloor>, 0)"
+        using tps1_def tps1b_def by (simp add: \<open>0 < k2\<close> nth_append)
+      then have 2: "tps2 ! k1 = (\<lfloor>[]\<rfloor>, 0)"
+        using tps2_def k_ge by simp
+      then show "snd (tps2 ! 1 |#=| ?i) = snd (implant (tps2 ! 1) (tps2 ! k1) ?i)"
+        using implant by simp
+      have "fst (implant (tps2 ! 1) (tps2 ! k1) ?i) i = fst (tps2 ! 1 |#=| ?i) i" for i
+        using 1 2 implant by simp
+      then show "fst (tps2 ! 1 |#=| ?i) = fst (implant (tps2 ! 1) (tps2 ! k1) ?i)"
+        by auto
+    qed
+    ultimately show ?thesis
+      using tps3_def by simp
+  qed
+  show "t = Suc (2 * T1 n) + Suc (Suc (length (f1 x)))"
+    using assms by simp
+qed
+
+definition "tps3' \<equiv> tps1a
+  [1 := (string_to_contents (f1 x), Suc (length (f1 x)))] @
+   ((string_to_contents (f1 x), Suc (length (f1 x))) #
+    replicate (k2 - 1) (\<lfloor>[]\<rfloor>, 0))"
+
+lemma tps3': "tps3 = tps3'"
+proof (rule nth_equalityI)
+  have "length tps3 = k1 + k2"
+    using tps3_def by simp
+  moreover have "length tps3' = k1 + k2"
+    using k_ge(2) tps3'_def by simp
+  ultimately show "length tps3 = length tps3'"
+    by simp
+  show "tps3 ! j = tps3' ! j" if "j < length tps3" for j
+  proof (cases "j < k1")
+    case True
+    then have rhs: "tps3' ! j = (tps1a [1 := (string_to_contents (f1 x), Suc (length (f1 x)))]) ! j"
+      by (simp add: tps3'_def nth_append)
+    show ?thesis
+    proof (cases "j = 1")
+      case True
+      then have "tps3 ! j = tps2 ! 1 |#=| (Suc (length (f1 x)))"
+        using tps3_def Suc_1 Suc_n_not_le_n \<open>length tps3 = k1 + k2\<close> k_ge(1)
+          length_tps2 nth_list_update_eq nth_list_update_neq that
+        by auto
+      then have "tps3 ! j = tps1 ! 1 |#=| (Suc (length (f1 x)))"
+        using tps2_def True \<open>length tps3 = k1 + k2\<close> length_tps2 that by auto
+      then have "tps3 ! j = (string_to_contents (f1 x), Suc (length (f1 x)))"
+        using tps1_at_1 tps1a(1) by simp
+      then show ?thesis
+        using rhs True k_ge(1) by auto
+    next
+      case False
+      then have "tps3 ! j = tps2 ! j"
+        using tps3_def True by simp
+      then have "tps3 ! j = tps1 ! j"
+        using tps2_def False by simp
+      then have "tps3 ! j = tps1a ! j"
+        using length_tps1a tps1_def False True by (simp add: nth_append)
+      moreover have "tps3' ! j = tps1a ! j"
+        using False rhs by simp
+      ultimately show ?thesis
+        by simp
+    qed
+  next
+    case j_ge: False
+    show ?thesis
+    proof (cases "j = k1")
+      case True
+      then have "tps3 ! j = tps2 ! 1 |#=| (Suc (length (f1 x)))"
+        using tps3_def that by simp
+      then have "tps3 ! j = tps1 ! 1 |#=| (Suc (length (f1 x)))"
+        using tps2_def \<open>length tps3 = k1 + k2\<close> length_tps2 Suc_1 Suc_le_lessD tm1_tm turing_machine_def
+        by simp
+      then have "tps3 ! j = (string_to_contents (f1 x), Suc (length (f1 x)))"
+        using tps1_at_1 tps1a(1) by simp
+      moreover have "tps3' ! j = (string_to_contents (f1 x), Suc (length (f1 x)))"
+        using True tps3'_def
+        by (metis (no_types, lifting) length_list_update length_tps1a nth_append_length)
+      ultimately show ?thesis
+        by simp
+    next
+      case False
+      then have "j > k1"
+        using j_ge by simp
+      then have "tps3' ! j = ((string_to_contents (f1 x), Suc (length (f1 x))) #
+          replicate (k2 - 1) (\<lfloor>[]\<rfloor>, 0)) ! (j - k1)"
+        by (simp add: tps3'_def nth_append)
+      moreover have "j - k1 < k2"
+        by (metis \<open>k1 < j\<close> \<open>length tps3 = k1 + k2\<close> add.commute less_diff_conv2 less_imp_le that)
+      ultimately have *: "tps3' ! j = (\<lfloor>[]\<rfloor>, 0)"
+        by (metis (no_types, lifting) Suc_leI \<open>k1 < j\<close> add_leD1 le_add_diff_inverse2 less_diff_conv2
+          nth_Cons_pos nth_replicate plus_1_eq_Suc zero_less_diff)
+      have "tps3 ! j = tps2 ! j"
+        using tps3_def \<open>k1 < j\<close> k_ge(1) by simp
+      then have "tps3 ! j = tps1 ! j"
+        using tps2_def \<open>k1 < j\<close> k_ge(1) by simp
+      then have "tps3 ! j = tps1b ! (j - k1)"
+        using tps1_def by (simp add: j_ge nth_append)
+      then have "tps3 ! j = (\<lfloor>[]\<rfloor>, 0)"
+        using tps1b_def by (simp add: \<open>j - k1 < k2\<close>)
+      then show ?thesis
+        using * by simp
+    qed
+  qed
+qed
+
+lemma tm3' [transforms_intros]:
+  assumes "t = Suc (Suc (Suc (3 * T1 n)))"
+  shows "transforms tm3 tps0 t tps3'"
+proof -
+  have "transforms tm3 tps0 (Suc (Suc (2 * T1 n + Suc (length (f1 x))))) tps3"
+    using tm3 by simp
+  moreover have "t \<ge> Suc (Suc (2 * T1 n + Suc (length (f1 x))))"
+    using assms length_f1_x by simp
+  ultimately show ?thesis
+    using tps3' transforms_monotone by auto
+qed
+
+definition "tps4 \<equiv>
+  tps1a [1 := (\<lfloor>[]\<rfloor>, 1)] @
+  ((string_to_contents (f1 x), Suc (length (f1 x))) #
+   replicate (k2 - 1) (\<lfloor>[]\<rfloor>, 0))"
+
+lemma tm4:
+  assumes "t = 9 + (3 * T1 n + (Suc (3 * length (string_to_symbols (f1 x)))))"
+  shows "transforms tm4 tps0 t tps4"
+  unfolding tm4_def
+proof (tform)
+  show "1 < length tps3'"
+    using tps3'_def using tm1_tm turing_machine_def by auto
+  let ?zs = "string_to_symbols (f1 x)"
+  show "proper_symbols ?zs"
+    by simp
+  show "tps4 = tps3'[1 := (\<lfloor>[]\<rfloor>, 1)]"
+    using tps4_def tps3'_def k_ge(1) length_tps1a by (simp add: list_update_append1)
+  show "tps3' ::: 1 = \<lfloor>string_to_symbols (f1 x)\<rfloor>"
+  proof -
+    have "tps3' ! 1 = (string_to_contents (f1 x), Suc (length (f1 x)))"
+      using tps3'_def k_ge(1) length_tps1a by (simp add: nth_append)
+    then show ?thesis
+      by auto
+  qed
+  have "tps3' :#: 1 = Suc (length (f1 x))"
+    using tps3'_def k_ge(1) length_tps1a by (simp add: nth_append)
+  then show "t = Suc (Suc (Suc (3 * T1 n))) +
+      (tps3' :#: 1 + 2 * length (string_to_symbols (f1 x)) + 6)"
+    using assms by simp
+qed
+
+lemma tm4' [transforms_intros]:
+  assumes "t = 10 + (6 * T1 n)"
+  shows "transforms tm4 tps0 t tps4"
+proof (rule transforms_monotone[OF tm4], simp)
+  show "10 + (3 * T1 n + 3 * length (f1 x)) \<le> t"
+    using length_f1_x assms by simp
+qed
+
+definition "tps5 \<equiv>
+  tps1a [1 := (\<lfloor>[]\<rfloor>, 1)] @
+  ((string_to_contents (f1 x), 0) #
+   replicate (k2 - 1) (\<lfloor>[]\<rfloor>, 0))"
+
+lemma tm5:
+  assumes "t = 11 + (6 * T1 n + tps4 :#: k1)"
+  shows "transforms tm5 tps0 t tps5"
+  unfolding tm5_def
+proof (tform time: assms)
+  show "k1 < length tps4"
+    using tps4_def length_tps1a by simp
+  show "tps5 = tps4[k1 := tps4 ! k1 |#=| 0]"
+    using tps4_def tps5_def length_tps1a
+    by (metis (no_types, lifting) fst_conv length_list_update list_update_length nth_append_length)
+  show "clean_tape (tps4 ! k1)"
+    using tps4_def length_tps1a clean_tape_def
+    by (smt (z3) Suc_eq_plus1 add.commute add_cancel_right_right
+      fst_conv length_list_update nat.distinct(1) nat_1_add_1 nth_append_length numeral_3_eq_3)
+qed
+
+abbreviation "ys \<equiv> string_to_symbols (f1 x)"
+
+abbreviation "m \<equiv> length (f1 x)"
+
+definition "tps5' \<equiv>
+  tps1a [1 := (\<lfloor>[]\<rfloor>, 1)] @
+  snd (start_config k2 ys)"
+
+lemma tps5': "tps5 = tps5'"
+  using tps5_def tps5'_def start_config_def by auto
+
+lemma tm5' [transforms_intros]:
+  assumes "t = 12 + 7 * T1 n"
+  shows "transforms tm5 tps0 t tps5'"
+proof -
+  have "tps4 :#: k1 = Suc (length (f1 x))"
+    using tps4_def
+    by (metis (no_types, lifting) length_list_update length_tps1a nth_append_length snd_conv)
+  then have "tps4 :#: k1 \<le> Suc (T1 n)"
+    using length_f1_x by simp
+  then have "t \<ge> 11 + (6 * T1 n + tps4 :#: k1)"
+    using assms by simp
+  then show ?thesis
+    using tm5 transforms_monotone tps5' by simp
+qed
+
+definition tps6b :: "tape list" where
+  "tps6b \<equiv> SOME tps. tps ::: 1 = string_to_contents (f2 (f1 x)) \<and>
+       transforms M2 (snd (start_config k2 ys)) (T2 m) tps"
+
+lemma tps6b:
+  "tps6b ::: 1 = string_to_contents (f2 (f1 x))"
+  "transforms M2 (snd (start_config k2 ys)) (T2 m) tps6b"
+  using tps6b_def someI_ex[OF computes_in_timeD[OF computes2, of "f1 x"]]
+  by simp_all
+
+lemma tps6b_pos_le: "tps6b :#: 1 \<le> T2 m"
+proof -
+  have "execute M2 (start_config k2 ys) (T2 m) = (length M2, tps6b)"
+    using transforms_def transits_def tps6b(2)
+    by (metis (no_types, lifting) execute_after_halting_ge fst_conv start_config_def snd_conv)
+  moreover have "execute M2 (start_config k2 ys) (T2 m) <#> 1 \<le> T2 m"
+    using head_pos_le_time[OF tm_M2, of 1] k_ge by simp
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma length_tps6b: "length tps6b = k2"
+  using tm_M2 execute_num_tapes k_ge(2) tps5' tps5'_def tps5_def tps6b(2) transforms_def transits_def
+  by (smt (verit, ccfv_threshold) One_nat_def Suc_diff_Suc length_Cons length_replicate less_le_trans
+    minus_nat.diff_0 numeral_2_eq_2 prod.sel(2) same_append_eq zero_less_Suc)
+
+lemma length_f2_f1_x: "length (f2 (f1 x)) \<le> T2 m"
+proof -
+  have "execute M2 (start_config k2 ys) (T2 m) = (length M2, tps6b)"
+    using transforms_def transits_def tps6b(2)
+    by (metis (no_types, lifting) execute_after_halting_ge fst_conv start_config_def snd_conv)
+  moreover have "(execute M2 (start_config k2 ys) (T2 m) <:> 1) i = 0" if "i > T2 m" for i
+    using blank_after_time[OF that _ _ tm_M2] k_ge(2) by simp
+  ultimately have "(tps6b ::: 1) i = \<box>" if "i > T2 m" for i
+    using that by simp
+  then have "(string_to_contents (f2 (f1 x))) i = \<box>" if "i > T2 m" for i
+    using that tps6b(1) by simp
+  then have "length (string_to_symbols (f2 (f1 x))) \<le> T2 m"
+    by (metis length_map order_refl verit_comp_simplify1(3) zero_neq_numeral zero_neq_one)
+  then show ?thesis
+    by simp
+qed
+
+lemma enlarged_M2: "transforms (enlarged G2 M2) (snd (start_config k2 ys)) (T2 m) tps6b"
+proof -
+  have "symbols_lt G2 (string_to_symbols (f1 x))"
+    using tm_M2 turing_machine_def by simp
+  then show ?thesis
+    using transforms_enlarged[OF tm_M2 _ tps6b(2)] by simp
+qed
+
+lemma enlarged_M2_tm: "turing_machine k2 G (enlarged G2 M2)"
+  using turing_machine_enlarged tm_M2 G2 by simp
+
+definition "tps6 \<equiv> tps1a[1 := (\<lfloor>[]\<rfloor>, 1)] @ tps6b"
+
+lemma tm56 [transforms_intros]: "transforms tm56 tps5' (T2 m) tps6"
+  using transforms_prepend_tapes[OF enlarged_M2_tm _ _ enlarged_M2, of "tps1a [1 := (\<lfloor>[]\<rfloor>, 1)]" k1]
+    tps5'_def tps6_def tm56_def start_config_length k_ge(2)
+  by auto
+
+lemma tps6_at_Suc_k1: "tps6 ::: (k1 + 1) = string_to_contents (f2 (f1 x))"
+  and tps6_pos_le: "tps6 :#: (k1 + 1) \<le> T2 m"
+proof -
+  have "tps6 ! (k1 + 1) = tps6b ! 1"
+    using tps6_def length_tps1a length_tps6b by (simp add: nth_append)
+  then show
+    "tps6 ::: (k1 + 1) = string_to_contents (f2 (f1 x))"
+    "tps6 :#: (k1 + 1) \<le> T2 m"
+    using tps6b(1) tps6b_pos_le by simp_all
+qed
+
+lemma tm6 [transforms_intros]:
+  assumes "t = 12 + 7 * T1 n + T2 m"
+  shows "transforms tm6 tps0 t tps6"
+  unfolding tm6_def by (tform tps: assms)
+
+definition "tps7 \<equiv>
+  tps1a[1 := (\<lfloor>[]\<rfloor>, 1)] @
+  tps6b[1 := (string_to_contents (f2 (f1 x)), 1)]"
+
+lemma tps7_at_Suc_k1: "tps7 ! (k1 + 1) = (string_to_contents (f2 (f1 x)), 1)"
+  using tps7_def k_ge(2) length_tps1a length_tps6b
+  by (metis (no_types, lifting) One_nat_def Suc_le_lessD add.commute diff_add_inverse
+    length_list_update not_add_less2 nth_append nth_list_update_eq numeral_2_eq_2)
+
+lemma tm7:
+  assumes "t = 14 + (7 * T1 n + (T2 m + tps6 :#: Suc k1))"
+  shows "transforms tm7 tps0 t tps7"
+  unfolding tm7_def
+proof (tform time: assms)
+  show "k1 + 1 < length tps6"
+    using tps6_def k_ge(2) length_tps1a length_tps6b by simp
+  show "clean_tape (tps6 ! (k1 + 1))"
+    using tps6_at_Suc_k1 clean_tape_def by simp
+  show "tps7 = tps6[k1 + 1 := tps6 ! (k1 + 1) |#=| 1]"
+  proof -
+    have "tps6 ! (k1 + 1) |#=| 1 = (string_to_contents (f2 (f1 x)), 1)"
+      using tps6_at_Suc_k1 by simp
+    then show ?thesis
+      using tps6_def tps7_def length_tps1a length_tps6b k_ge tps7_at_Suc_k1
+      by (metis (no_types, lifting) add.commute diff_add_inverse length_list_update
+        list_update_append not_add_less2 plus_1_eq_Suc)
+  qed
+qed
+
+corollary tm7' [transforms_intros]:
+  assumes "t = 14 + 7 * T1 n + 2 * T2 m"
+  shows "transforms tm7 tps0 t tps7"
+proof (rule transforms_monotone[OF tm7], simp)
+  show "14 + (7 * T1 n + (T2 (length (f1 x)) + tps6 :#: Suc k1)) \<le> t"
+    using assms tps6_pos_le by simp
+qed
+
+definition "tps8 \<equiv>
+  tps1a[1 := (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))] @
+  tps6b[1 := (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))]"
+
+lemma tps8_at_1: "tps8 ::: 1 = string_to_contents (f2 (f1 x))"
+  using tps8_def length_tps1a k_ge(1)
+  by (metis (no_types, lifting) One_nat_def Suc_le_lessD length_list_update nth_append
+    nth_list_update_eq numeral_2_eq_2 prod.sel(1))
+
+lemma tm8:
+  assumes "t = 15 + 7 * T1 n + 2 * T2 m + length (f2 (f1 x))"
+  shows "transforms tm8 tps0 t tps8"
+  unfolding tm8_def
+proof (tform tps: assms)
+  show "k1 + 1 < length tps7"
+    using tps7_def length_tps1a length_tps6b k_ge(2) by simp
+  show "1 < length tps7"
+    using tps7_def length_tps6b k_ge(2) by simp
+  let ?n = "length (f2 (f1 x))"
+  show "rneigh (tps7 ! (k1 + 1)) {\<box>} ?n"
+  proof (rule rneighI)
+   show "(tps7 ::: (k1 + 1)) (tps7 :#: (k1 + 1) + ?n) \<in> {\<box>}"
+     using tps7_at_Suc_k1 by simp
+   show "\<And>n'. n' < ?n \<Longrightarrow> (tps7 ::: (k1 + 1)) (tps7 :#: (k1 + 1) + n') \<notin> {\<box>}"
+     using tps7_at_Suc_k1 by simp
+  qed
+  show "tps8 = tps7
+    [k1 + 1 := tps7 ! (k1 + 1) |+| ?n,
+     1 := implant (tps7 ! (k1 + 1)) (tps7 ! 1) ?n]"
+     (is "tps8 = ?tps")
+  proof (rule nth_equalityI)
+    show "length tps8 = length ?tps"
+      using tps8_def tps7_def by simp
+    have len: "length tps8 = k1 + k2"
+      using tps8_def length_tps6b by simp
+    show "tps8 ! j = ?tps ! j" if "j < length tps8" for j
+    proof (cases "j < k1")
+      case j_less: True
+      then have lhs: "tps8 ! j = tps1a[1 := (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))] ! j"
+        using tps8_def length_tps1a length_tps6b k_ge by (simp add: nth_append)
+      show ?thesis
+      proof (cases "j = 1")
+        case True
+        then have 1: "?tps ! j = implant (tps7 ! (k1 + 1)) (tps7 ! 1) ?n"
+          using \<open>1 < length tps7\<close> by simp
+        have 2: "tps8 ! j = (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))"
+          using lhs True j_less by simp
+        have 3: "tps7 ! 1 = (\<lfloor>[]\<rfloor>, 1)"
+          using tps7_def length_tps1a
+          by (metis (no_types, lifting) True j_less length_list_update nth_append nth_list_update_eq)
+        have "implant (string_to_contents (f2 (f1 x)), 1) (\<lfloor>[]\<rfloor>, 1) ?n =
+            (string_to_contents (f2 (f1 x)), Suc ?n)"
+          using implant contents_def by auto
+        then show ?thesis
+          using 1 2 3 tps7_at_Suc_k1 by simp
+      next
+        case False
+        then have "?tps ! j = tps7 ! j"
+          by (metis One_nat_def Suc_eq_plus1 add.commute j_less not_add_less2 nth_list_update_neq)
+        then have "?tps ! j = tps1a ! j"
+          using False j_less tps7_def length_tps1a
+          by (metis (no_types, lifting) length_list_update nth_append nth_list_update_neq)
+        moreover have "tps8 ! j = tps1a ! j"
+          using False j_less tps8_def lhs by simp
+        ultimately show ?thesis
+          by simp
+      qed
+    next
+      case j_ge: False
+      then have lhs: "tps8 ! j = tps6b[1 := (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))] ! (j - k1)"
+        using tps8_def length_tps1a length_tps6b k_ge by (simp add: nth_append)
+      show ?thesis
+      proof (cases "j = Suc k1")
+        case True
+        then have "tps8 ! j = (string_to_contents (f2 (f1 x)), Suc (length (f2 (f1 x))))"
+          using lhs len that length_tps6b by simp
+        moreover have "?tps ! j = tps7 ! Suc k1 |+| ?n"
+          using True \<open>k1 + 1 < length tps7\<close> k_ge(1) by simp
+        ultimately show ?thesis
+          using tps7_at_Suc_k1 True by simp
+      next
+        case False
+        then have "tps8 ! j = tps6b ! (j - k1)"
+          using lhs by simp
+        moreover have "?tps ! j = tps7 ! j"
+          using False j_ge that k_ge(1) by simp
+        ultimately show ?thesis
+          using tps7_def j_ge False length_tps1a
+          by (metis (no_types, lifting) add.commute add_diff_inverse_nat length_list_update
+            nth_append nth_list_update_neq plus_1_eq_Suc)
+      qed
+    qed
+  qed
+qed
+
+lemma tm8':
+  assumes "t = 15 + 7 * T1 n + 3 * T2 m"
+  shows "transforms tm8 tps0 t tps8"
+proof (rule transforms_monotone[OF tm8], simp)
+  show "15 + 7 * T1 n + 2 * T2 m + length (f2 (f1 x)) \<le> t"
+    using length_f2_f1_x assms by simp
+qed
+
+lemma tm8'_mono:
+  assumes "mono T2"
+    and "t = 15 + 7 * T1 n + 3 * T2 (T1 n)"
+  shows "transforms tm8 tps0 t tps8"
+proof (rule transforms_monotone[OF tm8'], simp)
+  have "T2 (T1 n) \<ge> T2 m"
+    using assms(1) length_f1_x monoE by auto
+  then show "15 + 7 * T1 n + 3 * T2 m \<le> t"
+    using assms(2) by simp
+qed
+
+end  (* context x *)
+
+lemma computes_composed_mono:
+  assumes "mono T2" and "T = (\<lambda>n. 15 + 7 * T1 n + 3 * T2 (T1 n))"
+  shows "computes_in_time (k1 + k2) tm8 (f2 \<circ> f1) T"
+proof
+  fix x
+  have "tps8 x ::: 1 = string_to_contents (f2 (f1 x))"
+    using tps8_at_1 by simp
+  moreover have "transforms tm8 (snd (start_config (k1 + k2) (string_to_symbols x))) (T (length x)) (tps8 x)"
+    using tm8'_mono assms tps0_def zs_def by simp
+  ultimately show "\<exists>tps.
+      tps ::: 1 = string_to_contents ((f2 \<circ> f1) x) \<and>
+      transforms tm8 (snd (start_config (k1 + k2) (string_to_symbols x))) (T (length x)) tps"
+    by force
+qed
+
+end  (* locale compose *)
+
+lemma computes_composed_poly:
+  assumes tm_M1: "turing_machine k1 G1 M1"
+    and tm_M2: "turing_machine k2 G2 M2"
+    and computes1: "computes_in_time k1 M1 f1 T1"
+    and computes2: "computes_in_time k2 M2 f2 T2"
+  assumes "big_oh_poly T1" and "big_oh_poly T2"
+  shows "\<exists>T k G M. big_oh_poly T \<and> turing_machine k G M \<and> computes_in_time k M (f2 \<circ> f1) T"
+proof -
+  obtain d1 :: nat where "big_oh T1 (\<lambda>n. n ^ d1)"
+    using assms(5) big_oh_poly_def by auto
+  obtain b c d2 :: nat where cm: "d2 > 0" "\<forall>n. T2 n \<le> b + c * n ^ d2"
+    using big_oh_poly_offset[OF assms(6)] by auto
+  let ?U = "\<lambda>n. b + c * n ^ d2"
+  have U: "T2 n \<le> ?U n" for n
+    using cm by simp
+  have "mono ?U"
+    by standard (simp add: cm(1))
+  have computesU: "computes_in_time k2 M2 f2 ?U"
+    using computes_in_time_mono[OF computes2 U] .
+  interpret compo: compose k1 k2 G1 G2 M1 M2 T1 ?U f1 f2
+    using assms computesU compose.intro by simp
+  let ?M = "compo.tm8"
+  let ?T = "(\<lambda>n. 15 + 7 * T1 n + 3 * (b + c * T1 n ^ d2))"
+  have "computes_in_time (k1 + k2) ?M (f2 \<circ> f1) ?T"
+    using compo.computes_composed_mono[OF `mono ?U`, of ?T] by simp
+  moreover have "big_oh_poly ?T"
+  proof -
+    have "big_oh_poly (\<lambda>n. n ^ d2)"
+      using big_oh_poly_poly by simp
+    moreover have "(\<lambda>n. T1 n ^ d2) = (\<lambda>n. n ^ d2) \<circ> T1"
+      by auto
+    ultimately have "big_oh_poly (\<lambda>n. T1 n ^ d2)"
+      using big_oh_poly_composition[OF assms(5)] by auto
+    then have "big_oh_poly (\<lambda>n. 3 * (b + c * T1 n ^ d2))"
+      using big_oh_poly_const big_oh_poly_prod big_oh_poly_sum by simp
+    then show ?thesis
+      using assms(5) big_oh_poly_const big_oh_poly_prod big_oh_poly_sum by simp
+  qed
+  moreover have "turing_machine (k1 + k2) compo.G ?M"
+    using compo.tm8_tm .
+  ultimately show ?thesis
+    by auto
+qed
+
+end
diff --git a/thys/Cook_Levin/Elementary.thy b/thys/Cook_Levin/Elementary.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Elementary.thy
@@ -0,0 +1,2416 @@
+section \<open>Elementary Turing machines\label{s:tm-elementary}\<close>
+
+theory Elementary
+  imports Combinations
+begin
+
+text \<open>
+In this section we devise some simple yet useful Turing machines.  We have
+already fully analyzed the empty TM, where start and halting state coincide, in
+the lemmas~@{thm [source] computes_Nil_empty}, @{thm [source] Nil_tm}, and @{thm
+[source] transforms_Nil}.  The next more complex TMs are those with exactly one
+command. They represent TMs with two states: the halting state and the start
+state where the action happens. This action might last for one step only, or the
+TM may stay in this state for longer; for example, it can move a tape head
+rightward to the next blank symbol.  We will also start using the @{text ";;"}
+operator to combine some of the one-command TMs.
+\<close>
+
+text \<open>
+Most Turing machines we are going to construct throughout this section and
+indeed the entire article are really families of Turing machines that usually
+are parameterized by tape indices.
+\<close>
+
+type_synonym tapeidx = nat
+
+text \<open>
+Throughout this article, names of commands are prefixed with @{text cmd_} and
+names of Turing machines with @{text tm_}. Usually for a TM named @{term tm_foo}
+there is a lemma @{text tm_foo_tm} stating that it really is a Turing machine and
+a lemma @{text transforms_tm_fooI} describing its semantics and running time. The
+lemma usually receives a @{text transforms_intros} attribute for use with our
+proof method.
+
+If @{term "tm_foo"} comprises more than two TMs we will typically analyze the
+semantics and running time in a locale named @{text "turing_machine_foo"}. The
+first example of this is @{term tm_equals} in
+Section~\ref{s:tm-elementary-comparing}.
+
+When it comes to running times, we will have almost no scruples simplifying
+upper bounds to have the form $a + b\cdot n^c$ for some constants $a, b, c$,
+even if this means, for example, bounding $n \log n$ by $n^2$.
+\<close>
+
+
+subsection \<open>Clean tapes\<close>
+
+text \<open>
+Most of our Turing machines will not change the start symbol in the first cell
+of a tape nor will they write the start symbol anywhere else. The only
+exceptions are machines that simulate arbitrary other machines. We call tapes
+that have the start symbol only in the first cell \emph{clean tapes}.
+\<close>
+
+definition clean_tape :: "tape \<Rightarrow> bool" where
+  "clean_tape tp \<equiv> \<forall>i. fst tp i = \<triangleright> \<longleftrightarrow> i = 0"
+
+lemma clean_tapeI:
+  assumes "\<And>i. fst tp i = \<triangleright> \<longleftrightarrow> i = 0"
+  shows "clean_tape tp"
+  unfolding clean_tape_def using assms by simp
+
+lemma clean_tapeI':
+  assumes "fst tp 0 = \<triangleright>" and "\<And>i. i > 0 \<Longrightarrow> fst tp i \<noteq> \<triangleright>"
+  shows "clean_tape tp"
+  unfolding clean_tape_def using assms by auto
+
+text \<open>
+A clean configuration is one with only clean tapes.
+\<close>
+
+definition clean_config :: "config \<Rightarrow> bool" where
+  "clean_config cfg \<equiv> (\<forall>j<||cfg||. \<forall>i. (cfg <:> j) i = \<triangleright> \<longleftrightarrow> i = 0)"
+
+lemma clean_config_tapes: "clean_config cfg = (\<forall>tp\<in>set (snd cfg). clean_tape tp)"
+  using clean_config_def clean_tape_def by (metis in_set_conv_nth)
+
+lemma clean_configI:
+  assumes "\<And>j i. j < length tps \<Longrightarrow> fst (tps ! j) i = \<triangleright> \<longleftrightarrow> i = 0"
+  shows "clean_config (q, tps)"
+  unfolding clean_config_def using assms by simp
+
+lemma clean_configI':
+  assumes "\<And>tp i. tp \<in> set tps \<Longrightarrow> fst tp i = \<triangleright> \<longleftrightarrow> i = 0"
+  shows "clean_config (q, tps)"
+  using clean_configI assms by simp
+
+lemma clean_configI'':
+  assumes "\<And>tp. tp \<in> set tps \<Longrightarrow> (fst tp 0 = \<triangleright> \<and> (\<forall>i>0. fst tp i \<noteq> \<triangleright>))"
+  shows "clean_config (q, tps)"
+  using clean_configI' assms by blast
+
+lemma clean_configE:
+  assumes "clean_config (q, tps)"
+  shows "\<And>j i. j < length tps \<Longrightarrow> fst (tps ! j) i = \<triangleright> \<longleftrightarrow> i = 0"
+  using clean_config_def assms by simp
+
+lemma clean_configE':
+  assumes "clean_config (q, tps)"
+  shows "\<And>tp i. tp \<in> set tps \<Longrightarrow> fst tp i = \<triangleright> \<longleftrightarrow> i = 0"
+  using clean_configE assms by (metis in_set_conv_nth)
+
+lemma clean_contents_proper [simp]: "proper_symbols zs \<Longrightarrow> clean_tape (\<lfloor>zs\<rfloor>, q)"
+  using clean_tape_def contents_def proper_symbols_ne1 by simp
+
+lemma contents_clean_tape': "proper_symbols zs \<Longrightarrow> fst tp = \<lfloor>zs\<rfloor> \<Longrightarrow> clean_tape tp"
+  using contents_def clean_tape_def by (simp add: nat_neq_iff)
+
+text \<open>
+Some more lemmas about @{const contents}:
+\<close>
+
+lemma contents_append_blanks: "\<lfloor>ys @ replicate m \<box>\<rfloor> = \<lfloor>ys\<rfloor>"
+proof
+  fix i
+  consider
+      "i = 0"
+    | "0 < i \<and> i \<le> length ys"
+    | "length ys < i \<and> i \<le> length ys + m"
+    | "length ys + m < i"
+    by linarith
+  then show "\<lfloor>ys @ replicate m \<box>\<rfloor> i = \<lfloor>ys\<rfloor> i"
+  proof (cases)
+    case 1
+    then show ?thesis
+      by simp
+  next
+    case 2
+    then show ?thesis
+      using contents_inbounds
+      by (metis (no_types, opaque_lifting) Suc_diff_1 Suc_le_eq le_add1 le_trans length_append nth_append)
+  next
+    case 3
+    then show ?thesis
+      by (smt (z3) Suc_diff_Suc add_diff_inverse_nat contents_def diff_Suc_1 diff_commute leD less_one
+        less_or_eq_imp_le nat_add_left_cancel_le not_less_eq nth_append nth_replicate)
+  next
+    case 4
+    then show ?thesis
+      by simp
+  qed
+qed
+
+lemma contents_append_update:
+  assumes "length ys = m"
+  shows "\<lfloor>ys @ [v] @ zs\<rfloor>(Suc m := w) = \<lfloor>ys @ [w] @ zs\<rfloor>"
+proof
+  fix i
+  consider
+      "i = 0"
+    | "0 < i \<and> i < Suc m"
+    | "i = Suc m"
+    | "i > Suc m \<and> i \<le> Suc m + length zs"
+    | "i > Suc m + length zs"
+    by linarith
+  then show "(\<lfloor>ys @ [v] @ zs\<rfloor>(Suc m := w)) i = \<lfloor>ys @ [w] @ zs\<rfloor> i"
+    (is "?l = ?r")
+  proof (cases)
+    case 1
+    then show ?thesis
+      by simp
+  next
+    case 2
+    then have "?l = (ys @ [v] @ zs) ! (i - 1)"
+      using assms contents_inbounds by simp
+    then have *: "?l = ys ! (i - 1)"
+      using 2 assms by (metis Suc_diff_1 Suc_le_lessD less_Suc_eq_le nth_append)
+    have "?r = (ys @ [w] @ zs) ! (i - 1)"
+      using 2 assms contents_inbounds by simp
+    then have "?r = ys ! (i - 1)"
+      using 2 assms by (metis Suc_diff_1 Suc_le_lessD less_Suc_eq_le nth_append)
+    then show ?thesis
+      using * by simp
+  next
+    case 3
+    then show ?thesis
+      using assms by auto
+  next
+    case 4
+    then have "?l = (ys @ [v] @ zs) ! (i - 1)"
+      using assms contents_inbounds by simp
+    then have "?l = ((ys @ [v]) @ zs) ! (i - 1)"
+      by simp
+    then have *: "?l = zs ! (i - 1 - Suc m)"
+      using 4 assms by (metis diff_Suc_1 length_append_singleton less_imp_Suc_add not_add_less1 nth_append)
+    then have "?r = (ys @ [w] @ zs) ! (i - 1)"
+      using 4 assms contents_inbounds by simp
+    then have "?r = ((ys @ [w]) @ zs) ! (i - 1)"
+      by simp
+    then have "?r = zs ! (i - 1 - Suc m)"
+      using 4 assms by (metis diff_Suc_1 length_append_singleton less_imp_Suc_add not_add_less1 nth_append)
+    then show ?thesis
+      using * by simp
+  next
+    case 5
+    then show ?thesis
+      using assms by simp
+  qed
+qed
+
+lemma contents_snoc: "\<lfloor>ys\<rfloor>(Suc (length ys) := w) = \<lfloor>ys @ [w]\<rfloor>"
+proof
+  fix i
+  consider "i = 0" | "0 < i \<and> i \<le> length ys" | "i = Suc (length ys)" | "i > Suc (length ys)"
+    by linarith
+  then show "(\<lfloor>ys\<rfloor>(Suc (length ys) := w)) i = \<lfloor>ys @ [w]\<rfloor> i"
+  proof (cases)
+    case 1
+    then show ?thesis
+      by simp
+  next
+    case 2
+    then show ?thesis
+      by (smt (verit, ccfv_SIG) contents_def diff_Suc_1 ex_least_nat_less fun_upd_apply leD le_Suc_eq
+        length_append_singleton less_imp_Suc_add nth_append)
+  next
+    case 3
+    then show ?thesis
+      by simp
+  next
+    case 4
+    then show ?thesis
+      by simp
+  qed
+qed
+
+definition config_update_pos :: "config \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> config" where
+  "config_update_pos cfg j p \<equiv> (fst cfg, (snd cfg)[j:=(cfg <:> j, p)])"
+
+lemma config_update_pos_0: "config_update_pos cfg j (cfg <#> j) = cfg"
+  using config_update_pos_def by simp
+
+definition config_update_fwd :: "config \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> config" where
+  "config_update_fwd cfg j d \<equiv> (fst cfg, (snd cfg)[j:=(cfg <:> j, cfg <#> j + d)])"
+
+lemma config_update_fwd_0: "config_update_fwd cfg j 0 = cfg"
+  using config_update_fwd_def by simp
+
+lemma config_update_fwd_additive:
+  "config_update_fwd (config_update_fwd cfg j d1) j d2 = (config_update_fwd cfg j (d1 + d2))"
+  using config_update_fwd_def
+  by (smt add.commute add.left_commute fst_conv le_less_linear list_update_beyond list_update_overwrite nth_list_update_eq sndI)
+
+
+subsection \<open>Moving tape heads\<close>
+
+text \<open>
+Among the most simple things a Turing machine can do is moving one of its tape
+heads.
+\<close>
+
+subsubsection \<open>Moving left\<close>
+
+text \<open>
+The next command makes a TM move its head on tape $j$ one cell to the left
+unless, of course, it is in the leftmost cell already.
+\<close>
+
+definition cmd_left :: "tapeidx \<Rightarrow> command" where
+  "cmd_left j \<equiv> \<lambda>rs. (1, map (\<lambda>i. (rs ! i, if i = j then Left else Stay)) [0..<length rs])"
+
+lemma turing_command_left: "turing_command k 1 G (cmd_left j)"
+  by (auto simp add: cmd_left_def)
+
+lemma cmd_left': "[*] (cmd_left j rs) = 1"
+  using cmd_left_def by simp
+
+lemma cmd_left'': "j < length rs \<Longrightarrow> (cmd_left j rs) [!] j = (rs ! j, Left)"
+  using cmd_left_def by simp
+
+lemma cmd_left''': "i < length rs \<Longrightarrow> i \<noteq> j \<Longrightarrow> (cmd_left j rs) [!] i = (rs ! i, Stay)"
+  using cmd_left_def by simp
+
+lemma tape_list_eq:
+  assumes "length tps' = length tps"
+    and "\<And>i. i < length tps \<Longrightarrow> i \<noteq> j \<Longrightarrow> tps' ! i = tps ! i"
+    and "tps' ! j = x"
+  shows "tps' = tps[j := x]"
+  using assms by (smt length_list_update list_update_beyond not_le nth_equalityI nth_list_update)
+
+lemma sem_cmd_left:
+  assumes "j < length tps"
+  shows "sem (cmd_left j) (0, tps) = (1, tps[j:=(fst (tps ! j), snd (tps ! j) - 1)])"
+proof
+  show "fst (sem (cmd_left j)  (0, tps)) = fst (1, tps[j := (fst (tps ! j), snd (tps ! j) - 1)])"
+    using cmd_left' sem_fst by simp
+  have "snd (sem (cmd_left j) (0, tps)) = tps[j := (fst (tps ! j), snd (tps ! j) - 1)]"
+  proof (rule tape_list_eq)
+    show "||sem (cmd_left j) (0, tps)|| = length tps"
+      using turing_command_left sem_num_tapes2' by (metis snd_eqD)
+    show "sem (cmd_left j) (0, tps) <!> i = tps ! i" if "i < length tps" and "i \<noteq> j" for i
+    proof -
+      let ?rs = "read tps"
+      have "length ?rs = length tps"
+        using read_length by simp
+      moreover have "sem (cmd_left j) (0, tps) <!> i = act (cmd_left j ?rs [!] i) (tps ! i)"
+        by (simp add: cmd_left_def sem_snd that(1))
+      ultimately show ?thesis
+        using that act_Stay cmd_left''' by simp
+    qed
+    show "sem (cmd_left j) (0, tps) <!> j = (fst (tps ! j), snd (tps ! j) - 1)"
+      using assms act_Left cmd_left_def read_length sem_snd by simp
+  qed
+  then show "snd (sem (cmd_left j) (0, tps)) = snd (1, tps[j := (fst (tps ! j), snd (tps ! j) - 1)])"
+    by simp
+qed
+
+definition tm_left :: "tapeidx \<Rightarrow> machine" where
+  "tm_left j \<equiv> [cmd_left j]"
+
+lemma tm_left_tm: "k \<ge> 2 \<Longrightarrow> G \<ge> 4 \<Longrightarrow> turing_machine k G (tm_left j)"
+  unfolding tm_left_def using turing_command_left by auto
+
+lemma exe_tm_left:
+  assumes "j < length tps"
+  shows "exe (tm_left j) (0, tps) = (1, tps[j := tps ! j |-| 1])"
+  unfolding tm_left_def using sem_cmd_left assms by (simp add: exe_lt_length)
+
+lemma execute_tm_left:
+  assumes "j < length tps"
+  shows "execute (tm_left j) (0, tps) (Suc 0) = (1, tps[j := tps ! j |-| 1])"
+  using assms exe_tm_left by simp
+
+lemma transits_tm_left:
+  assumes "j < length tps"
+  shows "transits (tm_left j) (0, tps) (Suc 0) (1, tps[j := tps ! j |-| 1])"
+  using execute_tm_left assms transitsI by blast
+
+lemma transforms_tm_left:
+  assumes "j < length tps"
+  shows "transforms (tm_left j) tps (Suc 0) (tps[j := tps ! j |-| 1])"
+  using transits_tm_left assms by (simp add: tm_left_def transforms_def)
+
+lemma transforms_tm_leftI [transforms_intros]:
+  assumes "j < length tps"
+    and "t = 1"
+    and "tps' = tps[j := tps ! j |-| 1]"
+  shows "transforms (tm_left j) tps t tps'"
+  using transits_tm_left assms by (simp add: tm_left_def transforms_def)
+
+
+subsubsection \<open>Moving right\<close>
+
+text \<open>
+The next command makes the head on tape $j$ move one cell to the right.
+\<close>
+
+definition cmd_right :: "tapeidx \<Rightarrow> command" where
+  "cmd_right j \<equiv> \<lambda>rs. (1, map (\<lambda>i. (rs ! i, if i = j then Right else Stay)) [0..<length rs])"
+
+lemma turing_command_right: "turing_command k 1 G (cmd_right j)"
+  by (auto simp add: cmd_right_def)
+
+lemma cmd_right': "[*] (cmd_right j rs) = 1"
+  using cmd_right_def by simp
+
+lemma cmd_right'': "j < length rs \<Longrightarrow> (cmd_right j rs) [!] j = (rs ! j, Right)"
+  using cmd_right_def by simp
+
+lemma cmd_right''': "i < length rs \<Longrightarrow> i \<noteq> j \<Longrightarrow> (cmd_right j rs) [!] i = (rs ! i, Stay)"
+  using cmd_right_def by simp
+
+lemma sem_cmd_right:
+  assumes "j < length tps"
+  shows "sem (cmd_right j) (0, tps) = (1, tps[j:=(fst (tps ! j), snd (tps ! j) + 1)])"
+proof
+  show "fst (sem (cmd_right j)  (0, tps)) = fst (1, tps[j := (fst (tps ! j), snd (tps ! j) + 1)])"
+    using cmd_right' sem_fst by simp
+  have "snd (sem (cmd_right j) (0, tps)) = tps[j := (fst (tps ! j), snd (tps ! j) + 1)]"
+  proof (rule tape_list_eq)
+    show "||sem (cmd_right j) (0, tps)|| = length tps"
+      using sem_num_tapes3 turing_command_right by (metis snd_conv)
+    show "sem (cmd_right j) (0, tps) <!> i = tps ! i" if "i < length tps" and "i \<noteq> j" for i
+    proof -
+      let ?rs = "read tps"
+      have "length ?rs = length tps"
+        using read_length by simp
+      moreover have "sem (cmd_right j) (0, tps) <!> i = act (cmd_right j ?rs [!] i) (tps ! i)"
+        by (simp add: cmd_right_def sem_snd that(1))
+      ultimately show ?thesis
+        using that act_Stay cmd_right''' by simp
+    qed
+    show "sem (cmd_right j) (0, tps) <!> j = (fst (tps ! j), snd (tps ! j) + 1)"
+      using assms act_Right cmd_right_def read_length sem_snd by simp
+  qed
+  then show "snd (sem (cmd_right j) (0, tps)) = snd (1, tps[j := (fst (tps ! j), snd (tps ! j) + 1)])"
+    by simp
+qed
+
+definition tm_right :: "tapeidx \<Rightarrow> machine" where
+  "tm_right j \<equiv> [cmd_right j]"
+
+lemma tm_right_tm: "k \<ge> 2 \<Longrightarrow> G \<ge> 4 \<Longrightarrow> turing_machine k G (tm_right j)"
+  unfolding tm_right_def using turing_command_right cmd_right' by auto
+
+lemma exe_tm_right:
+  assumes "j < length tps"
+  shows "exe (tm_right j) (0, tps) = (1, tps[j:=(fst (tps ! j), snd (tps ! j) + 1)])"
+  unfolding tm_right_def using sem_cmd_right assms by (simp add: exe_lt_length)
+
+lemma execute_tm_right:
+  assumes "j < length tps"
+  shows "execute (tm_right j) (0, tps) (Suc 0) = (1, tps[j:=(fst (tps ! j), snd (tps ! j) + 1)])"
+  using assms exe_tm_right by simp
+
+lemma transits_tm_right:
+  assumes "j < length tps"
+  shows "transits (tm_right j) (0, tps) (Suc 0) (1, tps[j:=(fst (tps ! j), snd (tps ! j) + 1)])"
+  using execute_tm_right assms transitsI by blast
+
+lemma transforms_tm_right:
+  assumes "j < length tps"
+  shows "transforms (tm_right j) tps (Suc 0) (tps[j := tps ! j |+| 1])"
+  using transits_tm_right assms by (simp add: tm_right_def transforms_def)
+
+lemma transforms_tm_rightI [transforms_intros]:
+  assumes "j < length tps"
+    and "t = Suc 0"
+    and "tps' = tps[j := tps ! j |+| 1]"
+  shows "transforms (tm_right j) tps t tps'"
+  using transits_tm_right assms by (simp add: tm_right_def transforms_def)
+
+
+subsubsection \<open>Moving right on several tapes\<close>
+
+text \<open>
+The next command makes the heads on all tapes from a set $J$ of tapes move one
+cell to the right.
+\<close>
+
+definition cmd_right_many :: "tapeidx set \<Rightarrow> command" where
+  "cmd_right_many J \<equiv> \<lambda>rs. (1, map (\<lambda>i. (rs ! i, if i \<in> J then Right else Stay)) [0..<length rs])"
+
+lemma turing_command_right_many: "turing_command k 1 G (cmd_right_many J)"
+  by (auto simp add: cmd_right_many_def)
+
+lemma sem_cmd_right_many:
+  "sem (cmd_right_many J) (0, tps) = (1, map (\<lambda>j. if j \<in> J then tps ! j |+| 1 else tps ! j) [0..<length tps])"
+proof
+  show "fst (sem (cmd_right_many J)  (0, tps)) =
+      fst (1, map (\<lambda>j. if j \<in> J then tps ! j |+| 1 else tps ! j) [0..<length tps])"
+    using cmd_right_many_def sem_fst by simp
+  have "snd (sem (cmd_right_many J) (0, tps)) =
+    map (\<lambda>j. if j \<in> J then tps ! j |+| 1 else tps ! j) [0..<length tps]"
+    (is "?lhs = ?rhs")
+  proof (rule nth_equalityI)
+    show "length ?lhs = length ?rhs"
+      using turing_command_right_many sem_num_tapes2'
+      by (metis (no_types, lifting) diff_zero length_map length_upt snd_conv)
+    then have len: "length ?lhs = length tps"
+      by simp
+    show "?lhs ! j = ?rhs ! j" if "j < length ?lhs" for j
+    proof (cases "j \<in> J")
+      case True
+      let ?rs = "read tps"
+      have "length ?rs = length tps"
+        using read_length by simp
+      moreover have "sem (cmd_right_many J) (0, tps) <!> j = act (cmd_right_many J ?rs [!] j) (tps ! j)"
+        using cmd_right_many_def sem_snd that True len by auto
+      moreover have "?rhs ! j = tps ! j |+| 1"
+        using that len True by simp
+      ultimately show ?thesis
+        using that act_Right cmd_right_many_def True len by simp
+    next
+      case False
+      let ?rs = "read tps"
+      have "length ?rs = length tps"
+        using read_length by simp
+      moreover have "sem (cmd_right_many J) (0, tps) <!> j = act (cmd_right_many J ?rs [!] j) (tps ! j)"
+        using cmd_right_many_def sem_snd that False len by auto
+      moreover have "?rhs ! j = tps ! j"
+        using that len False by simp
+      ultimately show ?thesis
+        using that act_Stay cmd_right_many_def False len by simp
+    qed
+  qed
+  then show "snd (sem (cmd_right_many J) (0, tps)) =
+      snd (1, map (\<lambda>j. if j \<in> J then tps ! j |+| 1 else tps ! j) [0..<length tps])"
+    by simp
+qed
+
+definition tm_right_many :: "tapeidx set \<Rightarrow> machine" where
+  "tm_right_many J \<equiv> [cmd_right_many J]"
+
+lemma tm_right_many_tm: "k \<ge> 2 \<Longrightarrow> G \<ge> 4 \<Longrightarrow> turing_machine k G (tm_right_many J)"
+  unfolding tm_right_many_def using turing_command_right_many by auto
+
+lemma transforms_tm_right_manyI [transforms_intros]:
+  assumes "t = Suc 0"
+    and "tps' = map (\<lambda>j. if j \<in> J then tps ! j |+| 1 else tps ! j) [0..<length tps]"
+  shows "transforms (tm_right_many J) tps t tps'"
+proof -
+  have "exe (tm_right_many J) (0, tps) = (1, map (\<lambda>j. if j \<in> J then tps ! j |+| 1 else tps ! j) [0..<length tps])"
+    unfolding tm_right_many_def using sem_cmd_right_many by (simp add: exe_lt_length)
+  then have "execute (tm_right_many J) (0, tps) (Suc 0) = (1, map (\<lambda>j. if j \<in> J then tps ! j |+| 1 else tps ! j) [0..<length tps])"
+    by simp
+  then have "transits (tm_right_many J) (0, tps) (Suc 0) (1, map (\<lambda>j. if j \<in> J then tps ! j |+| 1 else tps ! j) [0..<length tps])"
+    using transitsI by blast
+  then have "transforms (tm_right_many J) tps (Suc 0) (map (\<lambda>j. if j \<in> J then tps ! j |+| 1 else tps ! j) [0..<length tps])"
+    by (simp add: tm_right_many_def transforms_def)
+  then show ?thesis
+    using assms by (simp add: tm_right_many_def transforms_def)
+qed
+
+
+subsection \<open>Copying and translating tape contents\<close>
+
+text \<open>
+The Turing machines in this section scan a tape $j_1$ and copy the symbols to
+another tape $j_2$. Scanning can be performed in either direction, and ``copying''
+may include mapping the symbols.
+\<close>
+
+
+subsubsection \<open>Copying and translating from one tape to another\<close>
+
+text \<open>
+The next predicate is true iff.\ on the given tape the next symbol from the set
+$H$ of symbols is exactly $n$ cells to the right from the current head position.
+Thus, a command that moves the tape head right until it finds a symbol from $H$
+takes $n$ steps and moves the head $n$ cells right.
+\<close>
+
+definition rneigh :: "tape \<Rightarrow> symbol set \<Rightarrow> nat \<Rightarrow> bool" where
+  "rneigh tp H n \<equiv> fst tp (snd tp + n) \<in> H \<and> (\<forall>n' < n. fst tp (snd tp + n') \<notin> H)"
+
+lemma rneighI:
+  assumes "fst tp (snd tp + n) \<in> H" and "\<And>n'. n' < n \<Longrightarrow> fst tp (snd tp + n') \<notin> H"
+  shows "rneigh tp H n"
+  using assms rneigh_def by simp
+
+text \<open>
+The analogous predicate for moving to the left:
+\<close>
+
+definition lneigh :: "tape \<Rightarrow> symbol set \<Rightarrow> nat \<Rightarrow> bool" where
+  "lneigh tp H n \<equiv> fst tp (snd tp - n) \<in> H \<and> (\<forall>n' < n. fst tp (snd tp - n') \<notin> H)"
+
+lemma lneighI:
+  assumes "fst tp (snd tp - n) \<in> H" and "\<And>n'. n' < n \<Longrightarrow> fst tp (snd tp - n') \<notin> H"
+  shows "lneigh tp H n"
+  using assms lneigh_def by simp
+
+text \<open>
+The next command scans tape $j_1$ rightward until it reaches a symbol from the
+set $H$. While doing so it copies the symbols, after applying a mapping $f$, to
+tape $j_2$.
+\<close>
+
+definition cmd_trans_until :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol set \<Rightarrow> (symbol \<Rightarrow> symbol) \<Rightarrow> command" where
+  "cmd_trans_until j1 j2 H f \<equiv> \<lambda>rs.
+    if rs ! j1 \<in> H
+    then (1, map (\<lambda>r. (r, Stay)) rs)
+    else (0, map (\<lambda>i. (if i = j2 then f (rs ! j1) else rs ! i, if i = j1 \<or> i = j2 then Right else Stay)) [0..<length rs])"
+
+text \<open>
+The analogous command for moving to the left:
+\<close>
+
+definition cmd_ltrans_until :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol set \<Rightarrow> (symbol \<Rightarrow> symbol) \<Rightarrow> command" where
+  "cmd_ltrans_until j1 j2 H f \<equiv> \<lambda>rs.
+    if rs ! j1 \<in> H
+    then (1, map (\<lambda>r. (r, Stay)) rs)
+    else (0, map (\<lambda>i. (if i = j2 then f (rs ! j1) else rs ! i, if i = j1 \<or> i = j2 then Left else Stay)) [0..<length rs])"
+
+lemma proper_cmd_trans_until: "proper_command k (cmd_trans_until j1 j2 H f)"
+  using cmd_trans_until_def by simp
+
+lemma proper_cmd_ltrans_until: "proper_command k (cmd_ltrans_until j1 j2 H f)"
+  using cmd_ltrans_until_def by simp
+
+lemma sem_cmd_trans_until_1:
+  assumes "j1 < k" and "length tps = k" and "(0, tps) <.> j1 \<in> H"
+  shows "sem (cmd_trans_until j1 j2 H f) (0, tps) = (1, tps)"
+  using cmd_trans_until_def tapes_at_read read_length assms act_Stay
+  by (intro semI[OF proper_cmd_trans_until]) auto
+
+lemma sem_cmd_ltrans_until_1:
+  assumes "j1 < k" and "length tps = k" and "(0, tps) <.> j1 \<in> H"
+  shows "sem (cmd_ltrans_until j1 j2 H f) (0, tps) = (1, tps)"
+  using cmd_ltrans_until_def tapes_at_read read_length assms act_Stay
+  by (intro semI[OF proper_cmd_ltrans_until]) auto
+
+lemma sem_cmd_trans_until_2:
+  assumes "j1 < k" and "length tps = k" and "(0, tps) <.> j1 \<notin> H"
+  shows "sem (cmd_trans_until j1 j2 H f) (0, tps) =
+    (0, tps[j1 := tps ! j1 |+| 1, j2 := tps ! j2 |:=| (f (tps :.: j1)) |+| 1])"
+  using cmd_trans_until_def tapes_at_read read_length assms act_Stay act_Right
+  by (intro semI[OF proper_cmd_trans_until]) auto
+
+lemma sem_cmd_ltrans_until_2:
+  assumes "j1 < k" and "length tps = k" and "(0, tps) <.> j1 \<notin> H"
+  shows "sem (cmd_ltrans_until j1 j2 H f) (0, tps) =
+    (0, tps[j1 := tps ! j1 |-| 1, j2 := tps ! j2 |:=| (f (tps :.: j1)) |-| 1])"
+  using cmd_ltrans_until_def tapes_at_read read_length assms act_Stay act_Left
+  by (intro semI[OF proper_cmd_ltrans_until]) auto
+
+definition tm_trans_until :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol set \<Rightarrow> (symbol \<Rightarrow> symbol) \<Rightarrow> machine" where
+  "tm_trans_until j1 j2 H f \<equiv> [cmd_trans_until j1 j2 H f]"
+
+definition tm_ltrans_until :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol set \<Rightarrow> (symbol \<Rightarrow> symbol) \<Rightarrow> machine" where
+  "tm_ltrans_until j1 j2 H f \<equiv> [cmd_ltrans_until j1 j2 H f]"
+
+lemma tm_trans_until_tm:
+  assumes "0 < j2" and "j1 < k" and "j2 < k" and "\<forall>h<G. f h < G" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_trans_until j1 j2 H f)"
+  unfolding tm_trans_until_def cmd_trans_until_def using assms turing_machine_def by auto
+
+lemma tm_ltrans_until_tm:
+  assumes "0 < j2" and "j1 < k" and "j2 < k" and "\<forall>h<G. f h < G" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_ltrans_until j1 j2 H f)"
+  unfolding tm_ltrans_until_def cmd_ltrans_until_def using assms turing_machine_def by auto
+
+lemma exe_tm_trans_until_1:
+  assumes "j1 < k" and "length tps = k" and "(0, tps) <.> j1 \<in> H"
+  shows "exe (tm_trans_until j1 j2 H f) (0, tps) = (1, tps)"
+  unfolding tm_trans_until_def using sem_cmd_trans_until_1 assms exe_lt_length by simp
+
+lemma exe_tm_ltrans_until_1:
+  assumes "j1 < k" and "length tps = k" and "(0, tps) <.> j1 \<in> H"
+  shows "exe (tm_ltrans_until j1 j2 H f) (0, tps) = (1, tps)"
+  unfolding tm_ltrans_until_def using sem_cmd_ltrans_until_1 assms exe_lt_length by simp
+
+lemma exe_tm_trans_until_2:
+  assumes "j1 < k" and "length tps = k" and "(0, tps) <.> j1 \<notin> H"
+  shows "exe (tm_trans_until j1 j2 H f) (0, tps) =
+    (0, tps[j1 := tps ! j1 |+| 1, j2 := tps ! j2 |:=| (f (tps :.: j1)) |+| 1])"
+  unfolding tm_trans_until_def using sem_cmd_trans_until_2 assms exe_lt_length by simp
+
+lemma exe_tm_ltrans_until_2:
+  assumes "j1 < k" and "length tps = k" and "(0, tps) <.> j1 \<notin> H"
+  shows "exe (tm_ltrans_until j1 j2 H f) (0, tps) =
+    (0, tps[j1 := tps ! j1 |-| 1, j2 := tps ! j2 |:=| (f (tps :.: j1)) |-| 1])"
+  unfolding tm_ltrans_until_def using sem_cmd_ltrans_until_2 assms exe_lt_length by simp
+
+text \<open>
+Let $tp_1$ and $tp_2$ be two tapes with head positions $i_1$ and $i_2$,
+respectively. The next function describes the result of overwriting the symbols
+at positions $i_2, \dots, i_2 + n - 1$ on tape $tp_2$ by the symbols at
+positions $i_1, \dots, i_1 + n - 1$ on tape $tp_1$ after applying a symbol map
+$f$.
+\<close>
+
+definition transplant :: "tape \<Rightarrow> tape \<Rightarrow> (symbol \<Rightarrow> symbol)\<Rightarrow> nat \<Rightarrow> tape" where
+  "transplant tp1 tp2 f n \<equiv>
+     (\<lambda>i. if snd tp2 \<le> i \<and> i < snd tp2 + n then f (fst tp1 (snd tp1 + i - snd tp2)) else fst tp2 i,
+      snd tp2 + n)"
+
+text \<open>
+The analogous function for moving to the left while copying:
+\<close>
+
+definition ltransplant :: "tape \<Rightarrow> tape \<Rightarrow> (symbol \<Rightarrow> symbol)\<Rightarrow> nat \<Rightarrow> tape" where
+  "ltransplant tp1 tp2 f n \<equiv>
+     (\<lambda>i. if snd tp2 - n < i \<and> i \<le> snd tp2 then f (fst tp1 (snd tp1 + i - snd tp2)) else fst tp2 i,
+      snd tp2 - n)"
+
+lemma transplant_0: "transplant tp1 tp2 f 0 = tp2"
+  unfolding transplant_def by standard auto
+
+lemma ltransplant_0: "ltransplant tp1 tp2 f 0 = tp2"
+  unfolding ltransplant_def by standard auto
+
+lemma transplant_upd: "transplant tp1 tp2 f n |:=| (f ( |.| (tp1 |+| n))) |+| 1 = transplant tp1 tp2 f (Suc n)"
+  unfolding transplant_def by auto
+
+lemma ltransplant_upd:
+  assumes "n < snd tp2"
+  shows "ltransplant tp1 tp2 f n |:=| (f ( |.| (tp1 |-| n))) |-| 1 = ltransplant tp1 tp2 f (Suc n)"
+  unfolding ltransplant_def using assms by fastforce
+
+lemma tapes_ltransplant_upd:
+  assumes "t < tps :#: j2" and "t < tps :#: j1" and "j1 < k" and "j2 < k" and "length tps = k"
+    and "tps' = tps[j1 := tps ! j1 |-| t, j2 := ltransplant (tps ! j1) (tps ! j2) f t]"
+  shows "tps'[j1 := tps' ! j1 |-| 1, j2 := tps' ! j2 |:=| (f (tps' :.: j1)) |-| 1] =
+    tps[j1 := tps ! j1 |-| Suc t, j2 := ltransplant (tps ! j1) (tps ! j2) f (Suc t)]"
+    (is "?lhs = ?rhs")
+proof (rule nth_equalityI)
+  show 1: "length ?lhs = length ?rhs"
+    using assms by simp
+  have len: "length ?lhs = k"
+    using assms by simp
+  show "?lhs ! j = ?rhs ! j" if "j < length ?lhs" for j
+  proof -
+    have "j < k"
+      using len that by simp
+    show ?thesis
+    proof (cases "j \<noteq> j1 \<and> j \<noteq> j2")
+      case True
+      then show ?thesis
+        using assms by simp
+    next
+      case j1j2: False
+      show ?thesis
+      proof (cases "j1 = j2")
+        case True
+        then have j: "j = j1" "j = j2"
+          using j1j2 by simp_all
+        have "tps' ! j1 = ltransplant (tps ! j1) (tps ! j2) f t"
+          using j assms that by simp
+        then have *: "snd (tps' ! j1) = snd (tps ! j1) - t"
+          using j ltransplant_def by simp
+        then have "fst (tps' ! j1) =
+          (\<lambda>i. if snd (tps ! j2) - t < i \<and> i \<le> snd (tps ! j2) then f (fst (tps ! j1) (snd (tps ! j1) + i - snd (tps ! j2))) else fst (tps ! j2) i)"
+          using j ltransplant_def assms by auto
+        then have "fst (tps' ! j1) =
+          (\<lambda>i. if snd (tps ! j1) - t < i \<and> i \<le> snd (tps ! j1) then f (fst (tps ! j1) (snd (tps ! j1) + i - snd (tps ! j1))) else fst (tps ! j1) i)"
+         using j by auto
+        then have "fst (tps' ! j1) (snd (tps ! j1) - t) = fst (tps ! j1) (snd (tps ! j1) - t)"
+          by simp
+        then have "tps' :.: j1 = fst (tps ! j1) (snd (tps ! j1) - t)"
+          using * by simp
+        then have "?lhs ! j = (ltransplant (tps ! j1) (tps ! j2) f t) |:=| (f ( |.| (tps ! j1 |-| t))) |-| 1"
+          using assms(6) j that by simp
+        then have "?lhs ! j = (ltransplant (tps ! j1) (tps ! j2) f (Suc t))"
+          using ltransplant_upd assms(1) by simp
+        moreover have "?rhs ! j = ltransplant (tps ! j1) (tps ! j2) f (Suc t)"
+          using assms(6) that j by simp
+        ultimately show ?thesis
+          by simp
+      next
+        case j1_neq_j2: False
+        then show ?thesis
+        proof (cases "j = j1")
+          case True
+          then have "?lhs ! j = tps' ! j1 |-| 1"
+            using assms j1_neq_j2 by simp
+          then have "?lhs ! j = (tps ! j1 |-| t) |-| 1"
+            using assms j1_neq_j2 by simp
+          moreover have "?rhs ! j = tps ! j1 |-| Suc t"
+            using True assms j1_neq_j2 by simp
+          ultimately show ?thesis
+            by simp
+        next
+          case False
+          then have j: "j = j2"
+            using j1j2 by simp
+          then have "?lhs ! j = tps' ! j2 |:=| (f (tps' :.: j1)) |-| 1"
+            using assms by simp
+          then have "?lhs ! j = (ltransplant (tps ! j1) (tps ! j2) f t) |:=| (f (tps' :.: j1)) |-| 1"
+            using assms by simp
+          then have "?lhs ! j = (ltransplant (tps ! j1) (tps ! j2) f (Suc t))"
+            using ltransplant_def assms ltransplant_upd by (smt (z3) j1_neq_j2 nth_list_update_eq nth_list_update_neq)
+          moreover have "?rhs ! j = ltransplant (tps ! j1) (tps ! j2) f (Suc t)"
+            using assms(6) that j by simp
+          ultimately show ?thesis
+            by simp
+        qed
+      qed
+    qed
+  qed
+qed
+
+lemma execute_tm_trans_until_less:
+  assumes "j1 < k" and "j2 < k" and "length tps = k" and "rneigh (tps ! j1) H n" and "t \<le> n"
+  shows "execute (tm_trans_until j1 j2 H f) (0, tps) t =
+    (0, tps[j1 := tps ! j1 |+| t, j2 := transplant (tps ! j1) (tps ! j2) f t])"
+  using assms(5)
+proof (induction t)
+  case 0
+  then show ?case
+    using transplant_0 by simp
+next
+  case (Suc t)
+  then have "t < n" by simp
+  let ?M = "tm_trans_until j1 j2 H f"
+  have "execute ?M (0, tps) (Suc t) = exe ?M (execute ?M (0, tps) t)"
+    by simp
+  also have "... = exe ?M (0, tps[j1 := tps ! j1 |+| t, j2 := transplant (tps ! j1) (tps ! j2) f t])"
+      (is "_ = exe ?M (0, ?tps)")
+    using Suc by simp
+  also have "... = (0, ?tps[j1 := ?tps ! j1 |+| 1, j2 := ?tps ! j2 |:=| (f (?tps :.: j1)) |+| 1])"
+  proof (rule exe_tm_trans_until_2[where ?k=k])
+    show "j1 < k"
+      using assms(1) .
+    show "length (tps[j1 := tps ! j1 |+| t, j2 := transplant (tps ! j1) (tps ! j2) f t]) = k"
+      using assms by simp
+    show "(0, tps[j1 := tps ! j1 |+| t, j2 := transplant (tps ! j1) (tps ! j2) f t]) <.> j1 \<notin> H"
+      using assms transplant_def rneigh_def \<open>t < n\<close>
+      by (smt fst_conv length_list_update less_not_refl2 nth_list_update_eq nth_list_update_neq snd_conv)
+  qed
+  finally show ?case
+    using assms transplant_upd
+    by auto
+      (smt add.commute fst_conv transplant_def transplant_upd less_not_refl2 list_update_overwrite list_update_swap
+       nth_list_update_eq nth_list_update_neq plus_1_eq_Suc snd_conv)
+qed
+
+lemma execute_tm_ltrans_until_less:
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "lneigh (tps ! j1) H n"
+    and "t \<le> n"
+    and "n \<le> tps :#: j1"
+    and "n \<le> tps :#: j2"
+  shows "execute (tm_ltrans_until j1 j2 H f) (0, tps) t =
+    (0, tps[j1 := tps ! j1 |-| t, j2 := ltransplant (tps ! j1) (tps ! j2) f t])"
+  using assms(5)
+proof (induction t)
+  case 0
+  then show ?case
+    using ltransplant_0 by simp
+next
+  case (Suc t)
+  then have "t < n"
+    by simp
+  have 1: "t < tps :#: j2"
+    using assms(7) Suc by simp
+  have 2: "t < tps :#: j1"
+    using assms(6) Suc by simp
+  let ?M = "tm_ltrans_until j1 j2 H f"
+  define tps' where "tps' = tps[j1 := tps ! j1 |-| t, j2 := ltransplant (tps ! j1) (tps ! j2) f t]"
+  have "execute ?M (0, tps) (Suc t) = exe ?M (execute ?M (0, tps) t)"
+    by simp
+  also have "... = exe ?M (0, tps')"
+    using Suc tps'_def by simp
+  also have "... = (0, tps'[j1 := tps' ! j1 |-| 1, j2 := tps' ! j2 |:=| (f (tps' :.: j1)) |-| 1])"
+  proof (rule exe_tm_ltrans_until_2[where ?k=k])
+    show "j1 < k"
+      using assms(1) .
+    show "length tps' = k"
+      using assms tps'_def by simp
+    show "(0, tps') <.> j1 \<notin> H"
+      using assms ltransplant_def tps'_def lneigh_def \<open>t < n\<close>
+      by (smt fst_conv length_list_update less_not_refl2 nth_list_update_eq nth_list_update_neq snd_conv)
+  qed
+  finally show ?case
+    using tapes_ltransplant_upd[OF 1 2 assms(1,2,3) tps'_def] by simp
+qed
+
+lemma execute_tm_trans_until:
+  assumes "j1 < k" and "j2 < k" and "length tps = k" and "rneigh (tps ! j1) H n"
+  shows "execute (tm_trans_until j1 j2 H f) (0, tps) (Suc n) =
+    (1, tps[j1 := tps ! j1 |+| n, j2 := transplant (tps ! j1) (tps ! j2) f n])"
+proof -
+  let ?M = "tm_trans_until j1 j2 H f"
+  have "execute ?M (0, tps) (Suc n) = exe ?M (execute ?M (0, tps) n)"
+    by simp
+  also have "... = exe ?M (0, tps[j1 := tps ! j1 |+| n, j2 := transplant (tps ! j1) (tps ! j2) f n])"
+    using execute_tm_trans_until_less[where ?t=n] assms by simp
+  also have "... = (1, tps[j1 := tps ! j1 |+| n, j2 := transplant (tps ! j1) (tps ! j2) f n])"
+      (is "_ = (1, ?tps)")
+  proof -
+    have "length ?tps = k"
+      using assms(3) by simp
+    moreover have "(0, ?tps) <.> j1 \<in> H"
+      using rneigh_def transplant_def assms
+      by (smt fst_conv length_list_update less_not_refl2 nth_list_update_eq nth_list_update_neq snd_conv)
+    ultimately show ?thesis
+      using exe_tm_trans_until_1 assms by simp
+  qed
+  finally show ?thesis by simp
+qed
+
+lemma execute_tm_ltrans_until:
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "lneigh (tps ! j1) H n"
+    and "n \<le> tps :#: j1"
+    and "n \<le> tps :#: j2"
+  shows "execute (tm_ltrans_until j1 j2 H f) (0, tps) (Suc n) =
+    (1, tps[j1 := tps ! j1 |-| n, j2 := ltransplant (tps ! j1) (tps ! j2) f n])"
+proof -
+  let ?M = "tm_ltrans_until j1 j2 H f"
+  have "execute ?M (0, tps) (Suc n) = exe ?M (execute ?M (0, tps) n)"
+    by simp
+  also have "... = exe ?M (0, tps[j1 := tps ! j1 |-| n, j2 := ltransplant (tps ! j1) (tps ! j2) f n])"
+    using execute_tm_ltrans_until_less[where ?t=n] assms by simp
+  also have "... = (1, tps[j1 := tps ! j1 |-| n, j2 := ltransplant (tps ! j1) (tps ! j2) f n])"
+      (is "_ = (1, ?tps)")
+  proof -
+    have "length ?tps = k"
+      using assms(3) by simp
+    moreover have "(0, ?tps) <.> j1 \<in> H"
+      using lneigh_def ltransplant_def assms
+      by (smt (verit, ccfv_threshold) fst_conv length_list_update less_not_refl nth_list_update_eq nth_list_update_neq snd_conv)
+    ultimately show ?thesis
+      using exe_tm_ltrans_until_1 assms by simp
+  qed
+  finally show ?thesis by simp
+qed
+
+lemma transits_tm_trans_until:
+  assumes "j1 < k" and "j2 < k" and "length tps = k" and "rneigh (tps ! j1) H n"
+  shows "transits (tm_trans_until j1 j2 H f)
+    (0, tps)
+    (Suc n)
+    (1, tps[j1 := tps ! j1 |+| n, j2 := transplant (tps ! j1) (tps ! j2) f n])"
+  using execute_tm_trans_until[OF assms] transitsI[of _ _ "Suc n" _ "Suc n"] by blast
+
+lemma transits_tm_ltrans_until:
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "lneigh (tps ! j1) H n"
+    and "n \<le> tps :#: j1"
+    and "n \<le> tps :#: j2"
+  shows "transits (tm_ltrans_until j1 j2 H f)
+    (0, tps)
+    (Suc n)
+    (1, tps[j1 := tps ! j1 |-| n, j2 := ltransplant (tps ! j1) (tps ! j2) f n])"
+  using execute_tm_ltrans_until[OF assms] transitsI[of _ _ "Suc n" _ "Suc n"] by blast
+
+lemma transforms_tm_trans_until:
+  assumes "j1 < k" and "j2 < k" and "length tps = k" and "rneigh (tps ! j1) H n"
+  shows "transforms (tm_trans_until j1 j2 H f)
+    tps
+    (Suc n)
+    (tps[j1 := tps ! j1 |+| n, j2 := transplant (tps ! j1) (tps ! j2) f n])"
+  using tm_trans_until_def transforms_def transits_tm_trans_until[OF assms] by simp
+
+lemma transforms_tm_ltrans_until:
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "lneigh (tps ! j1) H n"
+    and "n \<le> tps :#: j1"
+    and "n \<le> tps :#: j2"
+  shows "transforms (tm_ltrans_until j1 j2 H f)
+    tps
+    (Suc n)
+    (tps[j1 := tps ! j1 |-| n, j2 := ltransplant (tps ! j1) (tps ! j2) f n])"
+  using tm_ltrans_until_def transforms_def transits_tm_ltrans_until[OF assms] by simp
+
+corollary transforms_tm_trans_untilI [transforms_intros]:
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "rneigh (tps ! j1) H n"
+    and "t = Suc n"
+    and "tps' = tps[j1 := tps ! j1 |+| n, j2 := transplant (tps ! j1) (tps ! j2) f n]"
+  shows "transforms (tm_trans_until j1 j2 H f) tps t tps'"
+  using transforms_tm_trans_until[OF assms(1-4)] assms(5,6) by simp
+
+corollary transforms_tm_ltrans_untilI [transforms_intros]:
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "lneigh (tps ! j1) H n"
+    and "n \<le> tps :#: j1"
+    and "n \<le> tps :#: j2"
+    and "t = Suc n"
+    and "tps' = tps[j1 := tps ! j1 |-| n, j2 := ltransplant (tps ! j1) (tps ! j2) f n]"
+  shows "transforms (tm_ltrans_until j1 j2 H f) tps t tps'"
+  using transforms_tm_ltrans_until[OF assms(1-6)] assms(7,8) by simp
+
+
+subsubsection \<open>Copying one tape to another\<close>
+
+text \<open>
+If we set the symbol map $f$ in @{const tm_trans_until} to the identity
+function, we get a Turing machine that simply makes a copy.
+\<close>
+
+definition tm_cp_until :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol set \<Rightarrow> machine" where
+  "tm_cp_until j1 j2 H \<equiv> tm_trans_until j1 j2 H id"
+
+lemma id_symbol: "\<forall>h<G. (id :: symbol \<Rightarrow> symbol) h < G"
+  by simp
+
+lemma tm_cp_until_tm:
+  assumes "0 < j2" and "j1 < k" and "j2 < k" and "G \<ge> 4"
+  shows "turing_machine k G (tm_cp_until j1 j2 H)"
+  unfolding tm_cp_until_def using tm_trans_until_tm id_symbol assms turing_machine_def by simp
+
+abbreviation implant :: "tape \<Rightarrow> tape \<Rightarrow> nat \<Rightarrow> tape" where
+  "implant tp1 tp2 n \<equiv> transplant tp1 tp2 id n"
+
+lemma implant: "implant tp1 tp2 n =
+     (\<lambda>i. if snd tp2 \<le> i \<and> i < snd tp2 + n then fst tp1 (snd tp1 + i - snd tp2) else fst tp2 i,
+      snd tp2 + n)"
+  using transplant_def by auto
+
+lemma implantI:
+  assumes "tp' =
+     (\<lambda>i. if snd tp2 \<le> i \<and> i < snd tp2 + n then fst tp1 (snd tp1 + i - snd tp2) else fst tp2 i,
+      snd tp2 + n)"
+  shows "implant tp1 tp2 n = tp'"
+  using implant assms by simp
+
+lemma fst_snd_pair: "fst t = a \<Longrightarrow> snd t = b \<Longrightarrow> t = (a, b)"
+  by auto
+
+lemma implantI':
+  assumes "fst tp' =
+     (\<lambda>i. if snd tp2 \<le> i \<and> i < snd tp2 + n then fst tp1 (snd tp1 + i - snd tp2) else fst tp2 i)"
+    and "snd tp' = snd tp2 + n"
+  shows "implant tp1 tp2 n = tp'"
+  using implantI fst_snd_pair[OF assms] by simp
+
+lemma implantI'':
+  assumes "\<And>i. snd tp2 \<le> i \<and> i < snd tp2 + n \<Longrightarrow> fst tp' i = fst tp1 (snd tp1 + i - snd tp2)"
+    and "\<And>i. i < snd tp2 \<Longrightarrow> fst tp' i = fst tp2 i"
+    and "\<And>i. snd tp2 + n \<le> i \<Longrightarrow> fst tp' i = fst tp2 i"
+  assumes "snd tp' = snd tp2 + n"
+  shows "implant tp1 tp2 n = tp'"
+  using assms implantI' by (meson linorder_le_less_linear)
+
+lemma implantI''':
+  assumes "\<And>i. i2 \<le> i \<and> i < i2 + n \<Longrightarrow> ys i = ys1 (i1 + i - i2)"
+    and "\<And>i. i < i2 \<Longrightarrow> ys i = ys2 i"
+    and "\<And>i. i2 + n \<le> i \<Longrightarrow> ys i = ys2 i"
+  assumes "i = i2 + n"
+  shows "implant (ys1, i1) (ys2, i2) n = (ys, i)"
+  using assms implantI'' by auto
+
+lemma implant_self: "implant tp tp n = tp |+| n"
+  unfolding transplant_def by auto
+
+lemma transforms_tm_cp_untilI [transforms_intros]:
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "rneigh (tps ! j1) H n"
+    and "t = Suc n"
+    and "tps' = tps[j1 := tps ! j1 |+| n, j2 := implant (tps ! j1) (tps ! j2) n]"
+  shows "transforms (tm_cp_until j1 j2 H) tps t tps'"
+  unfolding tm_cp_until_def using transforms_tm_trans_untilI[OF assms(1-6)] by simp
+
+lemma implant_contents:
+  assumes "i > 0" and "n + (i - 1) \<le> length xs"
+  shows "implant (\<lfloor>xs\<rfloor>, i) (\<lfloor>ys\<rfloor>, Suc (length ys)) n =
+     (\<lfloor>ys @ (take n (drop (i - 1) xs))\<rfloor>, Suc (length ys) + n)"
+     (is "?lhs = ?rhs")
+proof -
+  have lhs: "?lhs =
+   (\<lambda>j. if Suc (length ys) \<le> j \<and> j < Suc (length ys) + n then \<lfloor>xs\<rfloor> (i + j - Suc (length ys)) else \<lfloor>ys\<rfloor> j,
+    Suc (length ys) + n)"
+    using implant by auto
+  let ?zs = "ys @ (take n (drop (i - 1) xs))"
+  have lenzs: "length ?zs = length ys + n"
+    using assms by simp
+  have fst_rhs: "fst ?rhs = (\<lambda>j. if j = 0 then 1 else if j \<le> length ys + n then ?zs ! (j - 1) else 0)"
+    using assms by auto
+
+  have "(\<lambda>j. if Suc (length ys) \<le> j \<and> j < Suc (length ys) + n then \<lfloor>xs\<rfloor> (i + j - Suc (length ys)) else \<lfloor>ys\<rfloor> j) =
+      (\<lambda>j. if j = 0 then 1 else if j \<le> length ys + n then ?zs ! (j - 1) else 0)"
+    (is "?l = ?r")
+  proof
+    fix j
+    consider
+        "j = 0"
+      | "j > 0 \<and> j \<le> length ys"
+      | "j > length ys \<and> j \<le> length ys + n"
+      | "j > length ys + n"
+      by linarith
+    then show "?l j = ?r j"
+    proof (cases)
+      case 1
+      then show ?thesis
+        by simp
+    next
+      case 2
+      then show ?thesis
+        using assms contents_def by (smt (z3) Suc_diff_1 less_trans_Suc not_add_less1 not_le not_less_eq_eq nth_append)
+    next
+      case 3
+      then have "?r j = ?zs ! (j - 1)"
+        by simp
+      also have "... = take n (drop (i - 1) xs) ! (j - 1 - length ys)"
+        using 3 lenzs
+        by (metis add.right_neutral diff_is_0_eq le_add_diff_inverse not_add_less2 not_le not_less_eq nth_append plus_1_eq_Suc)
+      also have "... = take n (drop (i - 1) xs) ! (j - Suc (length ys))"
+        by simp
+      also have "... = xs ! (i - 1 + j - Suc (length ys))"
+        using 3 assms by auto
+      also have "... = \<lfloor>xs\<rfloor> (i + j - Suc (length ys))"
+        using assms contents_def 3 by auto
+      also have "... = ?l j"
+        using 3 by simp
+      finally have "?r j = ?l j" .
+      then show ?thesis
+        by simp
+    next
+      case 4
+      then show ?thesis
+        by simp
+    qed
+  qed
+  then show ?thesis
+    using lhs fst_rhs by simp
+qed
+
+
+subsubsection \<open>Moving to the next specific symbol\<close>
+
+text \<open>
+Copying a tape to itself means just moving to the right.
+\<close>
+
+definition tm_right_until :: "tapeidx \<Rightarrow> symbol set \<Rightarrow> machine" where
+  "tm_right_until j H \<equiv> tm_cp_until j j H"
+
+text \<open>
+Copying a tape to itself does not change the tape. So this is a Turing machine
+even for the input tape $j = 0$, unlike @{const tm_cp_until} where
+the target tape cannot, in general, be the input tape.
+\<close>
+
+lemma tm_right_until_tm:
+  assumes "j < k" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_right_until j H)"
+  unfolding tm_right_until_def tm_cp_until_def tm_trans_until_def cmd_trans_until_def
+  using assms turing_machine_def
+  by auto
+
+lemma transforms_tm_right_untilI [transforms_intros]:
+  assumes "j < length tps"
+    and "rneigh (tps ! j) H n"
+    and "t = Suc n"
+    and "tps' = (tps[j := tps ! j |+| n])"
+  shows "transforms (tm_right_until j H) tps t tps'"
+  using transforms_tm_cp_untilI assms implant_self tm_right_until_def
+  by (metis list_update_id nth_list_update_eq)
+
+
+subsubsection \<open>Translating to a constant symbol\<close>
+
+text \<open>
+Another way to specialize @{const tm_trans_until} and @{const tm_ltrans_until}
+is to have a constant function $f$.
+\<close>
+
+definition tm_const_until :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol set \<Rightarrow> symbol \<Rightarrow> machine" where
+  "tm_const_until j1 j2 H h \<equiv> tm_trans_until j1 j2 H (\<lambda>_. h)"
+
+lemma tm_const_until_tm:
+  assumes "0 < j2" and "j1 < k" and "j2 < k" and "h < G" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_const_until j1 j2 H h)"
+  unfolding tm_const_until_def using tm_trans_until_tm assms turing_machine_def by metis
+
+text \<open>
+Continuing with our fantasy names ending in \emph{-plant}, we name the operation
+@{term constplant}.
+\<close>
+
+abbreviation constplant :: "tape \<Rightarrow> symbol \<Rightarrow> nat \<Rightarrow> tape" where
+  "constplant tp2 h n \<equiv> transplant (\<lambda>_. 0, 0) tp2 (\<lambda>_. h) n"
+
+lemma constplant_transplant: "constplant tp2 h n = transplant tp1 tp2 (\<lambda>_. h) n"
+  using transplant_def by simp
+
+lemma constplant: "constplant tp2 h n =
+     (\<lambda>i. if snd tp2 \<le> i \<and> i < snd tp2 + n then h else fst tp2 i,
+      snd tp2 + n)"
+  using transplant_def by simp
+
+lemma transforms_tm_const_untilI [transforms_intros]:
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "rneigh (tps ! j1) H n"
+    and "t = Suc n"
+    and "tps' = tps[j1 := tps ! j1 |+| n, j2 := constplant (tps ! j2) h n]"
+  shows "transforms (tm_const_until j1 j2 H h) tps t tps'"
+  unfolding tm_const_until_def using transforms_tm_trans_untilI assms constplant_transplant by metis
+
+definition tm_lconst_until :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol set \<Rightarrow> symbol \<Rightarrow> machine" where
+  "tm_lconst_until j1 j2 H h \<equiv> tm_ltrans_until j1 j2 H (\<lambda>_. h)"
+
+lemma tm_lconst_until_tm:
+  assumes "0 < j2" and "j1 < k" and "j2 < k" and "h < G" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_lconst_until j1 j2 H h)"
+  unfolding tm_lconst_until_def using tm_ltrans_until_tm assms turing_machine_def by metis
+
+abbreviation lconstplant :: "tape \<Rightarrow> symbol \<Rightarrow> nat \<Rightarrow> tape" where
+  "lconstplant tp2 h n \<equiv> ltransplant (\<lambda>_. 0, 0) tp2 (\<lambda>_. h) n"
+
+lemma lconstplant_ltransplant: "lconstplant tp2 h n = ltransplant tp1 tp2 (\<lambda>_. h) n"
+  using ltransplant_def by simp
+
+lemma lconstplant: "lconstplant tp2 h n =
+     (\<lambda>i. if snd tp2 - n < i \<and> i \<le> snd tp2 then h else fst tp2 i,
+      snd tp2 - n)"
+  using ltransplant_def by simp
+
+lemma transforms_tm_lconst_untilI [transforms_intros]:
+  assumes "0 < j2" and "j1 < k" and "j2 < k" and "length tps = k"
+    and "lneigh (tps ! j1) H n"
+    and "n \<le> tps :#: j1"
+    and "n \<le> tps :#: j2"
+    and "t = Suc n"
+    and "tps' = tps[j1 := tps ! j1 |-| n, j2 := lconstplant (tps ! j2) h n]"
+  shows "transforms (tm_lconst_until j1 j2 H h) tps t tps'"
+  unfolding tm_lconst_until_def using transforms_tm_ltrans_untilI assms lconstplant_ltransplant by metis
+
+
+subsection \<open>Writing single symbols\<close>
+
+text \<open>
+The next command writes a fixed symbol $h$ to tape $j$. It does not move a tape
+head.
+\<close>
+
+definition cmd_write :: "tapeidx \<Rightarrow> symbol \<Rightarrow> command" where
+  "cmd_write j h rs \<equiv> (1, map (\<lambda>i. (if i = j then h else rs ! i, Stay)) [0..<length rs])"
+
+lemma sem_cmd_write: "sem (cmd_write j h) (0, tps) = (1, tps[j := tps ! j |:=| h])"
+  using cmd_write_def read_length act_Stay by (intro semI) auto
+
+definition tm_write :: "tapeidx \<Rightarrow> symbol \<Rightarrow> machine" where
+  "tm_write j h \<equiv> [cmd_write j h]"
+
+lemma tm_write_tm:
+  assumes "0 < j" and "j < k" and "h < G" and "G \<ge> 4"
+  shows "turing_machine k G (tm_write j h)"
+  unfolding tm_write_def cmd_write_def using assms turing_machine_def by auto
+
+lemma transforms_tm_writeI [transforms_intros]:
+  assumes "tps' = tps[j := tps ! j |:=| h]"
+  shows "transforms (tm_write j h) tps 1 tps'"
+  unfolding tm_write_def
+  using sem_cmd_write exe_lt_length assms tm_write_def transits_def transforms_def
+  by auto
+
+text \<open>
+The next command writes the symbol to tape $j_2$ that results from applying a
+function $f$ to the symbol read from tape $j_1$. It does not move any tape heads.
+\<close>
+
+definition cmd_trans2 :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> (symbol \<Rightarrow> symbol) \<Rightarrow> command" where
+  "cmd_trans2 j1 j2 f rs \<equiv> (1, map (\<lambda>i. (if i = j2 then f (rs ! j1) else rs ! i, Stay)) [0..<length rs])"
+
+lemma sem_cmd_trans2:
+  assumes "j1 < length tps"
+  shows "sem (cmd_trans2 j1 j2 f) (0, tps) = (1, tps[j2 := tps ! j2 |:=| (f (tps :.: j1))])"
+  using cmd_trans2_def tapes_at_read assms read_length act_Stay by (intro semI) auto
+
+definition tm_trans2 :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> (symbol \<Rightarrow> symbol) \<Rightarrow> machine" where
+  "tm_trans2 j1 j2 f \<equiv> [cmd_trans2 j1 j2 f]"
+
+lemma tm_trans2_tm:
+  assumes "j1 < k" and "0 < j2" and "j2 < k" and "\<forall>h < G. f h < G" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_trans2 j1 j2 f)"
+  unfolding tm_trans2_def cmd_trans2_def using assms turing_machine_def by auto
+
+lemma exe_tm_trans2:
+  assumes "j1 < length tps"
+  shows "exe (tm_trans2 j1 j2 f) (0, tps) = (1, tps[j2 := tps ! j2 |:=| (f (tps :.: j1))])"
+  unfolding tm_trans2_def using sem_cmd_trans2 assms exe_lt_length by simp
+
+lemma execute_tm_trans2:
+  assumes "j1 < length tps"
+  shows "execute (tm_trans2 j1 j2 f) (0, tps) 1 = (1, tps[j2 := tps ! j2 |:=| (f (tps :.: j1))])"
+  using assms exe_tm_trans2 by simp
+
+lemma transits_tm_trans2:
+  assumes "j1 < length tps"
+  shows "transits (tm_trans2 j1 j2 f) (0, tps) 1 (1, tps[j2 := tps ! j2 |:=| (f (tps :.: j1))])"
+  using assms execute_tm_trans2 transits_def by auto
+
+lemma transforms_tm_trans2:
+  assumes "j1 < length tps"
+  shows "transforms (tm_trans2 j1 j2 f) tps 1 (tps[j2 := tps ! j2 |:=| (f (tps :.: j1))])"
+  using tm_trans2_def assms transits_tm_trans2 transforms_def by simp
+
+lemma transforms_tm_trans2I [transforms_intros]:
+  assumes "j1 < length tps" and "tps' = tps[j2 := tps ! j2 |:=| (f (tps :.: j1))]"
+  shows "transforms (tm_trans2 j1 j2 f) tps 1 tps'"
+  using assms transforms_tm_trans2 by simp
+
+text \<open>
+Equating the two tapes in @{const tm_trans2}, we can map a symbol in-place.
+\<close>
+
+definition tm_trans :: "tapeidx \<Rightarrow> (symbol \<Rightarrow> symbol) \<Rightarrow> machine" where
+  "tm_trans j f \<equiv> tm_trans2 j j f"
+
+lemma tm_trans_tm:
+  assumes "0 < j" and "j < k" and "\<forall>h < G. f h < G" and "G \<ge> 4"
+  shows "turing_machine k G (tm_trans j f)"
+  unfolding tm_trans_def using tm_trans2_tm assms by simp
+
+lemma transforms_tm_transI [transforms_intros]:
+  assumes "j < length tps" and "tps' = tps[j := tps ! j |:=| (f (tps :.: j))]"
+  shows "transforms (tm_trans j f) tps 1 tps'"
+  using assms transforms_tm_trans2 tm_trans_def by simp
+
+text \<open>
+The next command is like the previous one, except it also moves the tape head to
+the right.
+\<close>
+
+definition cmd_rtrans :: "tapeidx \<Rightarrow> (symbol \<Rightarrow> symbol) \<Rightarrow> command" where
+  "cmd_rtrans j f rs \<equiv> (1, map (\<lambda>i. (if i = j then f (rs ! i) else rs ! i, if i = j then Right else Stay)) [0..<length rs])"
+
+lemma sem_cmd_rtrans:
+  assumes "j < length tps"
+  shows "sem (cmd_rtrans j f) (0, tps) = (1, tps[j := tps ! j |:=| (f (tps :.: j)) |+| 1])"
+  using cmd_rtrans_def tapes_at_read read_length assms act_Stay act_Right
+  by (intro semI) auto
+
+definition tm_rtrans :: "tapeidx \<Rightarrow> (symbol \<Rightarrow> symbol) \<Rightarrow> machine" where
+  "tm_rtrans j f \<equiv> [cmd_rtrans j f]"
+
+lemma tm_rtrans_tm:
+  assumes "0 < j" and "j < k" and "\<forall>h<G. f h < G" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_rtrans j f)"
+  unfolding tm_rtrans_def cmd_rtrans_def using assms turing_machine_def by auto
+
+lemma exe_tm_rtrans:
+  assumes "j < length tps"
+  shows "exe (tm_rtrans j f) (0, tps) = (1, tps[j := tps ! j |:=| (f (tps :.: j)) |+| 1])"
+  unfolding tm_rtrans_def using sem_cmd_rtrans assms exe_lt_length by simp
+
+lemma execute_tm_rtrans:
+  assumes "j < length tps"
+  shows "execute (tm_rtrans j f) (0, tps) 1 = (1, tps[j := tps ! j |:=| (f (tps :.: j)) |+| 1])"
+  using assms exe_tm_rtrans by simp
+
+lemma transits_tm_rtrans:
+  assumes "j < length tps"
+  shows "transits (tm_rtrans j f) (0, tps) 1 (1, tps[j := tps ! j |:=| (f (tps :.: j)) |+| 1])"
+  using assms execute_tm_rtrans transits_def by auto
+
+lemma transforms_tm_rtrans:
+  assumes "j < length tps"
+  shows "transforms (tm_rtrans j f) tps 1 (tps[j := tps ! j |:=| (f (tps :.: j)) |+| 1])"
+  using assms transits_tm_rtrans transforms_def by (metis One_nat_def length_Cons list.size(3) tm_rtrans_def)
+
+lemma transforms_tm_rtransI [transforms_intros]:
+  assumes "j < length tps" and "tps' = tps[j := tps ! j |:=| (f (tps :.: j)) |+| 1]"
+  shows "transforms (tm_rtrans j f) tps 1 tps'"
+  using assms transforms_tm_rtrans by simp
+
+text \<open>
+The next command writes a fixed symbol $h$ to all tapes in the set $J$.
+\<close>
+
+definition cmd_write_many :: "tapeidx set \<Rightarrow> symbol \<Rightarrow> command" where
+  "cmd_write_many J h rs \<equiv> (1, map (\<lambda>i. (if i \<in> J then h else rs ! i, Stay)) [0..<length rs])"
+
+lemma proper_cmd_write_many: "proper_command k (cmd_write_many J h)"
+  unfolding cmd_write_many_def by auto
+
+lemma sem_cmd_write_many:
+  shows "sem (cmd_write_many J h) (0, tps) =
+    (1, map (\<lambda>j. if j \<in> J then tps ! j |:=| h else tps ! j) [0..<length tps])"
+  using cmd_write_many_def read_length act_Stay
+  by (intro semI[OF proper_cmd_write_many]) auto
+
+definition tm_write_many :: "tapeidx set \<Rightarrow> symbol \<Rightarrow> machine" where
+  "tm_write_many J h \<equiv> [cmd_write_many J h]"
+
+lemma tm_write_many_tm:
+  assumes "0 \<notin> J" and "\<forall>j\<in>J. j < k" and "h < G" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_write_many J h)"
+  unfolding tm_write_many_def cmd_write_many_def using assms turing_machine_def by auto
+
+lemma exe_tm_write_many: "exe (tm_write_many J h) (0, tps) =
+    (1, map (\<lambda>j. if j \<in> J then tps ! j |:=| h else tps ! j) [0..<length tps])"
+  unfolding tm_write_many_def using sem_cmd_write_many exe_lt_length by simp
+
+lemma execute_tm_write_many: "execute (tm_write_many J h) (0, tps) 1 =
+    (1, map (\<lambda>j. if j \<in> J then tps ! j |:=| h else tps ! j) [0..<length tps])"
+  using exe_tm_write_many by simp
+
+lemma transforms_tm_write_many:
+  "transforms (tm_write_many J h) tps 1 (map (\<lambda>j. if j \<in> J then tps ! j |:=| h else tps ! j) [0..<length tps])"
+  using execute_tm_write_many transits_def transforms_def tm_write_many_def by auto
+
+lemma transforms_tm_write_manyI [transforms_intros]:
+  assumes "\<forall>j\<in>J. j < k"
+    and "length tps = k"
+    and "length tps' = k"
+    and "\<And>j. j \<in> J \<Longrightarrow> tps' ! j = tps ! j |:=| h"
+    and "\<And>j. j < k \<Longrightarrow> j \<notin> J \<Longrightarrow> tps' ! j = tps ! j"
+  shows "transforms (tm_write_many J h) tps 1 tps'"
+proof -
+  have "tps' = map (\<lambda>j. if j \<in> J then tps ! j |:=| h else tps ! j) [0..<length tps]"
+    using assms by (intro nth_equalityI) simp_all
+  then show ?thesis
+    using assms transforms_tm_write_many by auto
+qed
+
+
+subsection \<open>Writing a symbol multiple times\<close>
+
+text \<open>
+In this section we devise a Turing machine that writes the symbol sequence
+$h^m$ with a hard-coded symbol $h$ and number $m$ to a tape. The resulting
+tape is defined by the next operation:
+\<close>
+
+definition overwrite :: "tape \<Rightarrow> symbol \<Rightarrow> nat \<Rightarrow> tape" where
+  "overwrite tp h m \<equiv> (\<lambda>i. if snd tp \<le> i \<and> i < snd tp + m then h else fst tp i, snd tp + m)"
+
+lemma overwrite_0: "overwrite tp h 0 = tp"
+proof -
+  have "snd (overwrite tp h 0) = snd tp"
+    unfolding overwrite_def by simp
+  moreover have "fst (overwrite tp h 0) = fst tp"
+    unfolding overwrite_def by auto
+  ultimately show ?thesis
+    using prod_eqI by blast
+qed
+
+lemma overwrite_upd: "(overwrite tp h t) |:=| h |+| 1 = overwrite tp h (Suc t)"
+  using overwrite_def by auto
+
+lemma overwrite_upd':
+  assumes "j < length tps" and "tps' = tps[j := overwrite (tps ! j) h t]"
+  shows "(tps[j := overwrite (tps ! j) h t])[j := tps' ! j |:=| h |+| 1] =
+    tps[j := overwrite (tps ! j) h (Suc t)]"
+  using assms overwrite_upd by simp
+
+text \<open>
+The next command writes the symbol $h$ to the tape $j$ and moves the tape head
+to the right.
+\<close>
+
+definition cmd_char :: "tapeidx \<Rightarrow> symbol \<Rightarrow> command" where
+  "cmd_char j z = cmd_rtrans j (\<lambda>_. z)"
+
+lemma turing_command_char:
+  assumes "0 < j" and "j < k" and "h < G"
+  shows "turing_command k 1 G (cmd_char j h)"
+  unfolding cmd_char_def cmd_rtrans_def using assms by auto
+
+definition tm_char :: "tapeidx \<Rightarrow> symbol \<Rightarrow> machine" where
+  "tm_char j z \<equiv> [cmd_char j z]"
+
+lemma tm_char_tm:
+  assumes "0 < j" and "j < k" and "G \<ge> 4" and "z < G"
+  shows "turing_machine k G (tm_char j z)"
+  using assms turing_command_char tm_char_def by auto
+
+lemma transforms_tm_charI [transforms_intros]:
+  assumes "j < length tps" and "tps' = tps[j := tps ! j |:=| z |+| 1]"
+  shows "transforms (tm_char j z) tps 1 tps'"
+  using assms transforms_tm_rtransI tm_char_def cmd_char_def tm_rtrans_def by metis
+
+lemma sem_cmd_char:
+  assumes "j < length tps"
+  shows "sem (cmd_char j h) (0, tps) = (1, tps[j := tps ! j |:=| h |+| 1])"
+  using cmd_char_def cmd_rtrans_def tapes_at_read read_length assms act_Right
+  by (intro semI) auto
+
+text \<open>
+The next TM is a sequence of $m$ @{const cmd_char} commands properly relocated.
+It writes a sequence of $m$ times the symbol $h$ to tape $j$.
+\<close>
+
+definition tm_write_repeat :: "tapeidx \<Rightarrow> symbol \<Rightarrow> nat \<Rightarrow> machine" where
+  "tm_write_repeat j h m \<equiv> map (\<lambda>i. relocate_cmd i (cmd_char j h)) [0..<m]"
+
+lemma tm_write_repeat_tm:
+  assumes "0 < j" and "j < k" and "h < G" and "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_write_repeat j h m)"
+proof
+  let ?M = "tm_write_repeat j h m"
+  show "2 \<le> k" and "4 \<le> G"
+    using assms(4,5) .
+  show "turing_command k (length ?M) G (?M ! i)" if "i < length ?M" for i
+  proof -
+    have "?M ! i = relocate_cmd i (cmd_char j h)"
+      using that tm_write_repeat_def by simp
+    then have "turing_command k (1 + i) G (?M ! i)"
+      using assms turing_command_char turing_command_relocate_cmd by metis
+    then show ?thesis
+      using turing_command_mono that by simp
+  qed
+qed
+
+lemma exe_tm_write_repeat:
+  assumes "j < length tps" and "q < m"
+  shows "exe (tm_write_repeat j h m) (q, tps) = (Suc q, tps[j := tps ! j |:=| h |+| 1])"
+  using sem_cmd_char assms sem sem_relocate_cmd tm_write_repeat_def by (auto simp add: exe_lt_length)
+
+lemma execute_tm_write_repeat:
+  assumes "j < length tps" and "t \<le> m"
+  shows "execute (tm_write_repeat j h m) (0, tps) t = (t, tps[j := overwrite (tps ! j) h t])"
+  using assms(2)
+proof (induction t)
+  case 0
+  then show ?case using overwrite_0 by simp
+next
+  case (Suc t)
+  then have "t < m" by simp
+  have "execute (tm_write_repeat j h m) (0, tps) (Suc t) = exe (tm_write_repeat j h m) (execute (tm_write_repeat j h m) (0, tps) t)"
+    by simp
+  also have "... = exe (tm_write_repeat j h m) (t, tps[j := overwrite (tps ! j) h t])"
+    using Suc by simp
+  also have "... = (Suc t, tps[j := overwrite (tps ! j) h (Suc t)])"
+    using `t < m` exe_tm_write_repeat assms overwrite_upd' by simp
+  finally show ?case .
+qed
+
+lemma transforms_tm_write_repeatI [transforms_intros]:
+  assumes "j < length tps" and "tps' = tps[j := overwrite (tps ! j) h m]"
+  shows "transforms (tm_write_repeat j h m) tps m tps'"
+  using assms execute_tm_write_repeat transits_def transforms_def tm_write_repeat_def by auto
+
+
+subsection \<open>Moving to the start of the tape\<close>
+
+text \<open>
+The next command moves the head on tape $j$ to the left until it reaches
+a symbol from the set $H$:
+\<close>
+
+definition cmd_left_until :: "symbol set \<Rightarrow> tapeidx \<Rightarrow> command" where
+  "cmd_left_until H j rs \<equiv>
+    if rs ! j \<in> H
+    then (1, map (\<lambda>r. (r, Stay)) rs)
+    else (0, map (\<lambda>i. (rs ! i, if i = j then Left else Stay)) [0..<length rs])"
+
+lemma sem_cmd_left_until_1:
+  assumes "j < k" and "length tps = k" and "(0, tps) <.> j \<in> H"
+  shows "sem (cmd_left_until H j) (0, tps) = (1, tps)"
+  using cmd_left_until_def tapes_at_read read_length assms act_Stay
+  by (intro semI) auto
+
+lemma sem_cmd_left_until_2:
+  assumes "j < k" and "length tps = k" and "(0, tps) <.> j \<notin> H"
+  shows "sem (cmd_left_until H j) (0, tps) = (0, tps[j := tps ! j |-| 1])"
+  using cmd_left_until_def tapes_at_read read_length assms act_Stay act_Left
+  by (intro semI) auto
+
+definition tm_left_until :: "symbol set \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_left_until H j \<equiv> [cmd_left_until H j]"
+
+lemma tm_left_until_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_left_until H j)"
+  unfolding tm_left_until_def cmd_left_until_def using assms turing_machine_def by auto
+
+text \<open>
+A \emph{begin tape} for a set of symbols has one of these symbols only in cell
+zero.  It generalizes the concept of clean tapes, where the set of symbols is
+$\{\triangleright\}$.
+\<close>
+
+definition begin_tape :: "symbol set \<Rightarrow> tape \<Rightarrow> bool" where
+  "begin_tape H tp \<equiv> \<forall>i. fst tp i \<in> H \<longleftrightarrow> i = 0"
+
+lemma begin_tapeI:
+  assumes "fst tp 0 \<in> H" and "\<And>i. i > 0 \<Longrightarrow> fst tp i \<notin> H"
+  shows "begin_tape H tp"
+  unfolding begin_tape_def using assms by auto
+
+lemma exe_tm_left_until_1:
+  assumes "j < length tps" and "(0, tps) <.> j \<in> H"
+  shows "exe (tm_left_until H j) (0, tps) = (1, tps)"
+  using tm_left_until_def assms exe_lt_length sem_cmd_left_until_1 by auto
+
+lemma exe_tm_left_until_2:
+  assumes "j < length tps" and "(0, tps) <.> j \<notin> H"
+  shows "exe (tm_left_until H j) (0, tps) = (0, tps[j := tps ! j |-| 1])"
+  using tm_left_until_def assms exe_lt_length sem_cmd_left_until_2 by auto
+
+text \<open>
+We do not show the semantics of @{const tm_left_until} for the general case, but
+only for when applied to begin tapes.
+\<close>
+
+lemma execute_tm_left_until_less:
+  assumes "j < length tps" and "begin_tape H (tps ! j)" and "t \<le> tps :#: j"
+  shows "execute (tm_left_until H j) (0, tps) t = (0, tps[j := tps ! j |-| t])"
+  using assms(3)
+proof (induction t)
+  case 0
+  then show ?case by simp
+next
+  case (Suc t)
+  then have "fst (tps ! j) (snd (tps ! j) - t) \<notin> H"
+    using assms begin_tape_def by simp
+  then have neq_0: "fst (tps ! j |-| t) (snd (tps ! j |-| t)) \<notin> H"
+    by simp
+  have "execute (tm_left_until H j) (0, tps) (Suc t) = exe (tm_left_until H j) (execute (tm_left_until H j) (0, tps) t)"
+    by simp
+  also have "... = exe (tm_left_until H j) (0, tps[j := tps ! j |-| t])"
+    using Suc by simp
+  also have "... = (0, tps[j := tps ! j |-| (Suc t)])"
+    using neq_0 exe_tm_left_until_2 assms by simp
+  finally show ?case by simp
+qed
+
+lemma execute_tm_left_until:
+  assumes "j < length tps" and "begin_tape H (tps ! j)"
+  shows "execute (tm_left_until H j) (0, tps) (Suc (tps :#: j)) = (1, tps[j := tps ! j |#=| 0])"
+  using assms begin_tape_def exe_tm_left_until_1 execute_tm_left_until_less by simp
+
+lemma transits_tm_left_until:
+  assumes "j < length tps" and "begin_tape H (tps ! j)"
+  shows "transits (tm_left_until H j) (0, tps) (Suc (tps :#: j)) (1, tps[j := tps ! j |#=| 0])"
+  using execute_imp_transits[OF execute_tm_left_until[OF assms]] by simp
+
+lemma transforms_tm_left_until:
+  assumes "j < length tps" and "begin_tape H (tps ! j)"
+  shows "transforms (tm_left_until H j) tps (Suc (tps :#: j)) (tps[j := tps ! j |#=| 0])"
+  using tm_left_until_def transforms_def transits_tm_left_until[OF assms] by simp
+
+text \<open>
+The most common case is $H = \{\triangleright\}$, which means the Turing machine
+moves the tape head left to the closest start symbol. On clean tapes it moves
+the tape head to the leftmost cell of the tape.
+\<close>
+
+definition tm_start :: "tapeidx \<Rightarrow> machine" where
+  "tm_start \<equiv> tm_left_until {1}"
+
+lemma tm_start_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_start j)"
+  unfolding tm_start_def using assms tm_left_until_tm by simp
+
+lemma transforms_tm_start:
+  assumes "j < length tps" and "clean_tape (tps ! j)"
+  shows "transforms (tm_start j) tps (Suc (tps :#: j)) (tps[j := tps ! j |#=| 0])"
+  using tm_start_def assms transforms_tm_left_until begin_tape_def clean_tape_def by (metis insertCI singletonD)
+
+lemma transforms_tm_startI [transforms_intros]:
+  assumes "j < length tps" and "clean_tape (tps ! j)"
+    and "t = Suc (tps :#: j)"
+    and "tps' = tps[j := tps ! j |#=| 0]"
+  shows "transforms (tm_start j) tps t tps'"
+  using transforms_tm_start assms by simp
+
+text \<open>
+The next Turing machine is the first instance in which we use the $;;$ operator
+with concrete Turing machines. It is also the first time we use the proof method
+@{method tform} for @{const transforms}. The TM performs a ``carriage return''
+on a clean tape, that is, it moves to the first non-start symbol.
+\<close>
+
+definition tm_cr :: "tapeidx \<Rightarrow> machine" where
+  "tm_cr j \<equiv> tm_start j ;; tm_right j"
+
+lemma tm_cr_tm: "k \<ge> 2 \<Longrightarrow> G \<ge> 4 \<Longrightarrow> turing_machine k G (tm_cr j)"
+  using turing_machine_sequential_turing_machine by (simp add: tm_cr_def tm_right_tm tm_start_tm)
+
+lemma transforms_tm_crI [transforms_intros]:
+  assumes "j < length tps"
+    and "clean_tape (tps ! j)"
+    and "t = tps :#: j + 2"
+    and "tps' = tps[j := tps ! j |#=| 1]"
+  shows "transforms (tm_cr j) tps t tps'"
+  unfolding tm_cr_def by (tform tps: assms)
+
+
+subsection \<open>Erasing a tape\<close>
+
+text \<open>
+The next Turing machine overwrites all but the start symbol with blanks. It
+first performs a carriage return and then writes blanks until it reaches a
+blank. This only works as intended if there are no gaps, that is, blanks between
+non-blank symbols.
+\<close>
+
+definition tm_erase :: "tapeidx \<Rightarrow> machine" where
+  "tm_erase j \<equiv> tm_cr j ;; tm_const_until j j {\<box>} \<box>"
+
+lemma tm_erase_tm: "G \<ge> 4 \<Longrightarrow> 0 < j \<Longrightarrow> j < k \<Longrightarrow> turing_machine k G (tm_erase j)"
+  unfolding tm_erase_def using tm_cr_tm tm_const_until_tm by simp
+
+lemma transforms_tm_eraseI [transforms_intros]:
+  assumes "j < length tps"
+    and "proper_symbols zs"
+    and "tps ::: j = \<lfloor>zs\<rfloor>"
+    and "t = tps :#: j + length zs + 3"
+    and "tps' = tps[j := (\<lfloor>[]\<rfloor>, Suc (length zs))]"
+  shows "transforms (tm_erase j) tps t tps'"
+  unfolding tm_erase_def
+proof (tform tps: assms time: assms(4))
+  show "clean_tape (tps ! j)"
+    using assms contents_clean_tape' by simp
+  show "rneigh (tps[j := tps ! j |#=| 1] ! j) {\<box>} (length zs)"
+    using assms contents_clean_tape' by (intro rneighI) auto
+  show "tps' = tps
+    [j := tps ! j |#=| 1, j := tps[j := tps ! j |#=| 1] ! j |+| length zs,
+     j := constplant (tps[j := tps ! j |#=| 1] ! j) \<box> (length zs)]"
+  proof -
+    have "(\<lfloor>[]\<rfloor>, Suc (length zs)) = constplant (\<lfloor>zs\<rfloor>, Suc 0) \<box> (length zs)"
+      using transplant_def contents_def by auto
+    then show ?thesis
+      using assms by simp
+  qed
+qed
+
+text \<open>
+The next TM returns to the leftmost blank symbol after erasing the tape.
+\<close>
+
+definition tm_erase_cr :: "tapeidx \<Rightarrow> machine" where
+  "tm_erase_cr j \<equiv> tm_erase j ;; tm_cr j"
+
+lemma tm_erase_cr_tm:
+  assumes "G \<ge> 4" and "0 < j" and "j < k"
+  shows "turing_machine k G (tm_erase_cr j)"
+  using tm_erase_cr_def tm_cr_tm tm_erase_tm assms by simp
+
+lemma transforms_tm_erase_crI [transforms_intros]:
+  assumes "j < length tps"
+    and "proper_symbols zs"
+    and "tps ::: j = \<lfloor>zs\<rfloor>"
+    and "t = tps :#: j + 2 * length zs + 6"
+    and "tps' = tps[j := (\<lfloor>[]\<rfloor>, 1)]"
+  shows "transforms (tm_erase_cr j) tps t tps'"
+  unfolding tm_erase_cr_def
+  by (tform tps: assms time: assms(4))
+
+
+subsection \<open>Writing a symbol sequence\<close>
+
+text \<open>
+The Turing machine in this section writes a hard-coded symbol sequence to a
+tape. It is like @{const tm_write_repeat} except with an arbitrary symbol
+sequence.
+\<close>
+
+fun tm_print :: "tapeidx \<Rightarrow> symbol list \<Rightarrow> machine" where
+  "tm_print j [] = []" |
+  "tm_print j (z # zs) = tm_char j z ;; tm_print j zs"
+
+lemma tm_print_tm:
+  assumes "0 < j" and "j < k" and "G \<ge> 4" and "\<forall>i<length zs. zs ! i < G"
+  shows "turing_machine k G (tm_print j zs)"
+  using assms(4)
+proof (induction zs)
+  case Nil
+  then show ?case
+    using assms by auto
+next
+  case (Cons z zs)
+  then have "turing_machine k G (tm_char j z)"
+    using assms tm_char_tm by auto
+  then show ?case
+    using assms Cons by fastforce
+qed
+
+text \<open>
+The result of writing the symbols @{term zs} to a tape @{term tp}:
+\<close>
+
+definition inscribe :: "tape \<Rightarrow> symbol list \<Rightarrow> tape" where
+  "inscribe tp zs \<equiv>
+     (\<lambda>i. if snd tp \<le> i \<and> i < snd tp + length zs then zs ! (i - snd tp) else fst tp i,
+      snd tp + length zs)"
+
+lemma inscribe_Nil: "inscribe tp [] = tp"
+proof -
+  have "(\<lambda>i. if snd tp \<le> i \<and> i < snd tp then [] ! (i - snd tp) else fst tp i) = fst tp"
+    by auto
+  then show ?thesis
+    unfolding inscribe_def by simp
+qed
+
+lemma inscribe_Cons: "inscribe ((fst tp)(snd tp := z), Suc (snd tp)) zs = inscribe tp (z # zs)"
+  using inscribe_def by auto
+
+lemma inscribe_contents: "inscribe (\<lfloor>ys\<rfloor>, Suc (length ys)) zs = (\<lfloor>ys @ zs\<rfloor>, Suc (length ys + length zs))"
+  (is "?lhs = ?rhs")
+proof
+  show "snd ?lhs = snd ?rhs"
+    using inscribe_def contents_def by simp
+  show "fst ?lhs = fst ?rhs"
+  proof
+    fix i :: nat
+    consider
+        "i = 0"
+      | "0 < i \<and> i < Suc (length ys)"
+      | "Suc (length ys) \<le> i \<and> i < Suc (length ys + length zs)"
+      | "Suc (length ys + length zs) \<le> i"
+      by linarith
+    then show "fst ?lhs i = fst ?rhs i"
+    proof (cases)
+      case 1
+      then show ?thesis
+        using inscribe_def contents_def by simp
+    next
+      case 2
+      then have "fst ?lhs i = \<lfloor>ys\<rfloor> i"
+        using inscribe_def by simp
+      then have lhs: "fst ?lhs i = ys ! (i - 1)"
+        using 2 contents_def by simp
+      have "fst ?rhs i = (ys @ zs) ! (i - 1)"
+        using 2 contents_def by simp
+      then have "fst ?rhs i = ys ! (i - 1)"
+        using 2 by (metis Suc_diff_1 not_less_eq nth_append)
+      then show ?thesis
+        using lhs by simp
+    next
+      case 3
+      then show ?thesis
+        using contents_def inscribe_def
+        by (smt (verit, del_insts) One_nat_def add.commute diff_Suc_eq_diff_pred fst_conv length_append less_Suc0
+         less_Suc_eq_le less_diff_conv2 nat.simps(3) not_less_eq nth_append plus_1_eq_Suc snd_conv)
+    next
+      case 4
+      then show ?thesis
+        using contents_def inscribe_def
+        by simp
+    qed
+  qed
+qed
+
+lemma inscribe_contents_Nil: "inscribe (\<lfloor>[]\<rfloor>, Suc 0) zs = (\<lfloor>zs\<rfloor>, Suc (length zs))"
+  using inscribe_def contents_def by auto
+
+lemma transforms_tm_print:
+  assumes "j < length tps"
+  shows "transforms (tm_print j zs) tps (length zs) (tps[j := inscribe (tps ! j) zs])"
+  using assms
+proof (induction zs arbitrary: tps)
+  case Nil
+  then show ?case
+    using inscribe_Nil transforms_Nil by simp
+next
+  case (Cons z zs)
+  have "transforms (tm_char j z ;; tm_print j zs) tps (length (z # zs)) (tps[j := inscribe (tps ! j) (z # zs)])"
+  proof (tform tps: Cons)
+    let ?tps = "tps[j := tps ! j |:=| z |+| 1]"
+    have "transforms (tm_print j zs) ?tps (length zs) (?tps[j := inscribe (?tps ! j) zs])"
+      using Cons by (metis length_list_update)
+    moreover have "(?tps[j := inscribe (?tps ! j) zs]) = (tps[j := inscribe (tps ! j) (z # zs)])"
+      using inscribe_Cons Cons.prems by simp
+    ultimately show "transforms (tm_print j zs) ?tps (length zs) (tps[j := inscribe (tps ! j) (z # zs)])"
+      by simp
+  qed
+  then show "transforms (tm_print j (z # zs)) tps (length (z # zs)) (tps[j := inscribe (tps ! j) (z # zs)])"
+    by simp
+qed
+
+lemma transforms_tm_printI [transforms_intros]:
+  assumes "j < length tps" and "tps' = (tps[j := inscribe (tps ! j) zs])"
+  shows "transforms (tm_print j zs) tps (length zs) tps'"
+  using assms transforms_tm_print by simp
+
+
+subsection \<open>Setting the tape contents to a symbol sequence\<close>
+
+text \<open>
+The following Turing machine erases the tape, then prints a hard-coded
+symbol sequence, and then performs a carriage return. It thus sets
+the tape contents to the symbol sequence.
+\<close>
+
+definition tm_set :: "tapeidx \<Rightarrow> symbol list \<Rightarrow> machine" where
+  "tm_set j zs \<equiv> tm_erase_cr j ;; tm_print j zs ;; tm_cr j"
+
+lemma tm_set_tm:
+  assumes "0 < j" and "j < k" and "G \<ge> 4" and "\<forall>i<length zs. zs ! i < G"
+  shows "turing_machine k G (tm_set j zs)"
+  unfolding tm_set_def using assms tm_print_tm tm_erase_cr_tm tm_cr_tm by simp
+
+lemma transforms_tm_setI [transforms_intros]:
+  assumes "j < length tps"
+    and "clean_tape (tps ! j)"
+    and "proper_symbols ys"
+    and "proper_symbols zs"
+    and "tps ::: j = \<lfloor>ys\<rfloor>"
+    and "t = 8 + tps :#: j + 2 * length ys + Suc (2 * length zs)"
+    and "tps' = tps[j := (\<lfloor>zs\<rfloor>, 1)]"
+  shows "transforms (tm_set j zs) tps t tps'"
+  unfolding tm_set_def
+proof (tform tps: assms(1-5))
+  show "clean_tape
+     (tps[j := (\<lfloor>[]\<rfloor>, 1),
+          j := inscribe (tps[j := (\<lfloor>[]\<rfloor>, 1)] ! j) zs] ! j)"
+    using assms inscribe_contents_Nil clean_contents_proper[OF assms(4)] by simp
+  show "tps' = tps
+      [j := (\<lfloor>[]\<rfloor>, 1), j := inscribe (tps[j := (\<lfloor>[]\<rfloor>, 1)] ! j) zs,
+       j := tps[j := (\<lfloor>[]\<rfloor>, 1), j := inscribe (tps[j := (\<lfloor>[]\<rfloor>, 1)] ! j) zs] ! j |#=| 1]"
+    using assms inscribe_def clean_tape_def assms contents_def inscribe_contents_Nil by simp
+  show "t = tps :#: j + 2 * length ys + 6 + length zs +
+      (tps[j := (\<lfloor>[]\<rfloor>, 1),
+           j := inscribe (tps[j := (\<lfloor>[]\<rfloor>, 1)] ! j) zs] :#: j + 2)"
+    using assms inscribe_def by simp
+qed
+
+
+subsection \<open>Comparing two tapes\label{s:tm-elementary-comparing}\<close>
+
+text \<open>
+The next Turing machine compares the contents of two tapes $j_1$ and $j_2$ and
+writes to tape $j_3$ either a @{text \<one>} or a @{text \<box>} depending on whether the
+tapes are equal or not. The next command does all the work. It scans both tapes
+left to right and halts if it encounters a blank on both tapes, which means the
+tapes are equal, or two different symbols, which means the tapes are unequal. It
+only works for contents without blanks.
+\<close>
+
+definition cmd_cmp :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> command" where
+  "cmd_cmp j1 j2 j3 rs \<equiv>
+    if rs ! j1 \<noteq> rs ! j2
+    then (1, map (\<lambda>i. (if i = j3 then \<box> else rs ! i, Stay)) [0..<length rs])
+    else if rs ! j1 = \<box> \<or> rs ! j2 = \<box>
+      then (1, map (\<lambda>i. (if i = j3 then \<one> else rs ! i, Stay)) [0..<length rs])
+      else (0, map (\<lambda>i. (rs ! i, if i = j1 \<or> i = j2 then Right else Stay)) [0..<length rs])"
+
+lemma sem_cmd_cmp1:
+  assumes "length tps = k"
+    and "j1 < k" and "j2 < k" and "j3 < k"
+    and "tps :.: j1 \<noteq> tps :.: j2"
+  shows "sem (cmd_cmp j1 j2 j3) (0, tps) = (1, tps[j3 := tps ! j3 |:=| \<box>])"
+  unfolding cmd_cmp_def using assms tapes_at_read' act_Stay read_length by (intro semI) auto
+
+lemma sem_cmd_cmp2:
+  assumes "length tps = k"
+    and "j1 < k" and "j2 < k" and "j3 < k"
+    and "tps :.: j1 = tps :.: j2" and "tps :.: j1 = \<box> \<or> tps :.: j2 = \<box>"
+  shows "sem (cmd_cmp j1 j2 j3) (0, tps) = (1, tps[j3 := tps ! j3 |:=| \<one>])"
+  unfolding cmd_cmp_def using assms tapes_at_read' act_Stay read_length by (intro semI) auto
+
+lemma sem_cmd_cmp3:
+  assumes "length tps = k"
+    and "j2 \<noteq> j3" and "j1 \<noteq> j3" and "j1 < k" and "j2 < k" and "j3 < k"
+    and "tps :.: j1 = tps :.: j2" and "tps :.: j1 \<noteq> \<box> \<and> tps :.: j2 \<noteq> \<box>"
+  shows "sem (cmd_cmp j1 j2 j3) (0, tps) = (0, tps[j1 := tps ! j1 |+| 1, j2 := tps ! j2 |+| 1])"
+proof (rule semI)
+  show "proper_command k (cmd_cmp j1 j2 j3)"
+    using cmd_cmp_def by simp
+  show "length tps = k"
+    using assms(1) .
+  show "length (tps[j1 := tps ! j1 |+| 1, j2 := tps ! j2 |+| 1]) = k"
+    using assms(1) by simp
+  show "fst ((cmd_cmp j1 j2 j3) (read tps)) = 0"
+    unfolding cmd_cmp_def using assms tapes_at_read' by simp
+  show "act (cmd_cmp j1 j2 j3 (read tps) [!] j) (tps ! j) = tps[j1 := tps ! j1 |+| 1, j2 := tps ! j2 |+| 1] ! j"
+      if "j < k" for j
+    unfolding cmd_cmp_def
+    using assms tapes_at_read' that act_Stay act_Right read_length
+    by (cases "j1 = j2") simp_all
+qed
+
+definition tm_cmp :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_cmp j1 j2 j3 \<equiv> [cmd_cmp j1 j2 j3]"
+
+lemma tm_cmp_tm:
+  assumes "k \<ge> 2" and "j3 > 0" and "G \<ge> 4"
+  shows "turing_machine k G (tm_cmp j1 j2 j3)"
+  unfolding tm_cmp_def cmd_cmp_def using assms turing_machine_def by auto
+
+lemma exe_cmd_cmp1:
+  assumes "length tps = k"
+    and "j1 < k" and "j2 < k" and "j3 < k"
+    and "tps :.: j1 \<noteq> tps :.: j2"
+  shows "exe (tm_cmp j1 j2 j3) (0, tps) = (1, tps[j3 := tps ! j3 |:=| \<box>])"
+  using tm_cmp_def assms exe_lt_length sem_cmd_cmp1 by simp
+
+lemma exe_cmd_cmp2:
+  assumes "length tps = k"
+    and "j1 < k" and "j2 < k" and "j3 < k"
+    and "tps :.: j1 = tps :.: j2" and "tps :.: j1 = \<box> \<or> tps :.: j2 = \<box>"
+  shows "exe (tm_cmp j1 j2 j3) (0, tps) = (1, tps[j3 := tps ! j3 |:=| \<one>])"
+  using tm_cmp_def assms exe_lt_length sem_cmd_cmp2 by simp
+
+lemma exe_cmd_cmp3:
+  assumes "length tps = k"
+    and "j2 \<noteq> j3" and "j1 \<noteq> j3" and "j1 < k" and "j2 < k" and "j3 < k"
+    and "tps :.: j1 = tps :.: j2" and "tps :.: j1 \<noteq> \<box> \<and> tps :.: j2 \<noteq> \<box>"
+  shows "exe (tm_cmp j1 j2 j3) (0, tps) = (0, tps[j1 := tps ! j1 |+| 1, j2 := tps ! j2 |+| 1])"
+  using tm_cmp_def assms exe_lt_length sem_cmd_cmp3 by simp
+
+lemma execute_tm_cmp_eq:
+  fixes tps :: "tape list"
+  assumes "length tps = k"
+    and "j2 \<noteq> j3" and "j1 \<noteq> j3" and "j1 < k" and "j2 < k" and "j3 < k"
+    and "proper_symbols xs"
+    and "tps ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>xs\<rfloor>, 1)"
+  shows "execute (tm_cmp j1 j2 j3) (0, tps) (Suc (length xs)) =
+      (1, tps[j1 := tps ! j1 |+| length xs, j2 := tps ! j2 |+| length xs, j3 := tps ! j3 |:=| \<one>])"
+proof -
+  have "execute (tm_cmp j1 j2 j3) (0, tps) t = (0, tps[j1 := tps ! j1 |+| t, j2 := tps ! j2 |+| t])"
+      if "t \<le> length xs" for t
+    using that
+  proof (induction t)
+    case 0
+    then show ?case
+      by simp
+  next
+    case (Suc t)
+    then have t_less: "t < length xs"
+      by simp
+    have "execute (tm_cmp j1 j2 j3) (0, tps) (Suc t) = exe (tm_cmp j1 j2 j3) (execute (tm_cmp j1 j2 j3) (0, tps) t)"
+      by simp
+    also have "... = exe (tm_cmp j1 j2 j3) (0, tps[j1 := tps ! j1 |+| t, j2 := tps ! j2 |+| t])"
+        (is "_ = exe _ (0, ?tps)")
+      using Suc by simp
+    also have "... = (0, ?tps[j1 := ?tps ! j1 |+| 1, j2 := ?tps ! j2 |+| 1])"
+    proof -
+      have 1: "?tps :.: j1 = xs ! t"
+        using assms(1,2,4,8) t_less Suc.prems contents_inbounds
+        by (metis (no_types, lifting) diff_Suc_1 fst_conv length_list_update nth_list_update_eq
+          nth_list_update_neq plus_1_eq_Suc snd_conv zero_less_Suc)
+      moreover have 2: "?tps :.: j2 = xs ! t"
+        using t_less assms(1,5,9) by simp
+      ultimately have "?tps :.: j1 = ?tps :.: j2"
+        by simp
+      moreover have "?tps :.: j1 \<noteq> 0 \<and> ?tps :.: j2 \<noteq> 0"
+        using 1 2 assms(7) t_less by auto
+      moreover have "length ?tps = k"
+        using assms(1) by simp
+      ultimately show ?thesis
+        using assms exe_cmd_cmp3 by blast
+    qed
+    also have "... = (0, tps[j1 := tps ! j1 |+| Suc t, j2 := tps ! j2 |+| Suc t])"
+      using assms
+      by (smt (z3) Suc_eq_plus1 add.commute fst_conv list_update_overwrite list_update_swap
+        nth_list_update_eq nth_list_update_neq snd_conv)
+    finally show ?case
+      by simp
+  qed
+  then have "execute (tm_cmp j1 j2 j3) (0, tps) (length xs) =
+      (0, tps[j1 := tps ! j1 |+| length xs, j2 := tps ! j2 |+| length xs])"
+    by simp
+  then have "execute (tm_cmp j1 j2 j3) (0, tps) (Suc (length xs)) =
+      exe (tm_cmp j1 j2 j3) (0, tps[j1 := tps ! j1 |+| length xs, j2 := tps ! j2 |+| length xs])"
+      (is "_ = exe _ (0, ?tps)")
+    by simp
+  also have "... = (1, ?tps[j3 := ?tps ! j3 |:=| \<one>])"
+  proof -
+    have 1: "?tps :.: j1 = 0"
+      using assms(1,4,8) contents_outofbounds
+      by (metis fst_conv length_list_update lessI nth_list_update_eq nth_list_update_neq plus_1_eq_Suc snd_conv)
+    moreover have 2: "?tps :.: j2 = 0"
+      using assms(1,5,9) by simp
+    ultimately have "?tps :.: j1 = ?tps :.: j2" "?tps :.: j1 = \<box> \<or> ?tps :.: j2 = \<box>"
+      by simp_all
+    moreover have "length ?tps = k"
+      using assms(1) by simp
+    ultimately show ?thesis
+      using assms exe_cmd_cmp2 by blast
+  qed
+  also have "... = (1, tps[j1 := tps ! j1 |+| length xs, j2 := tps ! j2 |+| length xs, j3 := tps ! j3 |:=| \<one>])"
+    using assms by simp
+  finally show ?thesis .
+qed
+
+lemma ex_contents_neq:
+  assumes "proper_symbols xs" and "proper_symbols ys" and "xs \<noteq> ys"
+  shows "\<exists>m. m \<le> Suc (min (length xs) (length ys)) \<and> \<lfloor>xs\<rfloor> m \<noteq> \<lfloor>ys\<rfloor> m"
+proof -
+  consider "length xs < length ys" | "length xs = length ys" | "length xs > length ys"
+    by linarith
+  then show ?thesis
+  proof (cases)
+    case 1
+    let ?m = "length xs"
+    have "\<lfloor>xs\<rfloor> (Suc ?m) = \<box>"
+      by simp
+    moreover have "\<lfloor>ys\<rfloor> (Suc ?m) \<noteq> \<box>"
+      using 1 assms(2) by (simp add: proper_symbols_ne0)
+    ultimately show ?thesis
+      using 1 by auto
+  next
+    case 2
+    then have "\<exists>i<length xs. xs ! i \<noteq> ys ! i"
+      using assms by (meson list_eq_iff_nth_eq)
+    then show ?thesis
+      using contents_def 2 by auto
+  next
+    case 3
+    let ?m = "length ys"
+    have "\<lfloor>ys\<rfloor> (Suc ?m) = \<box>"
+      by simp
+    moreover have "\<lfloor>xs\<rfloor> (Suc ?m) \<noteq> \<box>"
+      using 3 assms(1) by (simp add: proper_symbols_ne0)
+    ultimately show ?thesis
+      using 3 by auto
+  qed
+qed
+
+lemma execute_tm_cmp_neq:
+  fixes tps :: "tape list"
+  assumes "length tps = k"
+    and "j1 \<noteq> j2" and "j2 \<noteq> j3" and "j1 \<noteq> j3" and "j1 < k" and "j2 < k" and "j3 < k"
+    and "proper_symbols xs"
+    and "proper_symbols ys"
+    and "xs \<noteq> ys"
+    and "tps ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>ys\<rfloor>, 1)"
+    and "m = (LEAST m. m \<le> Suc (min (length xs) (length ys)) \<and> \<lfloor>xs\<rfloor> m \<noteq> \<lfloor>ys\<rfloor> m)"
+  shows "execute (tm_cmp j1 j2 j3) (0, tps) m =
+    (1, tps[j1 := tps ! j1 |+| (m - 1), j2 := tps ! j2 |+| (m - 1), j3 := tps ! j3 |:=| \<box>])"
+proof -
+  have neq: "\<lfloor>xs\<rfloor> m \<noteq> \<lfloor>ys\<rfloor> m"
+    using ex_contents_neq[OF assms(8-10)] assms(13) by (metis (mono_tags, lifting) LeastI_ex)
+  have eq: "\<lfloor>xs\<rfloor> i = \<lfloor>ys\<rfloor> i" if "i < m" for i
+    using ex_contents_neq[OF assms(8-10)] assms(13) not_less_Least that by (smt (z3) Least_le le_trans less_imp_le_nat)
+  have "m > 0"
+    using neq contents_def gr0I by metis
+
+  have "execute (tm_cmp j1 j2 j3) (0, tps) t = (0, tps[j1 := tps ! j1 |+| t, j2 := tps ! j2 |+| t])"
+      if "t < m" for t
+    using that
+  proof (induction t)
+    case 0
+    then show ?case
+      by simp
+  next
+    case (Suc t)
+    have "execute (tm_cmp j1 j2 j3) (0, tps) (Suc t) = exe (tm_cmp j1 j2 j3) (execute (tm_cmp j1 j2 j3) (0, tps) t)"
+      by simp
+    also have "... = exe (tm_cmp j1 j2 j3) (0, tps[j1 := tps ! j1 |+| t, j2 := tps ! j2 |+| t])"
+        (is "_ = exe _ (0, ?tps)")
+      using Suc by simp
+    also have "... = (0, ?tps[j1 := ?tps ! j1 |+| 1, j2 := ?tps ! j2 |+| 1])"
+    proof -
+      have 1: "?tps :.: j1 = \<lfloor>xs\<rfloor> (Suc t)"
+        using assms(1,2,5,11) by simp
+      moreover have 2: "?tps :.: j2 = \<lfloor>ys\<rfloor> (Suc t)"
+        using assms(1,6,12) by simp
+      ultimately have "?tps :.: j1 = ?tps :.: j2"
+        using Suc eq by simp
+      moreover from this have "?tps :.: j1 \<noteq> \<box> \<and> ?tps :.: j2 \<noteq> \<box>"
+        using 1 2 assms neq Suc.prems contents_def
+        by (smt (z3) Suc_leI Suc_le_lessD Suc_lessD diff_Suc_1 le_trans less_nat_zero_code zero_less_Suc)
+      moreover have "length ?tps = k"
+        using assms(1) by simp
+      ultimately show ?thesis
+        using assms exe_cmd_cmp3 by blast
+    qed
+    also have "... = (0, tps[j1 := tps ! j1 |+| Suc t, j2 := tps ! j2 |+| Suc t])"
+      using assms
+      by (smt (z3) Suc_eq_plus1 add.commute fst_conv list_update_overwrite list_update_swap
+        nth_list_update_eq nth_list_update_neq snd_conv)
+    finally show ?case
+      by simp
+  qed
+  then have "execute (tm_cmp j1 j2 j3) (0, tps) (m - 1) =
+      (0, tps[j1 := tps ! j1 |+| (m - 1), j2 := tps ! j2 |+| (m - 1)])"
+    using `m > 0` by simp
+  then have "execute (tm_cmp j1 j2 j3) (0, tps) m =
+      exe (tm_cmp j1 j2 j3) (0, tps[j1 := tps ! j1 |+| (m - 1), j2 := tps ! j2 |+| (m - 1)])"
+    using `m > 0` by (metis contents_at_0 diff_Suc_1 execute.elims neq)
+  then show "execute (tm_cmp j1 j2 j3) (0, tps) m =
+      (1, tps[j1 := tps ! j1 |+| (m - 1), j2 := tps ! j2 |+| (m - 1), j3 := tps ! j3 |:=| \<box>])"
+    using exe_cmd_cmp1 assms \<open>0 < m\<close>
+    by (smt (z3) One_nat_def Suc_diff_Suc diff_zero fst_conv length_list_update neq nth_list_update_eq
+      nth_list_update_neq plus_1_eq_Suc snd_conv)
+qed
+
+lemma transforms_tm_cmpI [transforms_intros]:
+  fixes tps :: "tape list"
+  assumes "length tps = k"
+    and "j1 \<noteq> j2" and "j2 \<noteq> j3" and "j1 \<noteq> j3" and "j1 < k" and "j2 < k" and "j3 < k"
+    and "proper_symbols xs"
+    and "proper_symbols ys"
+    and "tps ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>ys\<rfloor>, 1)"
+    and "t = Suc (min (length xs) (length ys))"
+    and "b = (if xs = ys then \<one> else \<box>)"
+    and "m =
+     (if xs = ys
+      then Suc (length xs)
+      else (LEAST m. m \<le> Suc (min (length xs) (length ys)) \<and> \<lfloor>xs\<rfloor> m \<noteq> \<lfloor>ys\<rfloor> m))"
+    and "tps' = tps[j1 := (\<lfloor>xs\<rfloor>, m), j2 := (\<lfloor>ys\<rfloor>, m), j3 := tps ! j3 |:=| b]"
+  shows "transforms (tm_cmp j1 j2 j3) tps t tps'"
+proof (cases "xs = ys")
+  case True
+  then have m: "m = Suc (length xs)"
+    using assms(14) by simp
+  have "execute (tm_cmp j1 j2 j3) (0, tps) (Suc (length xs)) =
+      (1, tps[j1 := tps ! j1 |+| length xs, j2 := tps ! j2 |+| length xs, j3 := tps ! j3 |:=| \<one>])"
+    using execute_tm_cmp_eq assms True by blast
+  then have "execute (tm_cmp j1 j2 j3) (0, tps) m =
+      (1, tps[j1 := tps ! j1 |+| (m - 1), j2 := tps ! j2 |+| (m - 1), j3 := tps ! j3 |:=| b])"
+    using m assms(13) True diff_Suc_1 by simp
+  moreover have "m \<le> t"
+    using True assms(12) m by simp
+  ultimately show ?thesis
+    using transitsI tm_cmp_def transforms_def assms True
+    by (metis (no_types, lifting) One_nat_def add.commute diff_Suc_1 fst_conv list.size(3) list.size(4) plus_1_eq_Suc snd_conv)
+next
+  case False
+  then have m: "m = (LEAST m. m \<le> Suc (min (length xs) (length ys)) \<and> \<lfloor>xs\<rfloor> m \<noteq> \<lfloor>ys\<rfloor> m)"
+    using assms(14) by simp
+  then have "execute (tm_cmp j1 j2 j3) (0, tps) m =
+      (1, tps[j1 := tps ! j1 |+| (m - 1), j2 := tps ! j2 |+| (m - 1), j3 := tps ! j3 |:=| \<box>])"
+    using False assms execute_tm_cmp_neq by blast
+  then have "execute (tm_cmp j1 j2 j3) (0, tps) m =
+      (1, tps[j1 := tps ! j1 |+| (m - 1), j2 := tps ! j2 |+| (m - 1), j3 := tps ! j3 |:=| b])"
+    using False by (simp add: assms(13))
+  moreover have "m \<le> t"
+    using ex_contents_neq[OF assms(8,9)] False assms(12) m by (metis (mono_tags, lifting) LeastI)
+  ultimately show ?thesis
+    using transitsI tm_cmp_def transforms_def assms False
+    by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 Suc_pred add.commute execute.simps(1)
+      fst_eqD list.size(3) list.size(4) not_gr0 numeral_One snd_conv zero_neq_numeral)
+qed
+
+text \<open>
+The next Turing machine extends @{const tm_cmp} by a carriage return on tapes
+$j_1$ and $j_2$, ensuring that the next command finds the tape heads in a
+well-specified position. This makes the TM easier to reuse.
+\<close>
+
+definition tm_equals :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_equals j1 j2 j3 \<equiv> tm_cmp j1 j2 j3 ;; tm_cr j1 ;; tm_cr j2"
+
+lemma tm_equals_tm:
+  assumes "k \<ge> 2" and "j3 > 0" and "G \<ge> 4"
+  shows "turing_machine k G (tm_equals j1 j2 j3)"
+  unfolding tm_equals_def using tm_cmp_tm tm_cr_tm assms by simp
+
+text \<open>
+We analyze the behavior of @{const tm_equals} inside a locale. This is how we
+will typically proceed for Turing machines that are composed of more than two
+TMs. The locale is parameterized by the TM's parameters, which in the present
+case means the three tape indices $j_1$, $j_2$, and $j_3$.  Inside the locale
+the TM is decomposed such that proofs of @{const transforms} only involve two
+TMs combined by one of the three control structures (sequence, branch, loop).
+In the current example we have three TMs named @{term tm1}, @{term tm2}, @{term
+tm3}, where @{term tm3} is just @{const tm_equals}. Furthermore there will be
+lemmas \emph{tm1}, \emph{tm2}, \emph{tm3} describing, in terms of @{const
+transforms}, the behavior of the respective TMs. For this we define three tape
+lists @{term tps1}, @{term tps2}, @{term tps3}.
+
+This naming scheme creates many name clashes for things that only have a single
+use. That is the reason for the encapsulation in a locale.
+
+Afterwards this locale is interpreted, just once in lemma~@{text
+transforms_tm_equalsI}, to prove the semantics and running time of @{const
+tm_equals}.
+
+\null
+\<close>
+
+locale turing_machine_equals =
+  fixes j1 j2 j3 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_cmp j1 j2 j3"
+definition "tm2 \<equiv> tm1 ;; tm_cr j1"
+definition "tm3 \<equiv> tm2 ;; tm_cr j2"
+
+lemma tm3_eq_tm_equals: "tm3 = tm_equals j1 j2 j3"
+  unfolding tm3_def tm2_def tm1_def tm_equals_def by simp
+
+context
+  fixes tps0 :: "tape list" and k t b :: nat and xs ys :: "symbol list"
+  assumes jk [simp]: "length tps0 = k" "j1 \<noteq> j2" "j2 \<noteq> j3" "j1 \<noteq> j3" "j1 < k" "j2 < k" "j3 < k"
+    and proper: "proper_symbols xs" "proper_symbols ys"
+    and t: "t = Suc (min (length xs) (length ys))"
+    and b: "b = (if xs = ys then 3 else 0)"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    "tps0 ! j2 = (\<lfloor>ys\<rfloor>, 1)"
+begin
+
+definition "m \<equiv>
+  (if xs = ys
+   then Suc (length xs)
+   else (LEAST m. m \<le> Suc (min (length xs) (length ys)) \<and> \<lfloor>xs\<rfloor> m \<noteq> \<lfloor>ys\<rfloor> m))"
+
+lemma m_gr_0: "m > 0"
+proof -
+  have "\<lfloor>xs\<rfloor> m \<noteq> \<lfloor>ys\<rfloor> m" if "xs \<noteq> ys"
+    using ex_contents_neq LeastI_ex m_def proper that by (metis (mono_tags, lifting))
+  then show "m > 0"
+    using m_def by (metis contents_at_0 gr0I less_Suc_eq_0_disj)
+qed
+
+lemma m_le_t: "m \<le> t"
+proof (cases "xs = ys")
+  case True
+  then show ?thesis
+    using t m_def by simp
+next
+  case False
+  then have "m \<le> Suc (min (length xs) (length ys))"
+    using ex_contents_neq False proper m_def by (metis (mono_tags, lifting) LeastI_ex)
+  then show ?thesis
+    using t by simp
+qed
+
+definition "tps1 \<equiv> tps0[j1 := (\<lfloor>xs\<rfloor>, m), j2 := (\<lfloor>ys\<rfloor>, m), j3 := tps0 ! j3 |:=| b]"
+
+lemma tm1 [transforms_intros]: "transforms tm1 tps0 t tps1"
+  unfolding tm1_def
+proof (tform tps: tps0 tps1_def m_def b time: t)
+  show "proper_symbols xs" "proper_symbols ys"
+    using proper by simp_all
+qed
+
+definition "tps2 \<equiv> tps0[j1 := (\<lfloor>xs\<rfloor>, 1), j2 := (\<lfloor>ys\<rfloor>, m), j3 := tps0 ! j3 |:=| b]"
+
+lemma tm2:
+  assumes "ttt = t + m + 2"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps1_def)
+  show "clean_tape (tps1 ! j1)"
+    using tps1_def clean_contents_proper jk proper(1)
+    by (metis nth_list_update_eq nth_list_update_neq)
+  show "ttt = t + (tps1 :#: j1 + 2)"
+    using tps1_def tps0 jk assms
+    by (metis (no_types, lifting) ab_semigroup_add_class.add_ac(1) nth_list_update_eq nth_list_update_neq snd_conv)
+  show "tps2 = tps1[j1 := tps1 ! j1 |#=| 1]"
+    unfolding tps2_def tps1_def by (simp add: list_update_swap[of j1])
+qed
+
+lemma tm2' [transforms_intros]: "transforms tm2 tps0 (2 * t + 2) tps2"
+  using m_le_t tm2 transforms_monotone by simp
+
+definition "tps3 \<equiv> tps0[j1 := (\<lfloor>xs\<rfloor>, 1), j2 := (\<lfloor>ys\<rfloor>, 1), j3 := tps0 ! j3 |:=| b]"
+
+lemma tm3:
+  assumes "ttt = 2 * t + m + 4"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps2_def tps3_def)
+  have *: "tps2 ! j2 = (\<lfloor>ys\<rfloor>, m)"
+    using tps2_def by (simp add: nth_list_update_neq')
+  then show "clean_tape (tps2 ! j2)"
+    using clean_contents_proper proper(2) by simp
+  show "ttt = 2 * t + 2 + (tps2 :#: j2 + 2)"
+    using assms * by simp
+  show "tps3 = tps2[j2 := tps2 ! j2 |#=| 1]"
+    unfolding tps3_def tps2_def by (simp add: list_update_swap[of j2])
+qed
+
+definition "tps3' \<equiv> tps0[j3 := tps0 ! j3 |:=| b]"
+
+lemma tm3': "transforms tm3 tps0 (3 * min (length xs) (length ys) + 7) tps3'"
+proof -
+  have "tps3' = tps3"
+    using tps3'_def tps3_def tps0 jk by (metis list_update_id)
+  then show ?thesis
+    using m_le_t tm3 transforms_monotone t by simp
+qed
+
+end  (* context tps0 k xs ys *)
+
+end  (* locale turing_machine_equals *)
+
+lemma transforms_tm_equalsI [transforms_intros]:
+  fixes j1 j2 j3 :: tapeidx
+  fixes tps tps' :: "tape list" and k :: nat and xs ys :: "symbol list" and b :: symbol
+  assumes "length tps = k" "j1 \<noteq> j2" "j2 \<noteq> j3" "j1 \<noteq> j3" "j1 < k" "j2 < k" "j3 < k"
+    and "proper_symbols xs" "proper_symbols ys"
+    and "b = (if xs = ys then \<one> else \<box>)"
+  assumes
+    "tps ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>ys\<rfloor>, 1)"
+  assumes "ttt = 3 * min (length xs) (length ys) + 7"
+  assumes "tps' = tps
+    [j3 := tps ! j3 |:=| b]"
+  shows "transforms (tm_equals j1 j2 j3) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_equals j1 j2 j3 .
+  show ?thesis
+    using assms loc.tm3' loc.tm3_eq_tm_equals loc.tps3'_def by simp
+qed
+
+
+subsection \<open>Computing the identity function\<close>
+
+text \<open>
+In order to compute the identity function, a Turing machine can just copy the
+input tape to the output tape:
+\<close>
+
+definition tm_id :: machine where
+  "tm_id \<equiv> tm_cp_until 0 1 {\<box>}"
+
+lemma tm_id_tm:
+  assumes "1 < k" and "G \<ge> 4"
+  shows "turing_machine k G tm_id"
+  unfolding tm_id_def using assms tm_cp_until_tm by simp
+
+lemma transforms_tm_idI:
+  fixes zs :: "symbol list" and k :: nat and tps :: "tape list"
+  assumes "1 < k"
+    and "proper_symbols zs"
+    and "tps = snd (start_config k zs)"
+    and "tps' = tps[0 := (\<lfloor>zs\<rfloor>, (Suc (length zs))), 1 := (\<lfloor>zs\<rfloor>, (Suc (length zs)))]"
+  shows "transforms tm_id tps (Suc (Suc (length zs))) tps'"
+proof -
+  let ?n = "Suc (length zs)"
+  define tps2 where
+    "tps2 = tps[0 := tps ! 0 |+| (Suc (length zs)), 1 := implant (tps ! 0) (tps ! 1) (Suc (length zs))]"
+  have 1: "rneigh (tps ! 0) {\<box>} ?n"
+  proof (rule rneighI)
+    show "(tps ::: 0) (tps :#: 0 + Suc (length zs)) \<in> {\<box>}"
+      using start_config2 start_config3 assms by (simp add: start_config_def)
+    show "\<And>n'. n' < Suc (length zs) \<Longrightarrow> (tps ::: 0) (tps :#: 0 + n') \<notin> {\<box>}"
+      using start_config2 start_config3 start_config_pos assms
+      by (metis One_nat_def Suc_lessD add_cancel_right_left diff_Suc_1 less_Suc_eq_0_disj less_Suc_eq_le not_one_less_zero singletonD)
+  qed
+  have 2: "length tps = k"
+    using assms(1,3) by (simp add: start_config_length)
+  have **: "transforms tm_id tps (Suc ?n) tps2"
+    unfolding tm_id_def using transforms_tm_cp_untilI[OF _ assms(1) 2 1 _ tps2_def] assms(1) by simp
+
+  have 0: "tps ! 0 = (\<lfloor>zs\<rfloor>, 0)"
+    using assms start_config_def contents_def by auto
+  moreover have "tps ! 1 = (\<lfloor>[]\<rfloor>, 0)"
+    using assms start_config_def contents_def by auto
+  moreover have "implant (\<lfloor>zs\<rfloor>, 0) (\<lfloor>[]\<rfloor>, 0) ?n = (\<lfloor>zs\<rfloor>, ?n)"
+    by (rule implantI''') simp_all
+  ultimately have "implant (tps ! 0) (tps ! 1) ?n = (\<lfloor>zs\<rfloor>, ?n)"
+    by simp
+  then have "tps2 = tps[0 := tps ! 0 |+| ?n, 1 := (\<lfloor>zs\<rfloor>, ?n)]"
+    using tps2_def by simp
+  then have "tps2 = tps[0 := (\<lfloor>zs\<rfloor>, ?n), 1 := (\<lfloor>zs\<rfloor>, ?n)]"
+    using 0 by simp
+  then have "tps2 = tps'"
+    using assms(4) by simp
+  then show ?thesis
+    using ** by simp
+qed
+
+text \<open>
+The identity function is computable with a time bound of $n + 2$.
+\<close>
+
+lemma computes_id: "computes_in_time 2 tm_id id (\<lambda>n. Suc (Suc n))"
+proof
+  fix x :: string
+  let ?zs = "string_to_symbols x"
+  let ?start = "snd (start_config 2 ?zs)"
+  let ?T = "\<lambda>n. Suc (Suc n)"
+  let ?tps = "?start[0 := (\<lfloor>?zs\<rfloor>, (Suc (length ?zs))), 1 := (\<lfloor>?zs\<rfloor>, (Suc (length ?zs)))]"
+  have "proper_symbols ?zs"
+    by simp
+  then have "transforms tm_id ?start (Suc (Suc (length ?zs))) ?tps"
+    using transforms_tm_idI One_nat_def less_2_cases_iff by blast
+  then have "transforms tm_id ?start (?T (length x)) ?tps"
+    by simp
+  moreover have "?tps ::: 1 = string_to_contents (id x)"
+    by (auto simp add: start_config_length)
+  ultimately show "\<exists>tps. tps ::: 1 = string_to_contents (id x) \<and> transforms tm_id ?start (?T (length x)) tps"
+    by auto
+qed
+
+end
diff --git a/thys/Cook_Levin/Lists_Lists.thy b/thys/Cook_Levin/Lists_Lists.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Lists_Lists.thy
@@ -0,0 +1,3898 @@
+section \<open>Lists of numbers\label{s:tm-numlist}\<close>
+
+theory Lists_Lists
+  imports Arithmetic
+begin
+
+text \<open>
+In the previous section we defined a representation for numbers over the binary
+alphabet @{text "{\<zero>,\<one>}"}. In this section we first introduce a representation
+of lists of numbers as symbol sequences over the alphabet @{text "{\<zero>,\<one>,\<bar>}"}.
+Then we define Turing machines for some operations over such lists.
+
+As with the arithmetic operations, Turing machines implementing the operations
+on lists usually expect the tape heads of the operands to be in position~1 and
+guarantee to place the tape heads of the result in position~1. The exception are
+Turing machines for iterating over lists; such TMs move the tape head to the
+next list element.
+
+A tape containing such representations corresponds to a variable of type @{typ
+"nat list"}. A tape in the start configuration corresponds to the empty list of
+numbers.
+\<close>
+
+
+subsection \<open>Representation as symbol sequence\label{s:tm-numlist-repr}\<close>
+
+text \<open>
+The obvious idea for representing a list of numbers is to write them one after
+another separated by a fresh symbol, such as @{text "\<bar>"}. However since we
+represent the number~0 by the empty symbol sequence, this would result in both
+the empty list and the list containing only the number~0 to be represented by
+the same symbol sequence, namely the empty one. To prevent this we use the
+symbol @{text "\<bar>"} not as a separator but as a terminator; that is, we append it
+to every number.  Consequently the empty symbol sequence represents the empty
+list, whereas the list $[0]$ is represented by the symbol sequence @{text "\<bar>"}.
+As another example, the list $[14,0,0,7]$ is represented by
+@{text "\<zero>\<one>\<one>\<one>\<bar>\<bar>\<bar>\<one>\<one>\<one>\<bar>"}. As a side effect of using terminators instead of
+separators, the representation of the concatenation of lists is just the
+concatenation of the representations of the individual lists.  Moreover the
+length of the representation is simply the sum of the individual representation
+lengths. The number of @{text "\<bar>"} symbols equals the number of elements in the
+list.
+\<close>
+
+text \<open>
+This is how lists of numbers are represented as symbol sequences:
+\<close>
+
+definition numlist :: "nat list \<Rightarrow> symbol list" where
+  "numlist ns \<equiv> concat (map (\<lambda>n. canrepr n @ [\<bar>]) ns)"
+
+lemma numlist_Nil: "numlist [] = []"
+  using numlist_def by simp
+
+proposition "numlist [0] = [\<bar>]"
+  using numlist_def by (simp add: canrepr_0)
+
+lemma numlist_234: "set (numlist ns) \<subseteq> {\<zero>, \<one>, \<bar>}"
+proof (induction ns)
+  case Nil
+  then show ?case
+    using numlist_def by simp
+next
+  case (Cons n ns)
+  have "numlist (n # ns) = canrepr n @ [\<bar>] @ concat (map (\<lambda>n. canrepr n @ [\<bar>]) ns)"
+    using numlist_def by simp
+  then have "numlist (n # ns) = canrepr n @ [\<bar>] @ numlist ns"
+    using numlist_def by simp
+  moreover have "set ([\<bar>] @ numlist ns) \<subseteq> {\<zero>, \<one>, \<bar>}"
+    using Cons by simp
+  moreover have "set (canrepr n) \<subseteq> {\<zero>, \<one>, \<bar>}"
+    using bit_symbols_canrepr by (metis in_set_conv_nth insertCI subsetI)
+  ultimately show ?case
+    by simp
+qed
+
+lemma symbols_lt_numlist: "symbols_lt 5 (numlist ns)"
+  using numlist_234
+  by (metis empty_iff insert_iff nth_mem numeral_less_iff semiring_norm(68) semiring_norm(76) semiring_norm(79)
+    semiring_norm(80) subset_code(1) verit_comp_simplify1(2))
+
+lemma bit_symbols_prefix_eq:
+  assumes "(x @ [\<bar>]) @ xs = (y @ [\<bar>]) @ ys" and "bit_symbols x" and "bit_symbols y"
+  shows "x = y"
+proof -
+  have *: "x @ [\<bar>] @ xs = y @ [\<bar>] @ ys"
+      (is "?lhs = ?rhs")
+    using assms(1) by simp
+  show "x = y"
+  proof (cases "length x \<le> length y")
+    case True
+    then have "?lhs ! i = ?rhs ! i" if "i < length x" for i
+      using that * by simp
+    then have eq: "x ! i = y ! i" if "i < length x" for i
+      using that True by (metis Suc_le_eq le_trans nth_append)
+    have "?lhs ! (length x) = \<bar>"
+      by (metis Cons_eq_appendI nth_append_length)
+    then have "?rhs ! (length x) = \<bar>"
+      using * by metis
+    then have "length y \<le> length x"
+      using assms(3)
+      by (metis linorder_le_less_linear nth_append numeral_eq_iff semiring_norm(85) semiring_norm(87) semiring_norm(89))
+    then have "length y = length x"
+      using True by simp
+    then show ?thesis
+      using eq by (simp add: list_eq_iff_nth_eq)
+  next
+    case False
+    then have "?lhs ! i = ?rhs ! i" if "i < length y" for i
+      using that * by simp
+    have "?rhs ! (length y) = \<bar>"
+      by (metis Cons_eq_appendI nth_append_length)
+    then have "?lhs ! (length y) = \<bar>"
+      using * by metis
+    then have "x ! (length y) = \<bar>"
+      using False by (simp add: nth_append)
+    then have False
+      using assms(2) False
+      by (metis linorder_le_less_linear numeral_eq_iff semiring_norm(85) semiring_norm(87) semiring_norm(89))
+    then show ?thesis
+      by simp
+  qed
+qed
+
+lemma numlist_inj: "numlist ns1 = numlist ns2 \<Longrightarrow> ns1 = ns2"
+proof (induction ns1 arbitrary: ns2)
+  case Nil
+  then show ?case
+    using numlist_def by simp
+next
+  case (Cons n ns1)
+  have 1: "numlist (n # ns1) = (canrepr n @ [\<bar>]) @ numlist ns1"
+    using numlist_def by simp
+  then have "numlist ns2 = (canrepr n @ [\<bar>]) @ numlist ns1"
+    using Cons by simp
+  then have "ns2 \<noteq> []"
+    using numlist_Nil by auto
+  then have 2: "ns2 = hd ns2 # tl ns2"
+    using `ns2 \<noteq> []` by simp
+  then have 3: "numlist ns2 = (canrepr (hd ns2) @ [\<bar>]) @ numlist (tl ns2)"
+    using numlist_def by (metis concat.simps(2) list.simps(9))
+
+  have 4: "hd ns2 = n"
+    using bit_symbols_prefix_eq 1 3 by (metis Cons.prems canrepr bit_symbols_canrepr)
+  then have "numlist ns2 = (canrepr n @ [\<bar>]) @ numlist (tl ns2)"
+    using 3 by simp
+  then have "numlist ns1 = numlist (tl ns2)"
+    using 1 by (simp add: Cons.prems)
+  then have "ns1 = tl ns2"
+    using Cons by simp
+  then show ?case
+    using 2 4 by simp
+qed
+
+corollary proper_symbols_numlist: "proper_symbols (numlist ns)"
+  using numlist_234 nth_mem by fastforce
+
+text \<open>
+The next property would not hold if we used separators between
+elements instead of terminators after elements.
+\<close>
+
+lemma numlist_append: "numlist (xs @ ys) = numlist xs @ numlist ys"
+  using numlist_def by simp
+
+text \<open>
+Like @{const nlength} for numbers, we have @{term nllength} for the length of
+the representation of a list of numbers.
+\<close>
+
+definition nllength :: "nat list \<Rightarrow> nat" where
+  "nllength ns \<equiv> length (numlist ns)"
+
+lemma nllength: "nllength ns = (\<Sum>n\<leftarrow>ns. Suc (nlength n))"
+  using nllength_def numlist_def by (induction ns) simp_all
+
+lemma nllength_Nil [simp]: "nllength [] = 0"
+  using nllength_def numlist_def by simp
+
+lemma length_le_nllength: "length ns \<le> nllength ns"
+  using nllength sum_list_mono[of ns "\<lambda>_. 1" "\<lambda>n. Suc (nlength n)"] sum_list_const[of 1 ns]
+  by simp
+
+lemma nllength_le_len_mult_max:
+  fixes N :: nat and ns :: "nat list"
+  assumes "\<forall>n\<in>set ns. n \<le> N"
+  shows "nllength ns \<le> Suc (nlength N) * length ns"
+proof -
+  have "nllength ns = (\<Sum>n\<leftarrow>ns. Suc (nlength n))"
+    using nllength by simp
+  moreover have "Suc (nlength n) \<le> Suc (nlength N)" if "n \<in> set ns" for n
+    using nlength_mono that assms by simp
+  ultimately have "nllength ns \<le> (\<Sum>n\<leftarrow>ns. Suc (nlength N))"
+    by (simp add: sum_list_mono)
+  then show "nllength ns \<le> Suc (nlength N) * length ns"
+    using sum_list_const by metis
+qed
+
+lemma nllength_upt_le_len_mult_max:
+  fixes a b :: nat
+  shows "nllength [a..<b] \<le> Suc (nlength b) * (b - a)"
+  using nllength_le_len_mult_max[of "[a..<b]" b] by simp
+
+lemma nllength_le_len_mult_Max: "nllength ns \<le> Suc (nlength (Max (set ns))) * length ns"
+  using nllength_le_len_mult_max by simp
+
+lemma member_le_nllength: "n \<in> set ns \<Longrightarrow> nlength n \<le> nllength ns"
+  using nllength by (induction ns) auto
+
+lemma member_le_nllength_1: "n \<in> set ns \<Longrightarrow> nlength n \<le> nllength ns - 1"
+  using nllength by (induction ns) auto
+
+lemma nllength_gr_0: "ns \<noteq> [] \<Longrightarrow> 0 < nllength ns"
+  using nllength_def numlist_def by simp
+
+lemma nlength_min_le_nllength: "n \<in> set ns \<Longrightarrow> m \<in> set ns \<Longrightarrow> nlength (min n m) \<le> nllength ns"
+  using member_le_nllength by (simp add: min_def)
+
+lemma take_drop_numlist:
+  assumes "i < length ns"
+  shows "take (Suc (nlength (ns ! i))) (drop (nllength (take i ns)) (numlist ns)) = canrepr (ns ! i) @ [\<bar>]"
+proof -
+  have "numlist ns = numlist (take i ns) @ numlist (drop i ns)"
+    using numlist_append by (metis append_take_drop_id)
+  moreover have "numlist (drop i ns) = numlist [ns ! i] @ numlist (drop (Suc i) ns)"
+    using assms numlist_append by (metis Cons_nth_drop_Suc append_Cons self_append_conv2)
+  ultimately have "numlist ns = numlist (take i ns) @ numlist [ns ! i] @ numlist (drop (Suc i) ns)"
+    by simp
+  then have "drop (nllength (take i ns)) (numlist ns) = numlist [ns ! i] @ numlist (drop (Suc i) ns)"
+    by (simp add: nllength_def)
+  then have "drop (nllength (take i ns)) (numlist ns) = canrepr (ns ! i) @ [\<bar>] @ numlist (drop (Suc i) ns)"
+    using numlist_def by simp
+  then show ?thesis
+    by simp
+qed
+
+corollary take_drop_numlist':
+  assumes "i < length ns"
+  shows "take (nlength (ns ! i)) (drop (nllength (take i ns)) (numlist ns)) = canrepr (ns ! i)"
+  using take_drop_numlist[OF assms] by (metis append_assoc append_eq_conv_conj append_take_drop_id)
+
+corollary numlist_take_at_term:
+  assumes "i < length ns"
+  shows "numlist ns ! (nllength (take i ns) + nlength (ns ! i)) = \<bar>"
+  using assms take_drop_numlist nllength_def numlist_append
+  by (smt (z3) append_eq_conv_conj append_take_drop_id lessI nth_append_length nth_append_length_plus nth_take)
+
+lemma numlist_take_at:
+  assumes "i < length ns" and "j < nlength (ns ! i)"
+  shows "numlist ns ! (nllength (take i ns) + j) = canrepr (ns ! i) ! j"
+proof -
+  have "ns = take i ns @ [ns ! i] @ drop (Suc i) ns"
+    using assms by (metis Cons_eq_appendI append_self_conv2 id_take_nth_drop)
+  then have "numlist ns = (numlist (take i ns) @ numlist [ns ! i]) @ numlist (drop (Suc i) ns)"
+    using numlist_append by (metis append_assoc)
+  moreover have "nllength (take i ns) + j < nllength (take i ns) + nllength [ns ! i]"
+    using assms(2) nllength by simp
+  ultimately have "numlist ns ! (nllength (take i ns) + j) =
+      (numlist (take i ns) @ numlist [ns ! i]) ! (nllength (take i ns) + j)"
+    by (metis length_append nllength_def nth_append)
+  also have "... = numlist [ns ! i] ! j"
+    by (simp add: nllength_def)
+  also have "... = (canrepr (ns ! i) @ [\<bar>]) ! j"
+    using numlist_def by simp
+  also have "... = canrepr (ns ! i) ! j"
+    using assms(2) by (simp add: nth_append)
+  finally show ?thesis .
+qed
+
+lemma nllength_take_Suc:
+  assumes "i < length ns"
+  shows "nllength (take i ns) + Suc (nlength (ns ! i)) = nllength (take (Suc i) ns)"
+proof -
+  have "ns = take i ns @ [ns ! i] @ drop (Suc i) ns"
+    using assms by (metis Cons_eq_appendI append_self_conv2 id_take_nth_drop)
+  then have "numlist ns = numlist (take i ns) @ numlist [ns ! i] @ numlist (drop (Suc i) ns)"
+    using numlist_append by metis
+  then have "nllength ns = nllength (take i ns) + nllength [ns ! i] + nllength (drop (Suc i) ns)"
+    by (simp add: nllength_def)
+  moreover have "nllength ns = nllength (take (Suc i) ns) + nllength (drop (Suc i) ns)"
+    using numlist_append by (metis append_take_drop_id length_append nllength_def)
+  ultimately have "nllength (take (Suc i) ns) = nllength (take i ns) + nllength [ns ! i]"
+    by simp
+  then show ?thesis
+    using nllength by simp
+qed
+
+lemma numlist_take_Suc_at_term:
+  assumes "i < length ns"
+  shows "numlist ns ! (nllength (take (Suc i) ns) - 1) = \<bar>"
+proof -
+  have "nllength (take (Suc i) ns) - 1 = nllength (take i ns) + nlength (ns ! i)"
+    using nllength_take_Suc assms by (metis add_Suc_right diff_Suc_1)
+  then show ?thesis
+    using numlist_take_at_term assms by simp
+qed
+
+lemma nllength_take:
+  assumes "i < length ns"
+  shows "nllength (take i ns) + nlength (ns ! i) < nllength ns"
+proof -
+  have "ns = take i ns @ [ns ! i] @ drop (Suc i) ns"
+    using assms by (metis Cons_eq_appendI append_self_conv2 id_take_nth_drop)
+  then have "numlist ns = numlist (take i ns) @ numlist [ns ! i] @ numlist (drop (Suc i) ns)"
+    using numlist_append by metis
+  then have "nllength ns = nllength (take i ns) + nllength [ns ! i] + nllength (drop (Suc i) ns)"
+    by (simp add: nllength_def)
+  then have "nllength ns \<ge> nllength (take i ns) + nllength [ns ! i]"
+    by simp
+  then have "nllength ns \<ge> nllength (take i ns) + Suc (nlength (ns ! i))"
+    using nllength by simp
+  then show ?thesis
+    by simp
+qed
+
+text \<open>
+The contents of a tape starting with the start symbol @{text \<triangleright>} followed by the
+symbol sequence representing a list of numbers:
+\<close>
+
+definition nlcontents :: "nat list \<Rightarrow> (nat \<Rightarrow> symbol)" ("\<lfloor>_\<rfloor>\<^sub>N\<^sub>L") where
+  "\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L \<equiv> \<lfloor>numlist ns\<rfloor>"
+
+lemma clean_tape_nlcontents: "clean_tape (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, i)"
+  by (simp add: nlcontents_def proper_symbols_numlist)
+
+lemma nlcontents_Nil: "\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L = \<lfloor>[]\<rfloor>"
+  using nlcontents_def by (simp add: numlist_Nil)
+
+lemma nlcontents_rneigh_4:
+  assumes "i < length ns"
+  shows "rneigh (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take i ns))) {\<bar>} (nlength (ns ! i))"
+proof (rule rneighI)
+  let ?tp = "(\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take i ns)))"
+  show "fst ?tp (snd ?tp + nlength (ns ! i)) \<in> {\<bar>}"
+  proof -
+    have "snd ?tp + nlength (ns ! i) \<le> nllength ns"
+      using nllength_take assms by (simp add: Suc_leI)
+    then have "fst ?tp (snd ?tp + nlength (ns ! i)) = numlist ns ! (nllength (take i ns) + nlength (ns ! i))"
+      using nlcontents_def contents_inbounds nllength_def by simp
+    then show ?thesis
+      using numlist_take_at_term assms by simp
+  qed
+  show "fst ?tp (snd ?tp + j) \<notin> {\<bar>}" if "j < nlength (ns ! i)" for j
+  proof -
+    have "snd ?tp + nlength (ns ! i) \<le> nllength ns"
+      using nllength_take assms by (simp add: Suc_leI)
+    then have "snd ?tp + j \<le> nllength ns"
+      using that by simp
+    then have "fst ?tp (snd ?tp + j) = numlist ns ! (nllength (take i ns) + j)"
+      using nlcontents_def contents_inbounds nllength_def by simp
+    then have "fst ?tp (snd ?tp + j) = canrepr (ns ! i) ! j"
+      using assms that numlist_take_at by simp
+    then show ?thesis
+      using bit_symbols_canrepr that by fastforce
+  qed
+qed
+
+lemma nlcontents_rneigh_04:
+  assumes "i < length ns"
+  shows "rneigh (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take i ns))) {\<box>, \<bar>} (nlength (ns ! i))"
+proof (rule rneighI)
+  let ?tp = "(\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take i ns)))"
+  show "fst ?tp (snd ?tp + nlength (ns ! i)) \<in> {\<box>, \<bar>}"
+  proof -
+    have "snd ?tp + nlength (ns ! i) \<le> nllength ns"
+      using nllength_take assms by (simp add: Suc_leI)
+    then have "fst ?tp (snd ?tp + nlength (ns ! i)) = numlist ns ! (nllength (take i ns) + nlength (ns ! i))"
+      using nlcontents_def contents_inbounds nllength_def by simp
+    then show ?thesis
+      using numlist_take_at_term assms by simp
+  qed
+  show "fst ?tp (snd ?tp + j) \<notin> {\<box>, \<bar>}" if "j < nlength (ns ! i)" for j
+  proof -
+    have "snd ?tp + nlength (ns ! i) \<le> nllength ns"
+      using nllength_take assms by (simp add: Suc_leI)
+    then have "snd ?tp + j \<le> nllength ns"
+      using that by simp
+    then have "fst ?tp (snd ?tp + j) = numlist ns ! (nllength (take i ns) + j)"
+      using nlcontents_def contents_inbounds nllength_def by simp
+    then have "fst ?tp (snd ?tp + j) = canrepr (ns ! i) ! j"
+      using assms that numlist_take_at by simp
+    then show ?thesis
+      using bit_symbols_canrepr that by fastforce
+  qed
+qed
+
+text \<open>
+A tape storing a list of numbers, with the tape head in the first blank cell
+after the symbols:
+\<close>
+
+abbreviation nltape :: "nat list \<Rightarrow> tape" where
+  "nltape ns \<equiv> (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength ns))"
+
+text \<open>
+A tape storing a list of numbers, with the tape head on the first symbol
+representing the $i$-th number, unless the $i$-th number is zero, in which case
+the tape head is on the terminator symbol of this zero. If $i$ is out of bounds
+of the list, the tape head is at the first blank after the list.
+\<close>
+
+abbreviation nltape' :: "nat list \<Rightarrow> nat \<Rightarrow> tape" where
+  "nltape' ns i \<equiv> (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take i ns)))"
+
+lemma nltape'_tape_read: "|.| (nltape' ns i) = \<box> \<longleftrightarrow> i \<ge> length ns"
+proof -
+  have "|.| (nltape' ns i) = \<box>" if "i \<ge> length ns" for i
+  proof -
+    have "nltape' ns i \<equiv> (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength ns))"
+      using that by simp
+    then show ?thesis
+      using nlcontents_def contents_outofbounds nllength_def
+      by (metis Suc_eq_plus1 add.left_neutral fst_conv less_Suc0 less_add_eq_less snd_conv)
+  qed
+  moreover have "|.| (nltape' ns i) \<noteq> \<box>" if "i < length ns" for i
+    using that nlcontents_def contents_inbounds nllength_def nllength_take proper_symbols_numlist
+    by (metis Suc_leI add_Suc_right diff_Suc_1 fst_conv less_add_same_cancel1 less_le_trans not_add_less2
+      plus_1_eq_Suc snd_conv zero_less_Suc)
+  ultimately show ?thesis
+    by (meson le_less_linear)
+qed
+
+
+subsection \<open>Moving to the next element\<close>
+
+text \<open>
+The next Turing machine provides a means to iterate over a list of numbers.  If
+the TM starts in a configuration where the tape $j_1$ contains a list of numbers
+and the tape head is on the first symbol of the $i$-th element of this list,
+then after the TM has finished, the $i$-th element will be written on tape
+$j_2$ and the tape head on $j_1$ will have advanced by one list element. If
+$i$ is the last element of the list, the tape head on $j_1$ will be on a blank
+symbol. One can execute this TM in a loop until the tape head reaches a blank.
+The TM is generic over a parameter $z$ representing the terminator symbol, so it
+can be used for other kinds of lists, too (see Section~\ref{s:tm-numlistlist}).
+
+\null
+\<close>
+
+definition tm_nextract :: "symbol \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_nextract z j1 j2 \<equiv>
+    tm_erase_cr j2 ;;
+    tm_cp_until j1 j2 {z} ;;
+    tm_cr j2 ;;
+    tm_right j1"
+
+lemma tm_nextract_tm:
+  assumes "G \<ge> 4" and "G > z" and "0 < j2" and "j2 < k" and "j1 < k" and "k \<ge> 2"
+  shows "turing_machine k G (tm_nextract z j1 j2)"
+  unfolding tm_nextract_def
+  using assms tm_erase_cr_tm tm_cp_until_tm tm_cr_tm tm_right_tm
+  by simp
+
+text \<open>
+The next locale is for the case @{text "z = \<bar>"}.
+
+\null
+\<close>
+
+locale turing_machine_nextract_4 =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_erase_cr j2"
+definition "tm2 \<equiv> tm1 ;; tm_cp_until j1 j2 {\<bar>}"
+definition "tm3 \<equiv> tm2 ;; tm_cr j2"
+definition "tm4 \<equiv> tm3 ;; tm_right j1"
+
+lemma tm4_eq_tm_nextract: "tm4 = tm_nextract \<bar> j1 j2"
+  unfolding tm1_def tm2_def tm3_def tm4_def tm_nextract_def by simp
+
+context
+  fixes tps0 :: "tape list" and k idx dummy :: nat and ns :: "nat list"
+  assumes jk: "j1 < k" "j2 < k" "0 < j1" "0 < j2" "j1 \<noteq> j2" "length tps0 = k"
+    and idx: "idx < length ns"
+    and tps0:
+      "tps0 ! j1 = nltape' ns idx"
+      "tps0 ! j2 = (\<lfloor>dummy\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0[j2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 7 + 2 * nlength dummy"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: jk idx tps0 tps1_def assms)
+  show "proper_symbols (canrepr dummy)"
+    using proper_symbols_canrepr by simp
+  show "tps1 = tps0[j2 := (\<lfloor>[]\<rfloor>, 1)]"
+    using ncontents_0 tps1_def by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, nllength (take (Suc idx) ns)),
+   j2 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, Suc (nlength (ns ! idx)))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 7 + 2 * nlength dummy + Suc (nlength (ns ! idx))"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: jk idx tps0 tps2_def tps1_def)
+  show "rneigh (tps1 ! j1) {\<bar>} (nlength (ns ! idx))"
+    using tps1_def tps0 jk by (simp add: idx nlcontents_rneigh_4)
+  show "tps2 = tps1
+    [j1 := tps1 ! j1 |+| nlength (ns ! idx),
+     j2 := implant (tps1 ! j1) (tps1 ! j2) (nlength (ns ! idx))]"
+     (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show len: "length ?l = length ?r"
+      using tps1_def tps2_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      consider "i = j1" | "i = j2" | "i \<noteq> j1 \<and> i \<noteq> j2"
+        by auto
+      then show ?thesis
+      proof (cases)
+        case 1
+        then show ?thesis
+          using tps0 that tps1_def tps2_def jk nllength_take_Suc[OF idx] idx by simp
+      next
+        case 2
+        then have lhs: "?l ! i = (\<lfloor>ns ! idx\<rfloor>\<^sub>N, Suc (nlength (ns ! idx)))"
+          using tps2_def jk by simp
+        let ?i = "Suc (nllength (take idx ns))"
+        have i1: "?i > 0"
+          by simp
+        have "nlength (ns ! idx) + (?i - 1) \<le> nllength ns"
+          using idx by (simp add: add.commute less_or_eq_imp_le nllength_take)
+        then have i2: "nlength (ns ! idx) + (?i - 1) \<le> length (numlist ns)"
+          using nllength_def by simp
+        have "?r ! i = implant (tps1 ! j1) (tps1 ! j2) (nlength (ns ! idx))"
+          using 2 tps1_def jk by simp
+        also have "... = implant (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, ?i) (\<lfloor>0\<rfloor>\<^sub>N, 1) (nlength (ns ! idx))"
+          using tps1_def jk tps0 by simp
+        also have "... =
+          (\<lfloor>[] @ (take (nlength (ns ! idx)) (drop (?i - 1) (numlist ns)))\<rfloor>,
+           Suc (length []) + nlength (ns ! idx))"
+          using implant_contents[OF i1 i2] by (metis One_nat_def list.size(3) ncontents_0 nlcontents_def)
+        finally have "?r ! i =
+          (\<lfloor>[] @ (take (nlength (ns ! idx)) (drop (?i - 1) (numlist ns)))\<rfloor>,
+           Suc (length []) + nlength (ns ! idx))" .
+        then have "?r ! i = (\<lfloor>take (nlength (ns ! idx)) (drop (nllength (take idx ns)) (numlist ns))\<rfloor>, Suc (nlength (ns ! idx)))"
+          by simp
+        then have "?r ! i = (\<lfloor>canrepr (ns ! idx)\<rfloor>, Suc (nlength (ns ! idx)))"
+          using take_drop_numlist'[OF idx] by simp
+        then show ?thesis
+          using lhs by simp
+      next
+        case 3
+        then show ?thesis
+          using that tps1_def tps2_def jk by simp
+      qed
+    qed
+  qed
+  show "ttt = 7 + 2 * nlength dummy + Suc (nlength (ns ! idx))"
+    using assms(1) .
+qed
+
+definition "tps3 \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, nllength (take (Suc idx) ns)),
+   j2 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 11 + 2 * nlength dummy + 2 * (nlength (ns ! idx))"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: jk idx tps0 tps2_def tps3_def time: assms tps2_def jk)
+  show "clean_tape (tps2 ! j2)"
+    using tps2_def jk clean_tape_ncontents by simp
+qed
+
+definition "tps4 \<equiv> tps0
+  [j1 := nltape' ns (Suc idx),
+   j2 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4:
+  assumes "ttt = 12 + 2 * nlength dummy + 2 * (nlength (ns ! idx))"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: jk idx tps0 tps3_def tps4_def time: assms)
+  show "tps4 = tps3[j1 := tps3 ! j1 |+| 1]"
+    using tps3_def tps4_def jk tps0
+    by (metis Suc_eq_plus1 fst_conv list_update_overwrite list_update_swap nth_list_update_eq nth_list_update_neq snd_conv)
+qed
+
+end  (* context *)
+
+end  (* locale turing_machine_nextract *)
+
+lemma transforms_tm_nextract_4I [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and k idx dummy :: nat and ns :: "nat list"
+  assumes "j1 < k" "j2 < k" "0 < j1" "0 < j2" "j1 \<noteq> j2" "length tps = k"
+    and "idx < length ns"
+  assumes
+    "tps ! j1 = nltape' ns idx"
+    "tps ! j2 = (\<lfloor>dummy\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 12 + 2 * nlength dummy + 2 * (nlength (ns ! idx))"
+  assumes "tps' = tps
+    [j1 := nltape' ns (Suc idx),
+     j2 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_nextract \<bar> j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_nextract_4 j1 j2 .
+  show ?thesis
+    using assms loc.tm4 loc.tps4_def loc.tm4_eq_tm_nextract by simp
+qed
+
+
+subsection \<open>Appending an element\<close>
+
+text \<open>
+The next Turing machine appends the number on tape $j_2$ to the list of numbers
+on tape $j_1$.
+\<close>
+
+definition tm_append :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_append j1 j2 \<equiv>
+    tm_right_until j1 {\<box>} ;;
+    tm_cp_until j2 j1 {\<box>} ;;
+    tm_cr j2 ;;
+    tm_char j1 \<bar>"
+
+lemma tm_append_tm:
+  assumes "0 < j1" and "G \<ge> 5" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_append j1 j2)"
+  unfolding tm_append_def
+  using assms tm_right_until_tm tm_cp_until_tm tm_right_tm tm_char_tm tm_cr_tm
+  by simp
+
+locale turing_machine_append =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_right_until j1 {\<box>}"
+definition "tm2 \<equiv> tm1 ;; tm_cp_until j2 j1 {\<box>}"
+definition "tm3 \<equiv> tm2 ;; tm_cr j2"
+definition "tm4 \<equiv> tm3 ;; tm_char j1 \<bar>"
+
+lemma tm4_eq_tm_append: "tm4 = tm_append j1 j2"
+  unfolding tm4_def tm3_def tm2_def tm1_def tm_append_def by simp
+
+context
+  fixes tps0 :: "tape list" and k i1 n :: nat and ns :: "nat list"
+  assumes jk: "length tps0 = k" "j1 < k" "j2 < k" "j1 \<noteq> j2" "0 < j1"
+    and i1: "i1 \<le> Suc (nllength ns)"
+    and tps0:
+      "tps0 ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, i1)"
+      "tps0 ! j2 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+begin
+
+lemma k: "k \<ge> 2"
+  using jk by simp
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = Suc (Suc (nllength ns) - i1)"
+    and "tps' = tps0[j1 := nltape ns]"
+  shows "transforms tm1 tps0 ttt tps'"
+  unfolding tm1_def
+proof (tform tps: jk k)
+  let ?l = "Suc (nllength ns) - i1"
+  show "rneigh (tps0 ! j1) {0} ?l"
+  proof (rule rneighI)
+    show "(tps0 ::: j1) (tps0 :#: j1 + ?l) \<in> {0}"
+      using tps0 jk nlcontents_def nllength_def by simp
+    show "(tps0 ::: j1) (tps0 :#: j1 + i) \<notin> {0}" if "i < Suc (nllength ns) - i1" for i
+    proof -
+      have "i1 + i < Suc (nllength ns)"
+        using that i1 by simp
+      then show ?thesis
+        using proper_symbols_numlist nllength_def tps0 nlcontents_def contents_def
+        by (metis One_nat_def Suc_le_eq diff_Suc_1 fst_eqD less_Suc_eq_0_disj less_nat_zero_code singletonD snd_eqD)
+    qed
+  qed
+  show "ttt = Suc (Suc (nllength ns) - i1)"
+    using assms(1) .
+  show "tps' = tps0[j1 := tps0 ! j1 |+| Suc (nllength ns) - i1]"
+    using assms(2) tps0 i1 by simp
+qed
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 3 + nllength ns - i1 + nlength n"
+    and "tps' = tps0
+      [j1 := (\<lfloor>numlist ns @ canrepr n\<rfloor>, Suc (nllength ns) + nlength n),
+       j2 := (\<lfloor>n\<rfloor>\<^sub>N, Suc (nlength n))]"
+  shows "transforms tm2 tps0 ttt tps'"
+  unfolding tm2_def
+proof (tform tps: jk tps0)
+  let ?tps = "tps0[j1 := nltape ns]"
+  have j1: "?tps ! j1 = nltape ns"
+    by (simp add: jk)
+  have j2: "?tps ! j2 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    using tps0 jk by simp
+  show "rneigh (tps0[j1 := nltape ns] ! j2) {0} (nlength n)"
+  proof (rule rneighI)
+    show "(?tps ::: j2) (?tps :#: j2 + nlength n) \<in> {0}"
+      using j2 contents_outofbounds by simp
+    show "\<And>i. i < nlength n \<Longrightarrow> (?tps ::: j2) (?tps :#: j2 + i) \<notin> {0}"
+      using j2 tps0 bit_symbols_canrepr by fastforce
+  qed
+  show "tps' = tps0
+    [j1 := nltape ns,
+     j2 := ?tps ! j2 |+| nlength n,
+     j1 := implant (?tps ! j2) (?tps ! j1) (nlength n)]"
+    (is "_ = ?rhs")
+  proof -
+    have "implant (?tps ! j2) (?tps ! j1) (nlength n) = implant (\<lfloor>n\<rfloor>\<^sub>N, 1) (nltape ns) (nlength n)"
+      using j1 j2 by simp
+    also have "... = (\<lfloor>numlist ns @ (take (nlength n) (drop (1 - 1) (canrepr n)))\<rfloor>, Suc (length (numlist ns)) + nlength n)"
+      using implant_contents nlcontents_def nllength_def by simp
+    also have "... = (\<lfloor>numlist ns @ canrepr n\<rfloor>, Suc (length (numlist ns)) + nlength n)"
+      by simp
+    also have "... = (\<lfloor>numlist ns @ canrepr n\<rfloor>, Suc (nllength ns) + nlength n)"
+      using nllength_def by simp
+    also have "... = tps' ! j1"
+      by (metis assms(2) jk(1,2,4) nth_list_update_eq nth_list_update_neq)
+    finally have "implant (?tps ! j2) (?tps ! j1) (nlength n) = tps' ! j1" .
+    then have "tps' ! j1 = implant (?tps ! j2) (?tps ! j1) (nlength n)"
+      by simp
+    then have "tps' ! j1 = ?rhs ! j1"
+      by (simp add: jk)
+    moreover have "tps' ! j2 = ?rhs ! j2"
+      using assms(2) jk j2 by simp
+    moreover have "tps' ! j = ?rhs ! j" if "j < length tps'" "j \<noteq> j1" "j \<noteq> j2" for j
+      using that assms(2) by simp
+    moreover have "length tps' = length ?rhs"
+      using assms(2) by simp
+    ultimately show ?thesis
+      using nth_equalityI by blast
+  qed
+  show "ttt = Suc (Suc (nllength ns) - i1) + Suc (nlength n)"
+    using assms(1) j1 tps0 i1 by simp
+qed
+
+definition "tps3 \<equiv> tps0
+    [j1 := (\<lfloor>numlist ns @ canrepr n\<rfloor>, Suc (nllength ns) + nlength n)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 6 + nllength ns - i1 + 2 * nlength n"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: jk k)
+  let ?tp1 = "(\<lfloor>numlist ns @ canrepr n\<rfloor>, Suc (nllength ns) + nlength n)"
+  let ?tp2 = "(\<lfloor>n\<rfloor>\<^sub>N, Suc (nlength n))"
+  show "clean_tape (tps0 [j1 := ?tp1, j2 := ?tp2] ! j2)"
+    by (simp add: clean_tape_ncontents jk)
+  show "tps3 = tps0[j1 := ?tp1, j2 := ?tp2, j2 := tps0 [j1 := ?tp1, j2 := ?tp2] ! j2 |#=| 1]"
+    using tps3_def tps0 jk
+    by (metis (no_types, lifting) add_Suc fst_conv length_list_update list_update_id list_update_overwrite
+      list_update_swap nth_list_update_eq)
+  show "ttt =
+    3 + nllength ns - i1 + nlength n + (tps0[j1 := ?tp1, j2 := ?tp2] :#: j2 + 2)"
+  proof -
+    have "tps0[j1 := ?tp1, j2 := ?tp2] :#: j2 = Suc (nlength n)"
+      by (simp add: jk)
+    then show ?thesis
+      using jk tps0 i1 assms(1) by simp
+  qed
+qed
+
+definition "tps4 = tps0
+    [j1 := (\<lfloor>numlist (ns @ [n])\<rfloor>, Suc (nllength (ns @ [n])))]"
+
+lemma tm4:
+  assumes "ttt = 7 + nllength ns - i1 + 2 * nlength n"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: jk tps0 tps3_def)
+  show "ttt = 6 + nllength ns - i1 + 2 * nlength n + 1 "
+      using i1 assms(1) by simp
+  show "tps4 = tps3[j1 := tps3 ! j1 |:=| \<bar> |+| 1]"
+    (is "tps4 = ?tps")
+  proof -
+    have "?tps = tps0[j1 := (\<lfloor>numlist ns @ canrepr n\<rfloor>, Suc (nllength ns + nlength n)) |:=| \<bar> |+| 1]"
+      using tps3_def by (simp add: jk)
+    moreover have "(\<lfloor>numlist ns @ canrepr n\<rfloor>, Suc (nllength ns + nlength n)) |:=| \<bar> |+| 1 =
+        (\<lfloor>numlist (ns @ [n])\<rfloor>, Suc (nllength (ns @ [n])))"
+      (is "?lhs = ?rhs")
+    proof -
+      have "?lhs = (\<lfloor>numlist ns @ canrepr n\<rfloor>(Suc (nllength ns + nlength n) := \<bar>), Suc (Suc (nllength ns + nlength n)))"
+        by simp
+      also have "... = (\<lfloor>numlist ns @ canrepr n\<rfloor>(Suc (nllength ns + nlength n) := \<bar>), Suc (nllength (ns @ [n])))"
+        using nllength_def numlist_def by simp
+      also have "... = (\<lfloor>(numlist ns @ canrepr n) @ [\<bar>]\<rfloor>, Suc (nllength (ns @ [n])))"
+        using contents_snoc by (metis length_append nllength_def)
+      also have "... = (\<lfloor>numlist ns @ canrepr n @ [\<bar>]\<rfloor>, Suc (nllength (ns @ [n])))"
+        by simp
+      also have "... = (\<lfloor>numlist (ns @ [n])\<rfloor>, Suc (nllength (ns @ [n])))"
+        using numlist_def by simp
+      finally show "?lhs = ?rhs" .
+    qed
+    ultimately show ?thesis
+      using tps4_def by auto
+  qed
+qed
+
+end
+
+end  (* locale turing_machine_append *)
+
+lemma tm_append [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps :: "tape list" and k i1 n :: nat and ns :: "nat list"
+  assumes "0 < j1"
+  assumes "length tps = k" "j1 < k" "j2 < k" "j1 \<noteq> j2" "i1 \<le> Suc (nllength ns)"
+    and "tps ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, i1)"
+    and "tps ! j2 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 7 + nllength ns - i1 + 2 * nlength n"
+    and "tps' = tps
+      [j1 := nltape (ns @ [n])]"
+  shows "transforms (tm_append j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_append j1 j2 .
+  show ?thesis
+    using loc.tm4 loc.tm4_eq_tm_append loc.tps4_def assms nlcontents_def by simp
+qed
+
+
+subsection \<open>Computing the length\<close>
+
+text \<open>
+The next Turing machine counts the number of terminator symbols $z$ on tape
+$j_1$ and stores the result on tape $j_2$. Thus, if $j_1$ contains a list of
+numbers, tape $j_2$ will contain the length of the list.
+\<close>
+
+definition tm_count :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol \<Rightarrow> machine" where
+  "tm_count j1 j2 z \<equiv>
+    WHILE tm_right_until j1 {\<box>, z} ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO
+      tm_incr j2 ;;
+      tm_right j1
+    DONE ;;
+    tm_cr j1"
+
+lemma tm_count_tm:
+  assumes "0 < j2" and "j1 < k" and "j2 < k" and "j1 \<noteq> j2" and "G \<ge> 4"
+  shows "turing_machine k G (tm_count j1 j2 z)"
+  unfolding tm_count_def
+  using turing_machine_loop_turing_machine tm_right_until_tm tm_incr_tm tm_cr_tm tm_right_tm assms
+  by simp
+
+locale turing_machine_count =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tmC \<equiv> tm_right_until j1 {\<box>, \<bar>}"
+definition "tmB1 \<equiv> tm_incr j2"
+definition "tmB2 \<equiv> tmB1 ;; tm_right j1"
+definition "tmL \<equiv> WHILE tmC ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO tmB2 DONE"
+definition "tm2 \<equiv> tmL ;; tm_cr j1"
+
+lemma tm2_eq_tm_count: "tm2 = tm_count j1 j2 \<bar>"
+  unfolding tmB1_def tmB2_def tmC_def tmL_def tm2_def tm_count_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and ns :: "nat list"
+  assumes jk: "j1 < k" "j2 < k" "0 < j2" "j1 \<noteq> j2" "length tps0 = k"
+    and tps0:
+      "tps0 ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+      "tps0 ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tpsL t \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take t ns))),
+   j2 := (\<lfloor>t\<rfloor>\<^sub>N, 1)]"
+
+definition "tpsC t \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, if t < length ns then nllength (take (Suc t) ns) else Suc (nllength ns)),
+   j2 := (\<lfloor>t\<rfloor>\<^sub>N, 1)]"
+
+lemma tmC:
+  assumes "t \<le> length ns"
+    and "ttt = Suc (if t = length ns then 0 else nlength (ns ! t))"
+  shows "transforms tmC (tpsL t) ttt (tpsC t)"
+  unfolding tmC_def
+proof (tform tps: jk tpsL_def tpsC_def)
+  let ?n = "if t = length ns then 0 else nlength (ns ! t)"
+  have *: "tpsL t ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take t ns)))"
+    using tpsL_def jk by simp
+  show "rneigh (tpsL t ! j1) {\<box>, \<bar>} ?n"
+  proof (cases "t = length ns")
+    case True
+    then have "tpsL t ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength ns))" (is "_ = ?tp")
+      using * by simp
+    moreover from this have "fst ?tp (snd ?tp) \<in> {\<box>, \<bar>}"
+      by (simp add: nlcontents_def nllength_def)
+    moreover have "?n = 0"
+      using True by simp
+    ultimately show ?thesis
+      using rneighI by simp
+  next
+    case False
+    then have "tpsL t ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take t ns)))"
+      using * by simp
+    moreover have "?n = nlength (ns ! t)"
+      using False by simp
+    ultimately show ?thesis
+      using nlcontents_rneigh_04 by (simp add: False assms(1) le_neq_implies_less)
+  qed
+  show "tpsC t = (tpsL t) [j1 := tpsL t ! j1 |+| (if t = length ns then 0 else nlength (ns ! t))]"
+    (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using tpsC_def tpsL_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      consider "i = j1" | "i = j2" | "i \<noteq> j1 \<and> i \<noteq> j2"
+        by auto
+      then show ?thesis
+      proof (cases)
+        case 1
+        show ?thesis
+        proof (cases "t = length ns")
+          case True
+          then show ?thesis
+            using 1 by (simp add: jk(2,4) tpsC_def tpsL_def)
+        next
+          case False
+          then have "t < length ns"
+            using assms(1) by simp
+          then show ?thesis
+            using 1 nllength_take_Suc jk tpsC_def tpsL_def by simp
+        qed
+      next
+        case 2
+        then show ?thesis
+          by (simp add: jk(2,4,5) tpsC_def tpsL_def)
+      next
+        case 3
+        then show ?thesis
+          by (simp add: jk(2,4) tpsC_def tpsL_def)
+      qed
+    qed
+  qed
+  show "ttt = Suc (if t = length ns then 0 else nlength (ns ! t))"
+    using assms(2) .
+qed
+
+lemma tmC' [transforms_intros]:
+  assumes "t \<le> length ns"
+  shows "transforms tmC (tpsL t) (Suc (nllength ns)) (tpsC t)"
+proof -
+  have "Suc (if t = length ns then 0 else nlength (ns ! t)) \<le> Suc (if t = length ns then 0 else nllength ns)"
+    using assms member_le_nllength by simp
+  then have "Suc (if t = length ns then 0 else nlength (ns ! t)) \<le> Suc (nllength ns)"
+    by auto
+  then show ?thesis
+    using tmC transforms_monotone assms by metis
+qed
+
+definition "tpsB1 t \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, nllength (take (Suc t) ns)),
+   j2 := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1)]"
+
+lemma tmB1 [transforms_intros]:
+  assumes "t < length ns" and "ttt = 5 + 2 * nlength t"
+  shows "transforms tmB1 (tpsC t) ttt (tpsB1 t)"
+  unfolding tmB1_def by (tform tps: jk tpsC_def tpsB1_def assms)
+
+definition "tpsB2 t \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take (Suc t) ns))),
+   j2 := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1)]"
+
+lemma tmB2:
+  assumes "t < length ns" and "ttt = 6 + 2 * nlength t"
+  shows "transforms tmB2 (tpsC t) ttt (tpsB2 t)"
+  unfolding tmB2_def by (tform tps: jk tpsB1_def tpsB2_def assms)
+
+lemma tpsB2_eq_tpsL: "tpsB2 t = tpsL (Suc t)"
+  using tpsB2_def tpsL_def by simp
+
+lemma tmB2' [transforms_intros]:
+  assumes "t < length ns"
+  shows "transforms tmB2 (tpsC t) (6 + 2 * nllength ns) (tpsL (Suc t))"
+proof -
+  have "nlength t \<le> nllength ns"
+    using assms(1) length_le_nllength nlength_le_n by (meson le_trans less_or_eq_imp_le)
+  then have "6 + 2 * nlength t \<le> 6 + 2 * nllength ns"
+    by simp
+  then show ?thesis
+    using assms tmB2 transforms_monotone tpsB2_eq_tpsL by metis
+qed
+
+lemma tmL [transforms_intros]:
+  assumes "ttt = 13 * nllength ns ^ 2 + 2"
+  shows "transforms tmL (tpsL 0) ttt (tpsC (length ns))"
+  unfolding tmL_def
+proof (tform)
+  show "read (tpsC t) ! j1 \<noteq> \<box>" if "t < length ns" for t
+  proof -
+    have "tpsC t ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, if t < length ns then nllength (take (Suc t) ns) else Suc (nllength ns))"
+      using tpsC_def jk by simp
+    then have *: "tpsC t ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, nllength (take (Suc t) ns))" (is "_ = ?tp")
+      using that by simp
+    have "fst ?tp (snd ?tp) = \<lfloor>ns\<rfloor>\<^sub>N\<^sub>L (nllength (take (Suc t) ns))"
+      by simp
+    also have "... = \<lfloor>numlist ns\<rfloor> (nllength (take (Suc t) ns))"
+      using nlcontents_def by simp
+    also have "... = numlist ns ! (nllength (take (Suc t) ns) - 1)"
+      using nllength that contents_inbounds nllength_def nllength_take nllength_take_Suc
+      by (metis Suc_leI add_Suc_right less_nat_zero_code not_less_eq)
+    also have "... = 4"
+      using numlist_take_Suc_at_term[OF that] by simp
+    finally have "fst ?tp (snd ?tp) = \<bar>" .
+    then have "fst ?tp (snd ?tp) \<noteq> \<box>"
+      by simp
+    then show ?thesis
+      using * jk(1,5) length_list_update tapes_at_read' tpsC_def by metis
+  qed
+  show "\<not> read (tpsC (length ns)) ! j1 \<noteq> \<box>"
+  proof -
+    have "tpsC (length ns) ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength ns))" (is "_ = ?tp")
+      using tpsC_def jk by simp
+    moreover have "fst ?tp (snd ?tp) = 0"
+      by (simp add: nlcontents_def nllength_def)
+    ultimately have "read (tpsC (length ns)) ! j1 = \<box>"
+      using jk(1,5) length_list_update tapes_at_read' tpsC_def by metis
+    then show ?thesis
+      by simp
+  qed
+  show "length ns * (Suc (nllength ns) + (6 + 2 * nllength ns) + 2) + Suc (nllength ns) + 1 \<le> ttt"
+  proof -
+    have "length ns * (Suc (nllength ns) + (6 + 2 * nllength ns) + 2) + Suc (nllength ns) + 1 =
+        length ns * (9 + 3 * nllength ns) + nllength ns + 2"
+      by simp
+    also have "... \<le> nllength ns * (9 + 3 * nllength ns) + nllength ns + 2"
+      by (simp add: length_le_nllength)
+    also have "... = nllength ns * (10 + 3 * nllength ns) + 2"
+      by algebra
+    also have "... = 10 * nllength ns + 3 * nllength ns ^ 2 + 2"
+      by algebra
+    also have "... \<le> 10 * nllength ns ^ 2 + 3 * nllength ns ^ 2 + 2"
+      by (meson add_mono_thms_linordered_semiring(1) le_eq_less_or_eq mult_le_mono2 power2_nat_le_imp_le)
+    also have "... = 13 * nllength ns ^ 2 + 2"
+      by simp
+    finally show ?thesis
+      using assms by simp
+  qed
+qed
+
+definition "tps2 \<equiv> tps0
+  [j2 := (\<lfloor>length ns\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2:
+  assumes "ttt = 13 * nllength ns ^ 2 + 5 + nllength ns"
+  shows "transforms tm2 (tpsL 0) ttt tps2"
+  unfolding tm2_def
+proof (tform tps: jk tpsC_def tps2_def)
+  have *: "tpsC (length ns) ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength ns))"
+    using jk tpsC_def by simp
+  then show "clean_tape (tpsC (length ns) ! j1)"
+    by (simp add: clean_tape_nlcontents)
+  show "tps2 = (tpsC (length ns))[j1 := tpsC (length ns) ! j1 |#=| 1]"
+    using jk tps0(1) tps2_def tpsC_def * by (metis fstI list_update_id list_update_overwrite list_update_swap)
+  show "ttt = 13 * (nllength ns)\<^sup>2 + 2 + (tpsC (length ns) :#: j1 + 2)"
+    using assms * by simp
+qed
+
+lemma tpsL_eq_tps0: "tpsL 0 = tps0"
+  using tpsL_def tps0 by (metis One_nat_def list_update_id nllength_Nil take0)
+
+lemma tm2':
+  assumes "ttt = 14 * nllength ns ^ 2 + 5"
+  shows "transforms tm2 tps0 ttt tps2"
+proof -
+  have "nllength ns \<le> nllength ns ^ 2"
+    using power2_nat_le_imp_le by simp
+  then have "13 * nllength ns ^ 2 + 5 + nllength ns \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using assms tm2 transforms_monotone tpsL_eq_tps0 by simp
+qed
+
+end  (* context tps0 *)
+
+end  (* locale *)
+
+lemma transforms_tm_count_4I [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and k :: nat and ns :: "nat list"
+  assumes "j1 < k" "j2 < k" "0 < j2" "j1 \<noteq> j2" "length tps = k"
+  assumes
+    "tps ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 14 * nllength ns ^ 2 + 5"
+  assumes "tps' = tps[j2 := (\<lfloor>length ns\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_count j1 j2 \<bar>) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_count j1 j2 .
+  show ?thesis
+    using loc.tm2_eq_tm_count loc.tm2' loc.tps2_def assms by simp
+qed
+
+
+subsection \<open>Extracting the $n$-th element\<close>
+
+text \<open>
+The next Turing machine expects a list on tape $j_1$ and an index $i$ on $j_2$
+and writes the $i$-th element of the list to $j_2$, overwriting $i$.  The TM
+does not terminate for out-of-bounds access, which of course we will never
+attempt. Again the parameter $z$ is a generic terminator symbol.
+\<close>
+
+definition tm_nth_inplace :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol \<Rightarrow> machine" where
+  "tm_nth_inplace j1 j2 z \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! j2 \<noteq> \<box> DO
+      tm_decr j2 ;;
+      tm_right_until j1 {z} ;;
+      tm_right j1
+    DONE ;;
+    tm_cp_until j1 j2 {z} ;;
+    tm_cr j2 ;;
+    tm_cr j1"
+
+lemma tm_nth_inplace_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j2" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_nth_inplace j1 j2 \<bar>)"
+  unfolding tm_nth_inplace_def
+  using assms tm_decr_tm tm_right_until_tm tm_right_tm tm_cp_until_tm tm_cr_tm Nil_tm
+  by (simp add: assms(1) turing_machine_loop_turing_machine)
+
+locale turing_machine_nth_inplace =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tmL1 \<equiv> tm_decr j2"
+definition "tmL2 \<equiv> tmL1 ;; tm_right_until j1 {\<bar>}"
+definition "tmL3 \<equiv> tmL2 ;; tm_right j1"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! j2 \<noteq> \<box> DO tmL3 DONE"
+definition "tm2 \<equiv> tmL ;; tm_cp_until j1 j2 {\<bar>}"
+definition "tm3 \<equiv> tm2 ;; tm_cr j2"
+definition "tm4 \<equiv> tm3 ;; tm_cr j1"
+
+lemma tm4_eq_tm_nth_inplace: "tm4 = tm_nth_inplace j1 j2 \<bar>"
+  unfolding tmL1_def tmL2_def tmL3_def tmL_def tm2_def tm3_def tm4_def tm_nth_inplace_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k idx :: nat and ns :: "nat list"
+  assumes jk: "j1 < k" "j2 < k" "0 < j2" "j1 \<noteq> j2" "length tps0 = k"
+    and idx: "idx < length ns"
+    and tps0:
+      "tps0 ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+      "tps0 ! j2 = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tpsL t \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take t ns))),
+   j2 := (\<lfloor>idx - t\<rfloor>\<^sub>N, 1)]"
+
+definition "tpsL1 t \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take t ns))),
+   j2 := (\<lfloor>idx - t - 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL1 [transforms_intros]:
+  assumes "ttt = 8 + 2 * nlength (idx - t)"
+  shows "transforms tmL1 (tpsL t) ttt (tpsL1 t)"
+  unfolding tmL1_def by (tform tps: tpsL_def tpsL1_def jk time: assms)
+
+definition "tpsL2 t \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, nllength (take (Suc t) ns)),
+   j2 := (\<lfloor>idx - t - 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL2:
+  assumes "t < length ns" and "ttt = 8 + 2 * nlength (idx - t) + Suc (nlength (ns ! t))"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL2 t)"
+  unfolding tmL2_def
+proof (tform tps: jk tpsL1_def tpsL2_def time: assms(2))
+  let ?l = "nlength (ns ! t)"
+  show "rneigh (tpsL1 t ! j1) {\<bar>} ?l"
+  proof -
+    have "tpsL1 t ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take t ns)))"
+      using tpsL1_def jk by (simp only: nth_list_update_eq nth_list_update_neq)
+    then show ?thesis
+      using assms(1) nlcontents_rneigh_4 by simp
+  qed
+  show "tpsL2 t = (tpsL1 t)[j1 := tpsL1 t ! j1 |+| nlength (ns ! t)]"
+    (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show len: "length ?l = length ?r"
+      using tpsL1_def tpsL2_def jk by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      consider "i = j1" | "i = j2" | "i \<noteq> j1 \<and> i \<noteq> j2"
+        by auto
+      then show ?thesis
+      proof (cases)
+        case 1
+        then show ?thesis
+          using that tpsL1_def tpsL2_def jk nllength_take_Suc[OF assms(1)] by simp
+      next
+        case 2
+        then show ?thesis
+          using that tpsL1_def tpsL2_def jk
+          by (simp only: nth_list_update_eq nth_list_update_neq' length_list_update)
+      next
+        case 3
+        then show ?thesis
+          using that tpsL1_def tpsL2_def jk
+          by (simp only: nth_list_update_eq jk nth_list_update_neq' length_list_update)
+      qed
+    qed
+  qed
+qed
+
+lemma tmL2' [transforms_intros]:
+  assumes "t < length ns" and "ttt = 9 + 2 * nlength idx + nlength (Max (set ns))"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL2 t)"
+proof -
+  let ?ttt = "8 + 2 * nlength (idx - t) + Suc (nlength (ns ! t))"
+  have "transforms tmL2 (tpsL t) ?ttt (tpsL2 t)"
+    using tmL2 assms by simp
+  moreover have "ttt \<ge> ?ttt"
+  proof -
+    have "nlength (idx - t) \<le> nlength idx"
+      using nlength_mono by simp
+    moreover have "nlength (ns ! t) \<le> nlength (Max (set ns))"
+      using nlength_mono assms by simp
+    ultimately show ?thesis
+      using assms(2) by simp
+  qed
+  ultimately show ?thesis
+    using transforms_monotone by simp
+qed
+
+definition "tpsL3 t \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take (Suc t) ns))),
+   j2 := (\<lfloor>idx - t - 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL3:
+  assumes "t < length ns" and "ttt = 10 + 2 * nlength idx + nlength (Max (set ns))"
+  shows "transforms tmL3 (tpsL t) ttt (tpsL3 t)"
+  unfolding tmL3_def
+proof (tform tps: jk tpsL2_def tpsL3_def assms(1) time: assms(2))
+  show "tpsL3 t = (tpsL2 t)[j1 := tpsL2 t ! j1 |+| 1]"
+    using tpsL3_def tpsL2_def jk tps0
+    by (metis Groups.add_ac(2) fst_conv list_update_overwrite list_update_swap nth_list_update nth_list_update_neq
+      plus_1_eq_Suc snd_conv)
+qed
+
+lemma tpsL3_eq_tpsL: "tpsL3 t = tpsL (Suc t)"
+  using tpsL3_def tpsL_def by simp
+
+lemma tmL:
+  assumes "ttt = idx * (12 + 2 * nlength idx + nlength (Max (set ns))) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL idx)"
+  unfolding tmL_def
+proof (tform)
+  let ?t = "10 + 2 * nlength idx + nlength (Max (set ns))"
+  show "\<And>t. t < idx \<Longrightarrow> transforms tmL3 (tpsL t) ?t (tpsL (Suc t))"
+    using tmL3 tpsL3_eq_tpsL idx by simp
+  show "read (tpsL t) ! j2 \<noteq> \<box>" if "t < idx" for t
+  proof -
+    have "tpsL t ! j2 = (\<lfloor>idx - t\<rfloor>\<^sub>N, 1)"
+      using tpsL_def jk by simp
+    then have "read (tpsL t) ! j2 = \<lfloor>idx - t\<rfloor>\<^sub>N 1"
+      using tapes_at_read' jk tpsL_def by (metis fst_conv length_list_update snd_conv)
+    moreover have "idx - t > 0"
+      using that by simp
+    ultimately show "read (tpsL t) ! j2 \<noteq> \<box>"
+      using ncontents_1_blank_iff_zero by simp
+  qed
+  show "\<not> read (tpsL idx) ! j2 \<noteq> \<box>"
+  proof -
+    have "tpsL idx ! j2 = (\<lfloor>idx - idx\<rfloor>\<^sub>N, 1)"
+      using tpsL_def jk by simp
+    then have "read (tpsL idx) ! j2 = \<lfloor>idx - idx\<rfloor>\<^sub>N 1"
+      using tapes_at_read' jk tpsL_def by (metis fst_conv length_list_update snd_conv)
+    then show ?thesis
+      using ncontents_1_blank_iff_zero by simp
+  qed
+  show "idx * (10 + 2 * nlength idx + nlength (Max (set ns)) + 2) + 1 \<le> ttt"
+    using assms by simp
+qed
+
+definition "tps1 \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take idx ns))),
+   j2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tps1_eq_tpsL: "tps1 = tpsL idx"
+  using tps1_def tpsL_def by simp
+
+lemma tps0_eq_tpsL: "tps0 = tpsL 0"
+  using tps0 tpsL_def nllength_Nil by (metis One_nat_def list_update_id minus_nat.diff_0 take0)
+
+lemma tmL' [transforms_intros]:
+  assumes "ttt = idx * (12 + 2 * nlength idx + nlength (Max (set ns))) + 1"
+  shows "transforms tmL tps0 ttt tps1"
+  using tmL assms tps0_eq_tpsL tps1_eq_tpsL by simp
+
+definition "tps2 \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, nllength (take (Suc idx) ns)),
+   j2 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, Suc (nlength (ns ! idx)))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = idx * (12 + 2 * nlength idx + nlength (Max (set ns))) + 2 + nlength (ns ! idx)"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: jk tps2_def tps1_def time: assms)
+  have "tps1 ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take idx ns)))"
+    using tps1_def tps0 jk by simp
+  then show "rneigh (tps1 ! j1) {\<bar>} (nlength (ns ! idx))"
+    by (simp add: idx nlcontents_rneigh_4)
+  show "tps2 = tps1
+    [j1 := tps1 ! j1 |+| nlength (ns ! idx),
+     j2 := implant (tps1 ! j1) (tps1 ! j2) (nlength (ns ! idx))]"
+     (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show len: "length ?l = length ?r"
+      using tps1_def tps2_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      consider "i = j1" | "i = j2" | "i \<noteq> j1 \<and> i \<noteq> j2"
+        by auto
+      then show ?thesis
+      proof (cases)
+        case 1
+        then show ?thesis
+          using that tps1_def tps2_def jk nllength_take_Suc idx by simp
+      next
+        case 2
+        then have lhs: "?l ! i = (\<lfloor>ns ! idx\<rfloor>\<^sub>N, Suc (nlength (ns ! idx)))"
+          using tps2_def jk by simp
+        let ?i = "Suc (nllength (take idx ns))"
+        have i1: "?i > 0"
+          by simp
+        have "nlength (ns ! idx) + (?i - 1) \<le> nllength ns"
+          using idx by (simp add: add.commute less_or_eq_imp_le nllength_take)
+        then have i2: "nlength (ns ! idx) + (?i - 1) \<le> length (numlist ns)"
+          using nllength_def by simp
+        have "?r ! i = implant (tps1 ! j1) (tps1 ! j2) (nlength (ns ! idx))"
+          using 2 tps1_def jk by simp
+        also have "... = implant (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, ?i) (\<lfloor>0\<rfloor>\<^sub>N, 1) (nlength (ns ! idx))"
+        proof -
+          have "tps1 ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (take idx ns)))"
+            using tps1_def jk by simp
+          moreover have "tps1 ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+            using tps1_def jk by simp
+          ultimately show ?thesis
+            by simp
+        qed
+        also have "... = (\<lfloor>[] @ (take (nlength (ns ! idx)) (drop (?i - 1) (numlist ns)))\<rfloor>, Suc (length []) + nlength (ns ! idx))"
+          using implant_contents[OF i1 i2] by (metis One_nat_def list.size(3) ncontents_0 nlcontents_def)
+        finally have "?r ! i = (\<lfloor>[] @ (take (nlength (ns ! idx)) (drop (?i - 1) (numlist ns)))\<rfloor>, Suc (length []) + nlength (ns ! idx))" .
+        then have "?r ! i = (\<lfloor>take (nlength (ns ! idx)) (drop (nllength (take idx ns)) (numlist ns))\<rfloor>, Suc (nlength (ns ! idx)))"
+          by simp
+        then have "?r ! i = (\<lfloor>canrepr (ns ! idx)\<rfloor>, Suc (nlength (ns ! idx)))"
+          using take_drop_numlist'[OF idx] by simp
+        then show ?thesis
+          using lhs by simp
+      next
+        case 3
+        then show ?thesis
+          using that tps1_def tps2_def jk by simp
+      qed
+    qed
+  qed
+qed
+
+definition "tps3 \<equiv> tps0
+  [j1 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, nllength (take (Suc idx) ns)),
+   j2 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = idx * (12 + 2 * nlength idx + nlength (Max (set ns))) + 5 + 2 * nlength (ns ! idx)"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+  by (tform tps: clean_tape_ncontents jk tps2_def tps3_def time: assms tps2_def jk)
+
+definition "tps4 \<equiv> tps0
+  [j2 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4:
+  assumes "ttt = idx * (12 + 2 * nlength idx + nlength (Max (set ns))) + 7 + 2 * nlength (ns ! idx) + nllength (take (Suc idx) ns)"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: clean_tape_nlcontents jk tps3_def tps4_def time: assms jk tps3_def)
+  show "tps4 = tps3[j1 := tps3 ! j1 |#=| 1]"
+    using tps4_def tps3_def jk tps0(1) list_update_id[of tps0 j1] by (simp add: list_update_swap)
+qed
+
+lemma tm4':
+  assumes "ttt = 18 * nllength ns ^ 2 + 12"
+  shows "transforms tm4 tps0 ttt tps4"
+proof -
+  let ?ttt = "idx * (12 + 2 * nlength idx + nlength (Max (set ns))) + 7 + 2 * nlength (ns ! idx) + nllength (take (Suc idx) ns)"
+
+  have 1: "idx \<le> nllength ns"
+    using idx length_le_nllength by (meson le_trans less_or_eq_imp_le)
+  then have 2: "nlength idx \<le> nllength ns"
+    using nlength_mono nlength_le_n by (meson dual_order.trans)
+  have "ns \<noteq> []"
+    using idx by auto
+  then have 3: "nlength (Max (set ns)) \<le> nllength ns"
+    using member_le_nllength by simp
+  have 4: "nlength (ns ! idx) \<le> nllength ns"
+    using idx member_le_nllength by simp
+  have 5: "nllength (take (Suc idx) ns) \<le> nllength ns"
+    by (metis Suc_le_eq add_Suc_right idx nllength_take nllength_take_Suc)
+
+  have "?ttt \<le> idx * (12 + 2 * nllength ns + nllength ns) + 7 + 2 * nllength ns + nllength ns"
+    using 2 3 4 5 by (meson add_le_mono le_eq_less_or_eq mult_le_mono2)
+  also have "... = idx * (12 + 3 * nllength ns) + 7 + 3 * nllength ns"
+    by simp
+  also have "... \<le> idx * (12 + 3 * nllength ns) + (12 + 3 * nllength ns)"
+    by simp
+  also have "... = Suc idx * (12 + 3 * nllength ns)"
+    by simp
+  also have "... \<le> Suc (nllength ns) * (12 + 3 * nllength ns)"
+    using 1 by simp
+  also have "... = nllength ns * (12 + 3 * nllength ns) + (12 + 3 * nllength ns)"
+    by simp
+  also have "... = 12 * nllength ns + 3 * nllength ns ^ 2 + 12 + 3 * nllength ns"
+    by algebra
+  also have "... = 15 * nllength ns + 3 * nllength ns ^ 2 + 12"
+    by simp
+  also have "... \<le> 18 * nllength ns ^ 2 + 12"
+    by (simp add: power2_eq_square)
+  finally have "?ttt \<le> 18 * nllength ns ^ 2 + 12" .
+  then show ?thesis
+    using tm4 transforms_monotone assms by simp
+qed
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_nth_inplace *)
+
+lemma transforms_tm_nth_inplace_4I [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and k idx :: nat and ns :: "nat list"
+  assumes "j1 < k" "j2 < k" "0 < j2" "j1 \<noteq> j2" "length tps = k"
+    and "idx < length ns"
+  assumes
+    "tps ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! j2 = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 18 * nllength ns ^ 2 + 12"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_nth_inplace j1 j2 \<bar>) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_nth_inplace j1 j2 .
+  show ?thesis
+    using assms loc.tm4_eq_tm_nth_inplace loc.tm4' loc.tps4_def by simp
+qed
+
+text \<open>
+The next Turing machine expects a list on tape $j_1$ and an index $i$ on tape
+$j_2$. It writes the $i$-th element of the list to tape $j_3$. Like the previous
+TM, it will not terminate on out-of-bounds access, and $z$ is a parameter for
+the symbol that terminates the list elements.
+\<close>
+
+definition tm_nth :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol \<Rightarrow> machine" where
+  "tm_nth j1 j2 j3 z \<equiv>
+    tm_copyn j2 j3 ;;
+    tm_nth_inplace j1 j3 z"
+
+lemma tm_nth_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j2" "0 < j1" "j1 < k" "j2 < k" "0 < j3" "j3 < k" "j2 \<noteq> j3"
+  shows "turing_machine k G (tm_nth j1 j2 j3 \<bar>)"
+  unfolding tm_nth_def using tm_copyn_tm tm_nth_inplace_tm assms by simp
+
+lemma transforms_tm_nth_4I [transforms_intros]:
+  fixes j1 j2 j3 :: tapeidx
+  fixes tps tps' :: "tape list" and k idx :: nat and ns :: "nat list"
+  assumes "j1 < k" "j2 < k" "j3 < k" "0 < j1" "0 < j2" "0 < j3" "j1 \<noteq> j2" "j2 \<noteq> j3" "j1 \<noteq> j3"
+    and "length tps = k"
+    and "idx < length ns"
+  assumes
+    "tps ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! j2 = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 21 * nllength ns ^ 2 + 26"
+  assumes "tps' = tps
+    [j3 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_nth j1 j2 j3 \<bar>) tps ttt tps'"
+proof -
+  let ?ttt = "14 + 3 * (nlength idx + nlength 0) + (18 * (nllength ns)\<^sup>2 + 12)"
+  have "transforms (tm_nth j1 j2 j3 \<bar>) tps ?ttt tps'"
+    unfolding tm_nth_def
+  proof (tform tps: assms(1-11))
+    show "tps ! j2 = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+      using assms by simp
+    show "tps ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      using assms by simp
+    show "tps[j3 := (\<lfloor>idx\<rfloor>\<^sub>N, 1)] ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+      using assms by simp
+    then show "tps' = tps
+      [j3 := (\<lfloor>idx\<rfloor>\<^sub>N, 1),
+       j3 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1)]"
+      using assms by (metis One_nat_def list_update_overwrite)
+  qed
+  moreover have "?ttt \<le> ttt"
+  proof -
+    have "nlength idx \<le> idx"
+      using nlength_le_n by simp
+    then have "nlength idx \<le> length ns"
+      using assms(11) by simp
+    then have "nlength idx \<le> nllength ns"
+      using length_le_nllength by (meson order.trans)
+    then have "nlength idx \<le> nllength ns ^ 2"
+      by (meson le_refl order_trans power2_nat_le_imp_le)
+    moreover have "?ttt = 3 * nlength idx + 18 * (nllength ns)\<^sup>2 + 26"
+      by simp
+    ultimately show ?thesis
+      using assms(15) by simp
+  qed
+  ultimately show ?thesis
+    using transforms_monotone by simp
+qed
+
+
+subsection \<open>Finding the previous position of an element\<close>
+
+text \<open>
+The Turing machine in this section implements a slightly peculiar functionality,
+which we will start using only in Section~\ref{s:Reducing}. Given a list of
+numbers and an index $i$ it determines the greatest index less than $i$ where
+the list contains the same element as in position $i$. If no such element
+exists, it returns $i$. Formally:
+\<close>
+
+definition previous :: "nat list \<Rightarrow> nat \<Rightarrow> nat" where
+  "previous ns idx \<equiv>
+    if \<exists>i<idx. ns ! i = ns ! idx
+    then GREATEST i. i < idx \<and> ns ! i = ns ! idx
+    else idx"
+
+lemma previous_less:
+  assumes "\<exists>i<idx. ns ! i = ns ! idx"
+  shows "previous ns idx < idx \<and> ns ! (previous ns idx) = ns ! idx"
+proof -
+  let ?P = "\<lambda>i. i < idx \<and> ns ! i = ns ! idx"
+  have "previous ns idx = (GREATEST i. ?P i)"
+    using assms previous_def by simp
+  moreover have "\<forall>y. ?P y \<longrightarrow> y \<le> idx"
+    by simp
+  ultimately show ?thesis
+    using GreatestI_ex_nat[OF assms, of idx] by simp
+qed
+
+lemma previous_eq: "previous ns idx = idx \<longleftrightarrow> \<not> (\<exists>i<idx. ns ! i = ns ! idx)"
+  using previous_def nat_less_le previous_less by simp
+
+lemma previous_le: "previous ns idx \<le> idx"
+  using previous_eq previous_less by (metis less_or_eq_imp_le)
+
+text \<open>
+The following Turing machine expects the list on tape $j_1$ and the index on
+tape $j_2$. It outputs the result on tape $j_2 + 5$. The tapes $j_2 + 1, \dots,
+j_2 + 4$ are scratch space.
+\<close>
+
+definition tm_prev :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_prev j1 j2 \<equiv>
+    tm_copyn j2 (j2 + 5) ;;
+    tm_nth j1 j2 (j2 + 1) \<bar> ;;
+    WHILE tm_equalsn (j2 + 2) j2 (j2 + 4) ; \<lambda>rs. rs ! (j2 + 4) = \<box> DO
+      tm_nth j1 (j2 + 2) (j2 + 3) \<bar> ;;
+      tm_equalsn (j2 + 1) (j2 + 3) (j2 + 4) ;;
+      tm_setn (j2 + 3) 0 ;;
+      IF \<lambda>rs. rs ! (j2 + 4) \<noteq> \<box> THEN
+        tm_setn (j2 + 4) 0 ;;
+        tm_copyn (j2 + 2) (j2 + 5)
+      ELSE
+        []
+      ENDIF ;;
+      tm_incr (j2 + 2)
+    DONE ;;
+    tm_erase_cr (j2 + 1) ;;
+    tm_erase_cr (j2 + 2) ;;
+    tm_erase_cr (j2 + 4)"
+
+lemma tm_prev_tm:
+  assumes "k \<ge> j2 + 6" and "G \<ge> 4" and "j1 < j2" and "0 < j1"
+  shows "turing_machine k G (tm_prev j1 j2)"
+  unfolding tm_prev_def
+  using assms tm_copyn_tm tm_nth_tm tm_equalsn_tm tm_setn_tm tm_incr_tm Nil_tm tm_erase_cr_tm
+    turing_machine_loop_turing_machine turing_machine_branch_turing_machine
+  by simp
+
+locale turing_machine_prev =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_copyn j2 (j2 + 5)"
+definition "tm2 \<equiv> tm1 ;; tm_nth j1 j2 (j2 + 1) \<bar>"
+definition "tmC \<equiv> tm_equalsn (j2 + 2) j2 (j2 + 4)"
+definition "tmB1 \<equiv> tm_nth j1 (j2 + 2) (j2 + 3) \<bar>"
+definition "tmB2 \<equiv> tmB1 ;; tm_equalsn (j2 + 1) (j2 + 3) (j2 + 4)"
+definition "tmB3 \<equiv> tmB2 ;; tm_setn (j2 + 3) 0"
+definition "tmI1 \<equiv> tm_setn (j2 + 4) 0"
+definition "tmI2 \<equiv> tmI1 ;; tm_copyn (j2 + 2) (j2 + 5)"
+definition "tmI \<equiv> IF \<lambda>rs. rs ! (j2 + 4) \<noteq> \<box> THEN tmI2 ELSE [] ENDIF"
+definition "tmB4 \<equiv> tmB3 ;; tmI"
+definition "tmB5 \<equiv> tmB4 ;; tm_incr (j2 + 2)"
+definition "tmL \<equiv> WHILE tmC ; \<lambda>rs. rs ! (j2 + 4) = \<box> DO tmB5 DONE"
+definition "tm3 \<equiv> tm2 ;; tmL"
+definition "tm4 \<equiv> tm3 ;; tm_erase_cr (j2 + 1)"
+definition "tm5 \<equiv> tm4 ;; tm_erase_cr (j2 + 2)"
+definition "tm6 \<equiv> tm5 ;; tm_erase_cr (j2 + 4)"
+
+lemma tm6_eq_tm_prev: "tm6 = tm_prev j1 j2"
+  unfolding tm_prev_def tm3_def tmL_def tmB5_def tmB4_def tmI_def tmI2_def tmI1_def tmB3_def
+    tmB2_def tmB1_def tmC_def tm2_def tm1_def tm4_def tm5_def tm6_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k idx :: nat and ns :: "nat list"
+  assumes jk: "0 < j1" "j1 < j2" "j2 + 6 \<le> k" "length tps0 = k"
+    and idx: "idx < length ns"
+    and tps0:
+      "tps0 ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+      "tps0 ! j2 = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+      "tps0 ! (j2 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      "tps0 ! (j2 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      "tps0 ! (j2 + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      "tps0 ! (j2 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      "tps0 ! (j2 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j2 + 5 := (\<lfloor>idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 14 + 3 * nlength idx"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def by (tform tps: jk idx tps0 tps1_def assms nlength_0)
+
+definition "tps2 \<equiv> tps0
+ [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+  j2 + 5 := (\<lfloor>idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2:
+  assumes "ttt = 14 + 3 * nlength idx + (21 * (nllength ns)\<^sup>2 + 26)"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: jk idx tps0 tps1_def tps2_def time: assms)
+
+definition rv :: "nat \<Rightarrow> nat" where
+  "rv t \<equiv> if \<exists>i<t. ns ! i = ns ! idx then GREATEST i. i < t \<and> ns ! i = ns ! idx else idx"
+
+lemma rv_0: "rv 0 = idx"
+  using rv_def by simp
+
+lemma rv_le: "rv t \<le> max t idx"
+proof (cases "\<exists>i<t. ns ! i = ns ! idx")
+  case True
+  let ?Q = "\<lambda>i. i < t \<and> ns ! i = ns ! idx"
+  have rvt: "rv t = Greatest ?Q"
+    using True rv_def by simp
+  moreover have "?Q (Greatest ?Q)"
+  proof (rule GreatestI_ex_nat)
+    show "\<exists>k<t. ns ! k = ns ! idx"
+      using True by simp
+    show "\<And>y. y < t \<and> ns ! y = ns ! idx \<Longrightarrow> y \<le> t"
+      by simp
+  qed
+  ultimately have "?Q (rv t)"
+    by simp
+  then have "rv t < t"
+    by simp
+  then show ?thesis
+    by simp
+next
+  case False
+  then show ?thesis
+    using rv_def by auto
+qed
+
+lemma rv_change:
+  assumes "t < length ns" and "idx < length ns" and "ns ! t = ns ! idx"
+  shows "rv (Suc t) = t"
+proof -
+  let ?P = "\<lambda>i. i < Suc t \<and> ns ! i = ns ! idx"
+  have "rv (Suc t) = Greatest ?P"
+    using assms(3) rv_def by auto
+  moreover have "Greatest ?P = t"
+  proof (rule Greatest_equality)
+    show "t < Suc t \<and> ns ! t = ns ! idx"
+      using assms(3) by simp
+    show "\<And>y. y < Suc t \<and> ns ! y = ns ! idx \<Longrightarrow> y \<le> t"
+      using assms by simp
+  qed
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma rv_keep:
+  assumes "t < length ns" and "idx < length ns" and "ns ! t \<noteq> ns ! idx"
+  shows "rv (Suc t) = rv t"
+proof (cases "\<exists>i<Suc t. ns ! i = ns ! idx")
+  case True
+  let ?Q = "\<lambda>i. i < t \<and> ns ! i = ns ! idx"
+  have ex: "\<exists>i<t. ns ! i = ns ! idx"
+    using True assms(3) less_antisym by blast
+  then have rvt: "rv t = Greatest ?Q"
+    using rv_def by simp
+  moreover have "?Q (Greatest ?Q)"
+  proof (rule GreatestI_ex_nat)
+    show "\<exists>k<t. ns ! k = ns ! idx"
+      using ex .
+    show "\<And>y. y < t \<and> ns ! y = ns ! idx \<Longrightarrow> y \<le> t"
+      by simp
+  qed
+  ultimately have "?Q (rv t)"
+    by simp
+
+  let ?P = "\<lambda>i. i < Suc t \<and> ns ! i = ns ! idx"
+  have "rv (Suc t) = Greatest ?P"
+    using True rv_def by simp
+  moreover have "Greatest ?P = rv t"
+  proof (rule Greatest_equality)
+    show "rv t < Suc t \<and> ns ! rv t = ns ! idx"
+      using `?Q (rv t)` by simp
+    show "y \<le> rv t" if "y < Suc t \<and> ns ! y = ns ! idx" for y
+    proof -
+      have "?Q y"
+        using True assms(3) less_antisym that by blast
+      moreover have "\<forall>y. ?Q y \<longrightarrow> y \<le> t"
+        by simp
+      ultimately have "y \<le> Greatest ?Q"
+        using Greatest_le_nat[of ?Q] by blast
+      then show ?thesis
+        using rvt by simp
+    qed
+  qed
+  ultimately show ?thesis
+    by simp
+next
+  case False
+  then show ?thesis
+    using rv_def by auto
+qed
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+     j2 + 5 := (\<lfloor>rv t\<rfloor>\<^sub>N, 1)]"
+
+lemma tpsL_eq_tps2: "tpsL 0 = tps2"
+  using tpsL_def tps2_def tps0 jk rv_0
+  by (metis add_eq_self_zero add_left_imp_eq gr_implies_not0 less_numeral_extra(1)
+    list_update_id list_update_swap one_add_one)
+
+definition tpsC :: "nat \<Rightarrow> tape list" where
+  "tpsC t \<equiv> tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+     j2 + 4 := (\<lfloor>t = idx\<rfloor>\<^sub>B, 1),
+     j2 + 5 := (\<lfloor>rv t\<rfloor>\<^sub>N, 1)]"
+
+lemma tmC:
+  assumes "ttt = 3 * nlength (min t idx) + 7"
+  shows "transforms tmC (tpsL t) ttt (tpsC t)"
+  unfolding tmC_def by (tform tps: jk idx tps0 tpsL_def tpsC_def time: assms)
+
+lemma tmC' [transforms_intros]:
+  assumes "ttt = 3 * nllength ns ^ 2 + 7" and "t \<le> idx"
+  shows "transforms tmC (tpsL t) ttt (tpsC t)"
+proof -
+  have "nlength (min t idx) \<le> nllength ns"
+    using idx assms(2) by (metis le_trans length_le_nllength less_or_eq_imp_le min_absorb1 nlength_le_n)
+  then have "nlength (min t idx) \<le> nllength ns ^ 2"
+    by (metis le_square min.absorb2 min.coboundedI1 power2_eq_square)
+  then have "3 * nlength (min t idx) + 7 \<le> 3 * nllength ns ^ 2 + 7"
+    by simp
+  then show ?thesis
+    using tmC assms(1) transforms_monotone by blast
+qed
+
+lemma condition_tpsC: "(read (tpsC t)) ! (j2 + 4) \<noteq> \<box> \<longleftrightarrow> t = idx"
+  using tpsC_def read_ncontents_eq_0 jk by simp
+
+definition "tpsB1 t \<equiv> tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+     j2 + 3 := (\<lfloor>ns ! t\<rfloor>\<^sub>N, 1),
+     j2 + 4 := (\<lfloor>t = idx\<rfloor>\<^sub>B, 1),
+     j2 + 5 := (\<lfloor>rv t\<rfloor>\<^sub>N, 1)]"
+
+lemma tmB1 [transforms_intros]:
+  assumes "ttt = 21 * (nllength ns)\<^sup>2 + 26" and "t < idx"
+  shows "transforms tmB1 (tpsC t) ttt (tpsB1 t)"
+  unfolding tmB1_def by (tform tps: jk idx tps0 tpsC_def tpsB1_def time: assms idx)
+
+definition "tpsB2 t \<equiv> tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+     j2 + 3 := (\<lfloor>ns ! t\<rfloor>\<^sub>N, 1),
+     j2 + 4 := (\<lfloor>ns ! idx = ns ! t\<rfloor>\<^sub>B, 1),
+     j2 + 5 := (\<lfloor>rv t\<rfloor>\<^sub>N, 1)]"
+
+lemma tmB2:
+  assumes "ttt = 21 * (nllength ns)\<^sup>2 + 26 + (3 * nlength (min (ns ! idx) (ns ! t)) + 7)"
+    and "t < idx"
+  shows "transforms tmB2 (tpsC t) ttt (tpsB2 t)"
+  unfolding tmB2_def
+proof (tform tps: tpsB1_def jk assms(2) time: assms(1))
+  show "tpsB2 t = (tpsB1 t)[j2 + 4 := (\<lfloor>ns ! idx = ns ! t\<rfloor>\<^sub>B, 1)]"
+    unfolding tpsB2_def tpsB1_def by (simp add: list_update_swap[of "j2 + 4"])
+qed
+
+lemma tmB2' [transforms_intros]:
+  assumes "ttt = 24 * (nllength ns)\<^sup>2 + 33" and "t < idx"
+  shows "transforms tmB2 (tpsC t) ttt (tpsB2 t)"
+proof -
+  let ?ttt = "21 * (nllength ns)\<^sup>2 + 26 + (3 * nlength (min (ns ! idx) (ns ! t)) + 7)"
+  have "?ttt = 21 * (nllength ns)\<^sup>2 + 33 + 3 * nlength (min (ns ! idx) (ns ! t))"
+    by simp
+  also have "... \<le> 21 * (nllength ns)\<^sup>2 + 33 + 3 * nllength ns"
+    using nlength_min_le_nllength idx assms(2) by simp
+  also have "... \<le> 21 * (nllength ns)\<^sup>2 + 33 + 3 * nllength ns ^ 2"
+    by (simp add: power2_eq_square)
+  also have "... = 24 * (nllength ns)\<^sup>2 + 33"
+    by simp
+  finally have "?ttt \<le> 24 * (nllength ns)\<^sup>2 + 33" .
+  then show ?thesis
+    using assms tmB2 transforms_monotone by blast
+qed
+
+definition "tpsB3 t \<equiv> tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+     j2 + 4 := (\<lfloor>ns ! idx = ns ! t\<rfloor>\<^sub>B, 1),
+     j2 + 5 := (\<lfloor>rv t\<rfloor>\<^sub>N, 1)]"
+
+lemma condition_tpsB3: "(read (tpsB3 t)) ! (j2 + 4) \<noteq> \<box> \<longleftrightarrow> ns ! idx = ns ! t"
+  using tpsB3_def read_ncontents_eq_0 jk by simp
+
+lemma tmB3 [transforms_intros]:
+  assumes "ttt = 24 * (nllength ns)\<^sup>2 + 33 + (10 + 2 * nlength (ns ! t))" and "t < idx"
+  shows "transforms tmB3 (tpsC t) ttt (tpsB3 t)"
+  unfolding tmB3_def
+proof (tform tps: assms(2) tpsB2_def jk time: assms(1))
+  show "tpsB3 t = (tpsB2 t)[j2 + 3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using tpsB2_def tpsB3_def tps0 by simp
+    show "?l ! j = ?r ! j" if "j < length ?l" for j
+    proof -
+      consider "j = j1" | "j = j2" | "j = j2 + 1" | "j = j2 + 2" | "j = j2 + 3" | "j = j2 + 4" | "j = j2 + 5"
+        | "j \<noteq> j1 \<and> j \<noteq> j2 \<and> j \<noteq> j2 + 1 \<and> j \<noteq> j2 + 2 \<and> j \<noteq> j2 + 3 \<and> j \<noteq> j2 + 4 \<and> j \<noteq> j2 + 5"
+        by auto
+      then show ?thesis
+        using tpsB2_def tpsB3_def tps0 jk
+        by (cases, simp_all only: nth_list_update_eq nth_list_update_neq length_list_update, metis nth_list_update_neq)
+    qed
+  qed
+qed
+
+definition "tpsI0 t \<equiv> tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+     j2 + 4 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+     j2 + 5 := (\<lfloor>rv t\<rfloor>\<^sub>N, 1)]"
+
+definition "tpsI1 t \<equiv> tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+     j2 + 5 := (\<lfloor>rv t\<rfloor>\<^sub>N, 1)]"
+
+lemma tmI1 [transforms_intros]:
+  assumes "t < idx" and "ns ! idx = ns ! t"
+  shows "transforms tmI1 (tpsB3 t) 12 (tpsI1 t)"
+  unfolding tmI1_def
+proof (tform tps: tpsB3_def jk assms(2) time: assms nlength_1_simp)
+  show "tpsI1 t = (tpsB3 t)[j2 + 4 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using tpsB3_def tpsI1_def tps0 jk by simp
+    show "?l ! j = ?r ! j" if "j < length ?l" for j
+    proof -
+      consider "j = j1" | "j = j2" | "j = j2 + 1" | "j = j2 + 2" | "j = j2 + 3" | "j = j2 + 4" | "j = j2 + 5"
+        | "j \<noteq> j1 \<and> j \<noteq> j2 \<and> j \<noteq> j2 + 1 \<and> j \<noteq> j2 + 2 \<and> j \<noteq> j2 + 3 \<and> j \<noteq> j2 + 4 \<and> j \<noteq> j2 + 5"
+        by auto
+      then show ?thesis
+        using tpsB3_def tpsI1_def tps0 jk
+        by (cases, simp_all only: nth_list_update_eq nth_list_update_neq length_list_update, metis nth_list_update_neq)
+    qed
+  qed
+qed
+
+definition "tpsI2 t \<equiv> tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+     j2 + 5 := (\<lfloor>t\<rfloor>\<^sub>N, 1)]"
+
+lemma tmI2 [transforms_intros]:
+  assumes "ttt = 26 + 3 * nlength t + 3 * nlength (rv t)"
+    and "t < idx"
+    and "ns ! idx = ns ! t"
+  shows "transforms tmI2 (tpsB3 t) ttt (tpsI2 t)"
+  unfolding tmI2_def
+proof (tform tps: assms(2,3) tpsI1_def jk time: assms(1))
+  show "tpsI2 t = (tpsI1 t)[j2 + 5 := (\<lfloor>t\<rfloor>\<^sub>N, 1)]"
+    (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using tpsI1_def tpsI2_def tps0 by simp
+    show "?l ! j = ?r ! j" if "j < length ?l" for j
+    proof -
+      consider "j = j1" | "j = j2" | "j = j2 + 1" | "j = j2 + 2" | "j = j2 + 3" | "j = j2 + 4" | "j = j2 + 5"
+        | "j \<noteq> j1 \<and> j \<noteq> j2 \<and> j \<noteq> j2 + 1 \<and> j \<noteq> j2 + 2 \<and> j \<noteq> j2 + 3 \<and> j \<noteq> j2 + 4 \<and> j \<noteq> j2 + 5"
+        by auto
+      then show ?thesis
+        using tpsI1_def tpsI2_def tps0 jk assms(2,3)
+        by (cases, simp_all only: One_nat_def nth_list_update_eq nth_list_update_neq length_list_update list_update_overwrite)
+    qed
+  qed
+qed
+
+definition "tpsI t \<equiv> tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+     j2 + 5 := (\<lfloor>rv (Suc t)\<rfloor>\<^sub>N, 1)]"
+
+lemma tmI [transforms_intros]:
+  assumes "ttt = 28 + 6 * nllength ns" and "t < idx"
+  shows "transforms tmI (tpsB3 t) ttt (tpsI t)"
+  unfolding tmI_def
+proof (tform tps: assms)
+  let ?tT = "26 + 3 * nlength t + 3 * nlength (rv t)"
+  have *: "(ns ! idx = ns ! t) = (read (tpsB3 t) ! (j2 + 4) \<noteq> \<box>)"
+    using condition_tpsB3 by simp
+  then show "read (tpsB3 t) ! (j2 + 4) \<noteq> \<box> \<Longrightarrow> ns ! idx = ns ! t"
+    by simp
+  have "ns ! idx = ns ! t \<Longrightarrow> rv (Suc t) = t"
+    using rv_change idx assms(2) by simp
+  then show "read (tpsB3 t) ! (j2 + 4) \<noteq> \<box> \<Longrightarrow> tpsI t = tpsI2 t"
+    using tpsI_def tpsI2_def * by simp
+
+  have "ns ! idx \<noteq> ns ! t \<Longrightarrow> rv (Suc t) = rv t"
+    using rv_keep idx assms(2) by simp
+  then have "ns ! idx \<noteq> ns ! t \<Longrightarrow> tpsI t = tpsB3 t"
+    using tpsI_def tpsB3_def tps0 jk
+    by (smt (verit, ccfv_SIG) add_left_imp_eq list_update_id list_update_swap numeral_eq_iff
+      one_eq_numeral_iff semiring_norm(83) semiring_norm(87))
+  then show "\<not> read (tpsB3 t) ! (j2 + 4) \<noteq> \<box> \<Longrightarrow> tpsI t = tpsB3 t"
+    using * by simp
+  show "26 + 3 * nlength t + 3 * nlength (rv t) + 2 \<le> ttt"
+  proof -
+    have "26 + 3 * nlength t + 3 * nlength (rv t) + 2 = 28 + 3 * nlength t + 3 * nlength (rv t)"
+      by simp
+    also have "... \<le> 28 + 3 * nlength idx + 3 * nlength (rv t)"
+      using assms(2) nlength_mono by simp
+    also have "... \<le> 28 + 3 * nlength idx + 3 * nlength idx"
+    proof -
+      have "rv t \<le> idx"
+        using assms(2) rv_le by (metis less_or_eq_imp_le max_absorb2)
+      then show ?thesis
+        using nlength_mono by simp
+    qed
+    also have "... = 28 + 6 * nlength idx"
+      by simp
+    also have "... \<le> 28 + 6 * nllength ns"
+    proof -
+      have "nlength idx \<le> nlength (length ns)"
+        using idx nlength_mono by simp
+      then have "nlength idx \<le> length ns"
+        using nlength_le_n by (meson le_trans)
+      then have "nlength idx \<le> nllength ns"
+        using length_le_nllength le_trans by blast
+      then show ?thesis
+        by simp
+    qed
+    finally show ?thesis
+      using assms(1) by simp
+  qed
+qed
+
+lemma tmB4:
+  assumes "ttt = 71 + 24 * (nllength ns)\<^sup>2 + 2 * nlength (ns ! t) + 6 * nllength ns"
+    and "t < idx"
+  shows "transforms tmB4 (tpsC t) ttt (tpsI t)"
+  unfolding tmB4_def by (tform tps: assms(2) jk time: assms(1))
+
+lemma tmB4' [transforms_intros]:
+  assumes "ttt = 71 + 32 * (nllength ns)\<^sup>2" and "t < idx"
+  shows "transforms tmB4 (tpsC t) ttt (tpsI t)"
+proof -
+  let ?ttt = "71 + 24 * (nllength ns)\<^sup>2 + 2 * nlength (ns ! t) + 6 * nllength ns"
+  have "?ttt \<le> 71 + 24 * (nllength ns)\<^sup>2 + 2 * nlength (ns ! t) + 6 * nllength ns ^ 2"
+    by (metis add_mono_thms_linordered_semiring(2) le_square mult.commute mult_le_mono1 power2_eq_square)
+  also have "... = 71 + 30 * (nllength ns)\<^sup>2 + 2 * nlength (ns ! t)"
+    by simp
+  also have "... \<le> 71 + 30 * (nllength ns)\<^sup>2 + 2 * nllength ns"
+    using member_le_nllength assms(2) idx by simp
+  also have "... \<le> 71 + 30 * (nllength ns)\<^sup>2 + 2 * nllength ns ^ 2"
+    by (simp add: power2_eq_square)
+  also have "... = 71 + 32 * (nllength ns)\<^sup>2"
+    by simp
+  finally have "?ttt \<le> 71 + 32 * (nllength ns)\<^sup>2" .
+  then show ?thesis
+    using assms tmB4 transforms_monotone by blast
+qed
+
+definition "tpsB5 t \<equiv> tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1),
+     j2 + 5 := (\<lfloor>rv (Suc t)\<rfloor>\<^sub>N, 1)]"
+
+lemma tmB5:
+  assumes "ttt = 76 + 32 * (nllength ns)\<^sup>2 + 2 * nlength t" and "t < idx"
+  shows "transforms tmB5 (tpsC t) ttt (tpsB5 t)"
+  unfolding tmB5_def
+proof (tform tps: assms(2) tpsI_def jk time: assms(1))
+  show "tpsB5 t = (tpsI t)[j2 + 2 := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1)]"
+    using tpsB5_def tpsI_def
+    by (smt (z3) add_left_imp_eq list_update_overwrite list_update_swap numeral_eq_iff semiring_norm(89))
+qed
+
+lemma tmB5' [transforms_intros]:
+  assumes "ttt = 76 + 34 * (nllength ns)\<^sup>2" and "t < idx"
+  shows "transforms tmB5 (tpsC t) ttt (tpsL (Suc t))"
+proof -
+  have "76 + 32 * (nllength ns)\<^sup>2 + 2 * nlength t \<le> 76 + 32 * (nllength ns)\<^sup>2 + 2 * nllength ns"
+    using assms(2) idx length_le_nllength nlength_le_n
+    by (meson add_mono_thms_linordered_semiring(2) le_trans less_or_eq_imp_le mult_le_mono2)
+  also have "... \<le> 76 + 32 * (nllength ns)\<^sup>2 + 2 * nllength ns ^ 2"
+    by (simp add: power2_eq_square)
+  also have "... \<le> 76 + 34 * (nllength ns)\<^sup>2"
+    by simp
+  finally have "76 + 32 * (nllength ns)\<^sup>2 + 2 * nlength t \<le> 76 + 34 * (nllength ns)\<^sup>2" .
+  moreover have "tpsL (Suc t) = tpsB5 t"
+    using tpsL_def tpsB5_def by simp
+  ultimately show ?thesis
+    using assms tmB5 transforms_monotone by fastforce
+qed
+
+lemma tmL [transforms_intros]:
+  assumes "ttt = 125 * nllength ns ^ 3 + 8" and "iidx = idx"
+  shows "transforms tmL (tpsL 0) ttt (tpsC iidx)"
+  unfolding tmL_def
+proof (tform tps: assms)
+  let ?tC = "3 * nllength ns ^ 2 + 7"
+  let ?tB5 = "76 + 34 * (nllength ns)\<^sup>2"
+  show "\<And>t. t < iidx \<Longrightarrow> read (tpsC t) ! (j2 + 4) = \<box>"
+    using condition_tpsC assms(2) by fast
+  show "read (tpsC iidx) ! (j2 + 4) \<noteq> \<box>"
+    using condition_tpsC assms(2) by simp
+  have "iidx * (?tC + ?tB5 + 2) + ?tC + 1 = iidx * (37 * (nllength ns)\<^sup>2 + 85) + 3 * (nllength ns)\<^sup>2 + 8"
+    by simp
+  also have "... \<le> length ns * (37 * (nllength ns)\<^sup>2 + 85) + 3 * (nllength ns)\<^sup>2 + 8"
+    using assms(2) idx by simp
+  also have "... \<le> nllength ns * (37 * (nllength ns)\<^sup>2 + 85) + 3 * (nllength ns)\<^sup>2 + 8"
+    using length_le_nllength by simp
+  also have "... = 37 * nllength ns ^ 3 + 85 * nllength ns + 3 * (nllength ns)\<^sup>2 + 8"
+    by algebra
+  also have "... \<le> 37 * nllength ns ^ 3 + 85 * nllength ns + 3 * nllength ns ^ 3 + 8"
+  proof -
+    have "nllength ns ^ 2 \<le> nllength ns ^ 3"
+      by (metis Suc_eq_plus1 add.commute eq_refl le_add2 neq0_conv numeral_3_eq_3 numerals(2)
+        pow_mono power_eq_0_iff zero_less_Suc)
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<le> 37 * nllength ns ^ 3 + 85 * nllength ns ^ 3 + 3 * nllength ns ^ 3 + 8"
+    by (simp add: power3_eq_cube)
+  also have "... = 125 * nllength ns ^ 3 + 8"
+    by simp
+  finally have "iidx * (?tC + ?tB5 + 2) + ?tC + 1 \<le> 125 * nllength ns ^ 3 + 8" .
+  then show "iidx * (?tC + ?tB5 + 2) + ?tC + 1 \<le> ttt"
+    using assms(1) by simp
+qed
+
+lemma tm2' [transforms_intros]:
+  assumes "ttt = 14 + 3 * nlength idx + (21 * (nllength ns)\<^sup>2 + 26)"
+  shows "transforms tm2 tps0 ttt (tpsL 0)"
+  using tm2 assms tpsL_eq_tps2 by simp
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 40 + (3 * nlength idx + 21 * (nllength ns)\<^sup>2) + (125 * nllength ns ^ 3 + 8)"
+  shows "transforms tm3 tps0 ttt (tpsC idx)"
+  unfolding tm3_def by (tform tps: assms jk)
+
+lemma tpsC_idx:
+  "tpsC idx = tps0
+    [j2 + 1 := (\<lfloor>ns ! idx\<rfloor>\<^sub>N, 1),
+     j2 + 2 := (\<lfloor>idx\<rfloor>\<^sub>N, 1),
+     j2 + 4 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+     j2 + 5 := (\<lfloor>if \<exists>i<idx. ns ! i = ns ! idx then GREATEST i. i < idx \<and> ns ! i = ns ! idx else idx\<rfloor>\<^sub>N, 1)]"
+  using tpsC_def rv_def by simp
+
+definition tps4 :: "tape list" where
+  "tps4 \<equiv> tps0
+    [j2 + 1 := (\<lfloor>[]\<rfloor>, 1),
+     j2 + 2 := (\<lfloor>idx\<rfloor>\<^sub>N, 1),
+     j2 + 4 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+     j2 + 5 := (\<lfloor>if \<exists>i<idx. ns ! i = ns ! idx then GREATEST i. i < idx \<and> ns ! i = ns ! idx else idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 55 + 3 * nlength idx + 21 * (nllength ns)\<^sup>2 + 125 * nllength ns ^ 3 + 2 * nlength (ns ! idx)"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: assms tpsC_def tps4_def jk)
+  show "proper_symbols (canrepr (ns ! idx))"
+    using proper_symbols_canrepr by simp
+  show "tps4 = (tpsC idx)[j2 + 1 := (\<lfloor>[]\<rfloor>, 1)]"
+    using tpsC_idx tps4_def by (simp add: list_update_swap[of "Suc j2"])
+qed
+
+definition tps5 :: "tape list" where
+  "tps5 \<equiv> tps0
+    [j2 + 1 := (\<lfloor>[]\<rfloor>, 1),
+     j2 + 2 := (\<lfloor>[]\<rfloor>, 1),
+     j2 + 4 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+     j2 + 5 := (\<lfloor>if \<exists>i<idx. ns ! i = ns ! idx then GREATEST i. i < idx \<and> ns ! i = ns ! idx else idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 62 + 5 * nlength idx + 21 * (nllength ns)\<^sup>2 + 125 * nllength ns ^ 3 + 2 * nlength (ns ! idx)"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def
+proof (tform tps: tps4_def tps5_def jk time: assms tps4_def jk)
+  show "proper_symbols (canrepr idx)"
+    using proper_symbols_canrepr by simp
+qed
+
+definition tps6 :: "tape list" where
+  "tps6 \<equiv> tps0
+    [j2 + 1 := (\<lfloor>[]\<rfloor>, 1),
+     j2 + 2 := (\<lfloor>[]\<rfloor>, 1),
+     j2 + 4 := (\<lfloor>[]\<rfloor>, 1),
+     j2 + 5 := (\<lfloor>if \<exists>i<idx. ns ! i = ns ! idx then GREATEST i. i < idx \<and> ns ! i = ns ! idx else idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm6:
+  assumes "ttt = 71 + 5 * nlength idx + 21 * (nllength ns)\<^sup>2 + 125 * nllength ns ^ 3 + 2 * nlength (ns ! idx)"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+proof (tform tps: tps5_def tps6_def jk time: assms tps5_def jk nlength_1_simp)
+  show "proper_symbols (canrepr (Suc 0))"
+    using proper_symbols_canrepr by simp
+qed
+
+definition tps6' :: "tape list" where
+  "tps6' \<equiv> tps0
+    [j2 + 5 := (\<lfloor>if \<exists>i<idx. ns ! i = ns ! idx then GREATEST i. i < idx \<and> ns ! i = ns ! idx else idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tps6'_eq_tps6: "tps6' = tps6"
+  using tps6'_def tps6_def tps0 jk canrepr_0 by (metis (no_types, lifting) list_update_id)
+
+lemma tm6':
+  assumes "ttt = 71 + 153 * nllength ns ^ 3"
+  shows "transforms tm6 tps0 ttt tps6'"
+proof -
+  let ?ttt = "71 + 5 * nlength idx + 21 * (nllength ns)\<^sup>2 + 125 * nllength ns ^ 3 + 2 * nlength (ns ! idx)"
+  have "?ttt \<le> 71 + 5 * nlength idx + 21 * (nllength ns)^3 + 125 * nllength ns ^ 3 + 2 * nlength (ns ! idx)"
+    using pow_mono[of 2 3 "nllength ns"] by fastforce
+  also have "... = 71 + 5 * nlength idx + 146 * nllength ns ^ 3 + 2 * nlength (ns ! idx)"
+    by simp
+  also have "... \<le> 71 + 5 * nllength ns + 146 * nllength ns ^ 3 + 2 * nlength (ns ! idx)"
+  proof -
+    have "nlength idx \<le> nllength ns"
+      using idx by (meson le_trans length_le_nllength nlength_le_n order.strict_implies_order)
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<le> 71 + 5 * nllength ns ^ 3 + 146 * nllength ns ^ 3 + 2 * nlength (ns ! idx)"
+    using linear_le_pow by simp
+  also have "... = 71 + 151 * nllength ns ^ 3 + 2 * nlength (ns ! idx)"
+    by simp
+  also have "... \<le> 71 + 151 * nllength ns ^ 3 + 2 * nllength ns"
+    using idx member_le_nllength by simp
+  also have "... \<le> 71 + 151 * nllength ns ^ 3 + 2 * nllength ns^3"
+    using linear_le_pow by simp
+  also have "... = 71 + 153 * nllength ns ^ 3"
+    by simp
+  finally have "?ttt \<le> ttt"
+    using assms by simp
+  then have "transforms tm6 tps0 ttt tps6"
+    using tm6 transforms_monotone by simp
+  then show ?thesis
+    using tps6'_eq_tps6 by simp
+qed
+
+end  (* context tps0 idx ns *)
+
+end  (* locale turing_machine_prev *)
+
+lemma transforms_tm_prevI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and k idx :: nat and ns :: "nat list"
+  assumes "0 < j1" "j1 < j2" "j2 + 6 \<le> k" "length tps = k"
+    and "idx < length ns"
+  assumes
+    "tps ! j1 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! j2 = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps ! (j2 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j2 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j2 + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j2 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j2 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 71 + 153 * nllength ns ^ 3"
+  assumes "tps' = tps
+    [j2 + 5 := (\<lfloor>previous ns idx\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_prev j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_prev j1 j2 .
+  show ?thesis
+    using assms loc.tm6_eq_tm_prev loc.tm6' loc.tps6'_def previous_def by simp
+qed
+
+
+subsection \<open>Checking containment in a list\<close>
+
+text \<open>
+A Turing machine that checks whether a number given on tape $j_2$ is contained
+in the list of numbers on tape $j_1$. If so, it writes a~1 to tape $j_3$, and
+otherwise leaves tape $j_3$ unchanged. So tape $j_3$ should be initialized
+with~0.
+\<close>
+
+definition tm_contains :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_contains j1 j2 j3 \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO
+      tm_nextract \<bar> j1 (j3 + 1) ;;
+      tm_equalsn j2 (j3 + 1) (j3 + 2) ;;
+      IF \<lambda>rs. rs ! (j3 + 2) \<noteq> \<box> THEN
+        tm_setn j3 1
+      ELSE
+        []
+      ENDIF ;;
+      tm_setn (j3 + 1) 0 ;;
+      tm_setn (j3 + 2) 0
+    DONE ;;
+    tm_cr j1"
+
+lemma tm_contains_tm:
+  assumes "0 < j1" "j1 \<noteq> j2" "j3 + 2 < k" "j1 < j3" "j2 < j3" and "k \<ge> 2" and "G \<ge> 5"
+  shows "turing_machine k G (tm_contains j1 j2 j3)"
+  unfolding tm_contains_def
+  using tm_nextract_tm tm_equalsn_tm Nil_tm tm_setn_tm tm_cr_tm assms
+    turing_machine_branch_turing_machine turing_machine_loop_turing_machine
+  by simp
+
+locale turing_machine_contains =
+  fixes j1 j2 j3 :: tapeidx
+begin
+
+definition "tmL1 \<equiv> tm_nextract \<bar> j1 (j3 + 1)"
+definition "tmL2 \<equiv> tmL1 ;; tm_equalsn j2 (j3 + 1) (j3 + 2)"
+definition "tmI \<equiv> IF \<lambda>rs. rs ! (j3 + 2) \<noteq> \<box> THEN tm_setn j3 1 ELSE [] ENDIF"
+definition "tmL3 \<equiv> tmL2 ;; tmI"
+definition "tmL4 \<equiv> tmL3 ;; tm_setn (j3 + 1) 0"
+definition "tmL5 \<equiv> tmL4 ;; tm_setn (j3 + 2) 0"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO tmL5 DONE"
+definition "tm2 \<equiv> tmL ;; tm_cr j1"
+
+lemma tm2_eq_tm_contains: "tm2 = tm_contains j1 j2 j3"
+  unfolding tm2_def tmL_def tmL5_def tmL4_def tmL3_def tmI_def tmL2_def tmL1_def tm_contains_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and ns :: "nat list" and needle :: nat
+  assumes jk: "0 < j1" "j1 \<noteq> j2" "j3 + 2 < k" "j1 < j3" "j2 < j3" "length tps0 = k"
+    and tps0:
+      "tps0 ! j1 = nltape' ns 0"
+      "tps0 ! j2 = (\<lfloor>needle\<rfloor>\<^sub>N, 1)"
+      "tps0 ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      "tps0 ! (j3 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      "tps0 ! (j3 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [j1 := nltape' ns t,
+     j3 := (\<lfloor>\<exists>i<t. ns ! i = needle\<rfloor>\<^sub>B, 1)]"
+
+lemma tpsL0: "tpsL 0 = tps0"
+  unfolding tpsL_def using tps0 by (smt (verit) list_update_id not_less_zero)
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+  "tpsL1 t \<equiv> tps0
+    [j1 := nltape' ns (Suc t),
+     j3 := (\<lfloor>\<exists>i<t. ns ! i = needle\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>ns ! t\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL1 [transforms_intros]:
+  assumes "ttt = 12 + 2 * nlength (ns ! t)" and "t < length ns"
+  shows "transforms tmL1 (tpsL t) ttt (tpsL1 t)"
+  unfolding tmL1_def
+proof (tform tps: assms(2) tpsL_def tpsL1_def jk tps0)
+  show "ttt = 12 + 2 * nlength 0 + 2 * nlength (ns ! t)"
+    using assms(1) by simp
+  show "tpsL1 t = (tpsL t)
+    [j1 := nltape' ns (Suc t),
+     j3 + 1 := (\<lfloor>ns ! t\<rfloor>\<^sub>N, 1)]"
+    unfolding tpsL1_def tpsL_def using jk by (simp add: list_update_swap)
+qed
+
+definition tpsL2 :: "nat \<Rightarrow> tape list" where
+  "tpsL2 t \<equiv> tps0
+    [j1 := nltape' ns (Suc t),
+     j3 := (\<lfloor>\<exists>i<t. ns ! i = needle\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>ns ! t\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>needle = ns ! t\<rfloor>\<^sub>B, 1)]"
+
+lemma tmL2 [transforms_intros]:
+  assumes "ttt = 12 + 2 * nlength (ns ! t) + (3 * nlength (min needle (ns ! t)) + 7)"
+    and "t < length ns"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL2 t)"
+  unfolding tmL2_def by (tform tps: assms tps0 tpsL1_def tpsL2_def jk)
+
+definition tpsI :: "nat \<Rightarrow> tape list" where
+  "tpsI t \<equiv> tps0
+    [j1 := nltape' ns (Suc t),
+     j3 := (\<lfloor>\<exists>i<Suc t. ns ! i = needle\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>ns ! t\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>needle = ns ! t\<rfloor>\<^sub>B, 1)]"
+
+lemma tmI [transforms_intros]:
+  assumes "ttt = 16" and "t < length ns"
+  shows "transforms tmI (tpsL2 t) ttt (tpsI t)"
+  unfolding tmI_def
+proof (tform tps: tpsL2_def jk)
+  show "10 + 2 * nlength (if \<exists>i<t. ns ! i = needle then 1 else 0) + 2 * nlength 1 + 2 \<le> ttt"
+    using assms(1) nlength_1_simp nlength_0 by simp
+  show "0 + 1 \<le> ttt"
+    using assms(1) by simp
+
+  have "tpsL2 t ! (j3 + 2) = (\<lfloor>needle = ns ! t\<rfloor>\<^sub>B, 1)"
+    using tpsL2_def jk by simp
+  then have *: "(read (tpsL2 t) ! (j3 + 2) = \<box>) = (needle \<noteq> ns ! t)"
+    using jk read_ncontents_eq_0[of "tpsL2 t" "j3 + 2"] tpsL2_def by simp
+
+  show "tpsI t = (tpsL2 t)[j3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]" if "read (tpsL2 t) ! (j3 + 2) \<noteq> \<box>"
+  proof -
+    have "needle = ns ! t"
+      using * that by simp
+    then have "\<exists>i<Suc t. ns ! i = needle"
+      using assms(2) by auto
+    then show ?thesis
+      unfolding tpsI_def tpsL2_def using jk by (simp add: list_update_swap)
+  qed
+  show "tpsI t = tpsL2 t" if "\<not> read (tpsL2 t) ! (j3 + 2) \<noteq> \<box>"
+  proof -
+    have "needle \<noteq> ns ! t"
+      using * that by simp
+    then have "(\<exists>i<Suc t. ns ! i = needle) = (\<exists>i< t. ns ! i = needle)"
+      using assms(2) less_Suc_eq by auto
+    then show ?thesis
+      unfolding tpsI_def tpsL2_def by simp
+  qed
+qed
+
+lemma tmL3 [transforms_intros]:
+  assumes "ttt = 28 + 2 * nlength (ns ! t) + (3 * nlength (min needle (ns ! t)) + 7)"
+    and "t < length ns"
+  shows "transforms tmL3 (tpsL t) ttt (tpsI t)"
+  unfolding tmL3_def by (tform tps: assms)
+definition tpsL4 :: "nat \<Rightarrow> tape list" where
+  "tpsL4 t \<equiv> tps0
+    [j1 := nltape' ns (Suc t),
+     j3 := (\<lfloor>\<exists>i<Suc t. ns ! i = needle\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>needle = ns ! t\<rfloor>\<^sub>B, 1)]"
+
+lemma tmL4 [transforms_intros]:
+  assumes "ttt = 38 + 4 * nlength (ns ! t) + (3 * nlength (min needle (ns ! t)) + 7)"
+    and "t < length ns"
+  shows "transforms tmL4 (tpsL t) ttt (tpsL4 t)"
+  unfolding tmL4_def
+proof (tform tps: assms tpsI_def jk)
+  show "tpsL4 t = (tpsI t)[j3 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    unfolding tpsL4_def tpsI_def by (simp add: list_update_swap)
+qed
+
+definition tpsL5 :: "nat \<Rightarrow> tape list" where
+  "tpsL5 t \<equiv> tps0
+    [j1 := nltape' ns (Suc t),
+     j3 := (\<lfloor>\<exists>i<Suc t. ns ! i = needle\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL5:
+  assumes "ttt = 48 + 4 * nlength (ns ! t) + (3 * nlength (min needle (ns ! t)) + 7) +
+      2 * nlength (if needle = ns ! t then 1 else 0)"
+    and "t < length ns"
+  shows "transforms tmL5 (tpsL t) ttt (tpsL5 t)"
+  unfolding tmL5_def
+proof (tform tps: assms tpsL4_def jk)
+  show "tpsL5 t = (tpsL4 t)[j3 + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    unfolding tpsL5_def tpsL4_def by (simp add: list_update_swap)
+qed
+
+definition tpsL5' :: "nat \<Rightarrow> tape list" where
+  "tpsL5' t \<equiv> tps0
+    [j1 := nltape' ns (Suc t),
+     j3 := (\<lfloor>\<exists>i<Suc t. ns ! i = needle\<rfloor>\<^sub>B, 1)]"
+
+lemma tpsL5': "tpsL5' t = tpsL5 t"
+  using tpsL5'_def tpsL5_def tps0 jk
+  by (smt (verit, del_insts) One_nat_def less_Suc_eq less_add_same_cancel1 list_update_swap not_less_eq tape_list_eq zero_less_numeral)
+
+lemma tmL5':
+  assumes "ttt = 57 + 4 * nlength (ns ! t) + 3 * nlength (min needle (ns ! t))"
+    and "t < length ns"
+  shows "transforms tmL5 (tpsL t) ttt (tpsL5' t)"
+proof -
+  have "nlength (if needle = ns ! t then 1 else 0) \<le> 1"
+    using nlength_1_simp by simp
+  then have "48 + 4 * nlength (ns ! t) + (3 * nlength (min needle (ns ! t)) + 7) +
+      2 * nlength (if needle = ns ! t then 1 else 0) \<le> ttt"
+    using assms(1) by simp
+  then show ?thesis
+    using tpsL5' tmL5 transforms_monotone assms(2) by fastforce
+qed
+
+lemma tmL5'' [transforms_intros]:
+  assumes "ttt = 57 + 7 * nllength ns" and "t < length ns"
+  shows "transforms tmL5 (tpsL t) ttt (tpsL (Suc t))"
+proof -
+  have "nlength (ns ! t) \<le> nllength ns"
+    using assms(2) by (simp add: member_le_nllength)
+  moreover from this have "nlength (min needle (ns ! t)) \<le> nllength ns"
+    using nlength_mono by (metis dual_order.trans min_def)
+  ultimately have "ttt \<ge> 57 + 4 * nlength (ns ! t) + 3 * nlength (min needle (ns ! t))"
+    using assms(1) by simp
+  moreover have "tpsL5' t = tpsL (Suc t)"
+    using tpsL5'_def tpsL_def by simp
+  ultimately show ?thesis
+    using tmL5' assms(2) transforms_monotone by fastforce
+qed
+
+lemma tmL [transforms_intros]:
+  assumes "ttt = length ns * (59 + 7 * nllength ns) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (length ns))"
+  unfolding tmL_def
+proof (tform)
+  let ?t = "57 + 7 * nllength ns"
+  show "length ns * (57 + 7 * nllength ns + 2) + 1 \<le> ttt"
+    using assms by simp
+  have *: "tpsL t ! j1 = nltape' ns t" for t
+    using tpsL_def jk by simp
+  moreover have "read (tpsL t) ! j1 = tpsL t :.: j1" for t
+    using tapes_at_read'[of j1 "tpsL t"] tpsL_def jk by simp
+  ultimately have "read (tpsL t) ! j1 = |.| (nltape' ns t)" for t
+    by simp
+  then have "read (tpsL t) ! j1 = \<box> \<longleftrightarrow> (t \<ge> length ns)" for t
+    using nltape'_tape_read by simp
+  then show
+      "\<And>i. i < length ns \<Longrightarrow> read (tpsL i) ! j1 \<noteq> \<box>"
+      "\<not> read (tpsL (length ns)) ! j1 \<noteq> \<box>"
+    using * by simp_all
+qed
+
+definition tps2 :: "tape list" where
+  "tps2 \<equiv> tps0
+    [j1 := nltape' ns 0,
+     j3 := (\<lfloor>\<exists>i<length ns. ns ! i = needle\<rfloor>\<^sub>B, 1)]"
+
+lemma tm2:
+  assumes "ttt = length ns * (59 + 7 * nllength ns) + nllength ns + 4"
+  shows "transforms tm2 (tpsL 0) ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tpsL_def jk)
+  show "clean_tape (tpsL (length ns) ! j1)"
+    using tpsL_def jk clean_tape_nlcontents by simp
+  have "tpsL (length ns) ! j1 |#=| 1 = nltape' ns 0"
+    using tpsL_def jk by simp
+  then have "(tpsL (length ns))[j1 := tpsL (length ns) ! j1 |#=| 1] = (tpsL (length ns))[j1 := nltape' ns 0]"
+    by simp
+  then show "tps2 = (tpsL (length ns))[j1 := tpsL (length ns) ! j1 |#=| 1]"
+    unfolding tps2_def tpsL_def using jk by (simp add: list_update_swap)
+  have "tpsL (length ns) :#: j1 = Suc (nllength ns)"
+    using tpsL_def jk by simp
+  then show "ttt = length ns * (59 + 7 * nllength ns) + 1 +
+      (tpsL (length ns) :#: j1 + 2)"
+    using assms by simp
+qed
+
+definition tps2' :: "tape list" where
+  "tps2' \<equiv> tps0
+    [j3 := (\<lfloor>needle \<in> set ns\<rfloor>\<^sub>B, 1)]"
+
+lemma tm2':
+  assumes "ttt = 67 * nllength ns ^ 2 + 4"
+  shows "transforms tm2 tps0 ttt tps2'"
+proof -
+  let ?t = "length ns * (59 + 7 * nllength ns) + nllength ns + 4"
+  have "?t \<le> nllength ns * (59 + 7 * nllength ns) + nllength ns + 4"
+    by (simp add: length_le_nllength)
+  also have "... = 60 * nllength ns + 7 * nllength ns ^ 2 + 4"
+    by algebra
+  also have "... \<le> 60 * nllength ns ^ 2 + 7 * nllength ns ^ 2 + 4"
+    using linear_le_pow by simp
+  also have "... = 67 * nllength ns ^ 2 + 4"
+    by simp
+  finally have "?t \<le> 67 * nllength ns ^ 2 + 4" .
+  moreover have "tps2' = tps2"
+    unfolding tps2_def tps2'_def using tps0(1) by (smt (verit) in_set_conv_nth list_update_id)
+  ultimately show ?thesis
+    using tm2 assms transforms_monotone tpsL0 by simp
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_containsI [transforms_intros]:
+  fixes j1 j2 j3 :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k needle :: nat and ns :: "nat list"
+  assumes "0 < j1" "j1 \<noteq> j2" "j3 + 2 < k" "j1 < j3" "j2 < j3" "length tps = k"
+  assumes
+    "tps ! j1 = nltape' ns 0"
+    "tps ! j2 = (\<lfloor>needle\<rfloor>\<^sub>N, 1)"
+    "tps ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 67 * nllength ns ^ 2 + 4"
+  assumes "tps' = tps
+    [j3 := (\<lfloor>needle \<in> set ns\<rfloor>\<^sub>B, 1)]"
+  shows "transforms (tm_contains j1 j2 j3) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_contains j1 j2 j3 .
+  show ?thesis
+    using assms loc.tm2_eq_tm_contains loc.tps2'_def loc.tm2' by simp
+qed
+
+
+subsection \<open>Creating lists of consecutive numbers\<close>
+
+text \<open>
+The next TM accepts a number $start$ on tape $j_1$ and a number $delta$ on tape
+$j_2$. It outputs the list $[start, \dots, start + delta - 1]$ on tape $j_3$.
+\<close>
+
+definition tm_range :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_range j1 j2 j3 \<equiv>
+    tm_copyn j1 (j3 + 2) ;;
+    tm_copyn j2 (j3 + 1) ;;
+    WHILE [] ; \<lambda>rs. rs ! (j3 + 1) \<noteq> \<box> DO
+      tm_append j3 (j3 + 2) ;;
+      tm_incr (j3 + 2) ;;
+      tm_decr (j3 + 1)
+    DONE ;;
+    tm_setn (j3 + 2) 0 ;;
+    tm_cr j3"
+
+lemma tm_range_tm:
+  assumes "k \<ge> j3 + 3" and "G \<ge> 5" and "j1 \<noteq> j2" and "0 < j1" and "0 < j2" and "j1 < j3" and "j2 < j3"
+  shows "turing_machine k G (tm_range j1 j2 j3)"
+  unfolding tm_range_def
+  using assms tm_copyn_tm tm_decr_tm tm_append_tm tm_setn_tm tm_incr_tm Nil_tm tm_cr_tm
+    turing_machine_loop_turing_machine
+  by simp
+
+locale turing_machine_range =
+  fixes j1 j2 j3 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_copyn j1 (j3 + 2)"
+definition "tm2 \<equiv> tm1 ;; tm_copyn j2 (j3 + 1)"
+definition "tmB1 \<equiv> tm_append j3 (j3 + 2)"
+definition "tmB2 \<equiv> tmB1 ;; tm_incr (j3 + 2)"
+definition "tmB3 \<equiv> tmB2 ;; tm_decr (j3 + 1)"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! (j3 + 1) \<noteq> \<box> DO tmB3 DONE"
+definition "tm3 \<equiv> tm2 ;; tmL"
+definition "tm4 \<equiv> tm3 ;; tm_setn (j3 + 2) 0"
+definition "tm5 \<equiv> tm4 ;; tm_cr j3"
+
+lemma tm5_eq_tm_range: "tm5 = tm_range j1 j2 j3"
+  unfolding tm_range_def tm5_def tm4_def tm3_def tmL_def tmB3_def tmB2_def tmB1_def tm2_def tm1_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k start delta :: nat
+  assumes jk: "k \<ge> j3 + 3" "j1 \<noteq> j2" "0 < j1" "0 < j2" "0 < j3" "j1 < j3" "j2 < j3" "length tps0 = k"
+    and tps0:
+      "tps0 ! j1 = (\<lfloor>start\<rfloor>\<^sub>N, 1)"
+      "tps0 ! j2 = (\<lfloor>delta\<rfloor>\<^sub>N, 1)"
+      "tps0 ! j3 = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+      "tps0 ! (j3 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      "tps0 ! (j3 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j3 + 2 := (\<lfloor>start\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 14 + 3 * nlength start"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+  by (tform tps: nlength_0 assms tps0 tps1_def jk)
+
+definition "tps2 \<equiv> tps0
+  [j3 + 2 := (\<lfloor>start\<rfloor>\<^sub>N, 1),
+   j3 + 1 := (\<lfloor>delta\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 28 + 3 * nlength start + 3 * nlength delta"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: jk tps0 tps1_def tps2_def)
+  show "ttt = 14 + 3 * nlength start + (14 + 3 * (nlength delta + nlength 0))"
+    using assms by simp
+qed
+
+definition "tpsL t \<equiv> tps0
+  [j3 + 2 := (\<lfloor>start + t\<rfloor>\<^sub>N, 1),
+   j3 + 1 := (\<lfloor>delta - t\<rfloor>\<^sub>N, 1),
+   j3 := nltape [start..<start + t]]"
+
+lemma tpsL_eq_tps2: "tpsL 0 = tps2"
+  using tpsL_def tps2_def tps0 jk
+  by (metis (mono_tags, lifting) One_nat_def Suc_n_not_le_n add_cancel_left_right eq_imp_le list_update_id
+    list_update_swap minus_nat.diff_0 nllength_Nil not_numeral_le_zero upt_conv_Nil)
+
+definition "tpsB1 t \<equiv> tps0
+  [j3 + 2 := (\<lfloor>start + t\<rfloor>\<^sub>N, 1),
+   j3 + 1 := (\<lfloor>delta - t\<rfloor>\<^sub>N, 1),
+   j3 := nltape ([start..<start + t] @ [start + t])]"
+
+lemma tmB1 [transforms_intros]:
+  assumes "ttt = 6 + 2 * nlength (start + t)"
+  shows "transforms tmB1 (tpsL t) ttt (tpsB1 t)"
+  unfolding tmB1_def
+proof (tform tps: tpsL_def tpsB1_def jk)
+  show "ttt = 7 + nllength [start..<start + t] - Suc (nllength [start..<start + t]) + 2 * nlength (start + t)"
+    using assms by simp
+qed
+
+definition "tpsB2 t \<equiv> tps0
+  [j3 + 2 := (\<lfloor>Suc (start + t)\<rfloor>\<^sub>N, 1),
+   j3 + 1 := (\<lfloor>delta - t\<rfloor>\<^sub>N, 1),
+   j3 := nltape ([start..<start + t] @ [start + t])]"
+
+lemma tmB2 [transforms_intros]:
+  assumes "ttt = 11 + 4 * nlength (start + t)"
+  shows "transforms tmB2 (tpsL t) ttt (tpsB2 t)"
+  unfolding tmB2_def by (tform tps: tpsL_def tpsB1_def tpsB2_def jk time: assms)
+
+definition "tpsB3 t \<equiv> tps0
+  [j3 + 2 := (\<lfloor>Suc (start + t)\<rfloor>\<^sub>N, 1),
+   j3 + 1 := (\<lfloor>delta - t - 1\<rfloor>\<^sub>N, 1),
+   j3 := nltape ([start..<start + t] @ [start + t])]"
+
+lemma tmB3:
+  assumes "ttt = 19 + 4 * nlength (start + t) + 2 * nlength (delta - t)"
+  shows "transforms tmB3 (tpsL t) ttt (tpsB3 t)"
+  unfolding tmB3_def by (tform tps: tpsL_def tpsB2_def tpsB3_def jk time: assms)
+
+lemma tpsB3: "tpsB3 t \<equiv> tpsL (Suc t)"
+  using tpsB3_def tpsL_def by simp
+
+lemma tmB3' [transforms_intros]:
+  assumes "ttt = 19 + 6 * nlength (start + delta)" and "t < delta"
+  shows "transforms tmB3 (tpsL t) ttt (tpsL (Suc t))"
+proof -
+  have "19 + 4 * nlength (start + t) + 2 * nlength (delta - t) \<le> 19 + 4 * nlength (start + t) + 2 * nlength delta"
+    using nlength_mono by simp
+  also have "... \<le> 19 + 4 * nlength (start + delta) + 2 * nlength delta"
+    using assms(2) nlength_mono by simp
+  also have "... \<le> 19 + 4 * nlength (start + delta) + 2 * nlength (start + delta)"
+    using nlength_mono by simp
+  also have "... = 19 + 6 * nlength (start + delta)"
+    by simp
+  finally have "19 + 4 * nlength (start + t) + 2 * nlength (delta - t) \<le> 19 + 6 * nlength (start + delta)" .
+  then show ?thesis
+    using tpsB3 tmB3 transforms_monotone assms(1) by metis
+qed
+
+lemma tmL:
+  assumes "ttt = delta * (21 + 6 * nlength (start + delta)) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL delta)"
+  unfolding tmL_def
+proof (tform)
+  have "read (tpsL t) ! (j3 + 1) \<noteq> \<box> \<longleftrightarrow> t < delta" for t
+    using tpsL_def read_ncontents_eq_0 jk by auto
+  then show "\<And>t. t < delta \<Longrightarrow> read (tpsL t) ! (j3 + 1) \<noteq> \<box>" and "\<not> read (tpsL delta) ! (j3 + 1) \<noteq> \<box>"
+    by simp_all
+  show "delta * (19 + 6 * nlength (start + delta) + 2) + 1 \<le> ttt"
+    using assms(1) by simp
+qed
+
+lemma tmL' [transforms_intros]:
+  assumes "ttt = delta * (21 + 6 * nlength (start + delta)) + 1"
+  shows "transforms tmL tps2 ttt (tpsL delta)"
+  using tmL assms tpsL_eq_tps2 by simp
+
+definition "tps3 \<equiv> tps0
+  [j3 + 2 := (\<lfloor>start + delta\<rfloor>\<^sub>N, 1),
+   j3 := nltape [start..<start + delta]]"
+
+lemma tpsL_eq_tps3: "tpsL delta = tps3"
+  using tps3_def tps0 jk tpsL_def
+  by (smt (z3) One_nat_def add_left_imp_eq cancel_comm_monoid_add_class.diff_cancel list_update_id
+    list_update_swap n_not_Suc_n numeral_2_eq_2)
+
+lemma tm3:
+  assumes "ttt = 29 + 3 * nlength start + 3 * nlength delta + delta * (21 + 6 * nlength (start + delta))"
+  shows "transforms tm3 tps0 ttt (tpsL delta)"
+  unfolding tm3_def by (tform time: assms)
+
+lemma tm3' [transforms_intros]:
+  assumes "ttt = 29 + 3 * nlength start + 3 * nlength delta + delta * (21 + 6 * nlength (start + delta))"
+  shows "transforms tm3 tps0 ttt tps3"
+  using assms tm3 tpsL_eq_tps3 by simp
+
+definition "tps4 \<equiv> tps0
+  [j3 := nltape [start..<start + delta]]"
+
+lemma tm4:
+  assumes "ttt = 39 + 3 * nlength start + 3 * nlength delta + delta * (21 + 6 * nlength (start + delta)) +
+    2 * nlength (start + delta)"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: tps3_def tps4_def jk time: assms)
+  show "tps4 = tps3[j3 + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    using tps4_def tps3_def tps0 jk
+    by (metis (mono_tags, lifting) Suc_neq_Zero add_cancel_right_right list_update_id list_update_overwrite
+      list_update_swap numeral_2_eq_2)
+qed
+
+lemma tm4' [transforms_intros]:
+  assumes "ttt = Suc delta * (39 + 8 * nlength (start + delta))"
+  shows "transforms tm4 tps0 ttt tps4"
+proof -
+  let ?ttt = "39 + 3 * nlength start + 3 * nlength delta + delta * (21 + 6 * nlength (start + delta)) + 2 * nlength (start + delta)"
+  have "?ttt \<le> 39 + 3 * nlength (start + delta) + 3 * nlength (start + delta) +
+      delta * (21 + 6 * nlength (start + delta)) + 2 * nlength (start + delta)"
+    using nlength_mono by (meson add_le_mono add_le_mono1 le_add2 nat_add_left_cancel_le nat_le_iff_add nat_mult_le_cancel_disj)
+  also have "... = 39 + 8 * nlength (start + delta) + delta * (21 + 6 * nlength (start + delta))"
+    by simp
+  also have "... \<le> 39 + 8 * nlength (start + delta) + delta * (39 + 8 * nlength (start + delta))"
+    by simp
+  also have "... = Suc delta * (39 + 8 * nlength (start + delta))"
+    by simp
+  finally have "?ttt \<le> Suc delta * (39 + 8 * nlength (start + delta))" .
+  then show ?thesis
+    using assms tm4 transforms_monotone tps4_def by simp
+qed
+
+definition "tps5 \<equiv> tps0
+  [j3 := (\<lfloor>[start..<start + delta]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm5:
+  assumes "ttt = Suc delta * (39 + 8 * nlength (start + delta)) + Suc (Suc (Suc (nllength [start..<start + delta])))"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def
+proof (tform tps: tps4_def tps5_def jk time: assms tps4_def jk)
+  show "clean_tape (tps4 ! j3)"
+    using tps4_def jk clean_tape_nlcontents by simp
+qed
+
+lemma tm5':
+  assumes "ttt = Suc delta * (43 + 9 * nlength (start + delta))"
+  shows "transforms tm5 tps0 ttt tps5"
+proof -
+  let ?ttt = "Suc delta * (39 + 8 * nlength (start + delta)) + Suc (Suc (Suc (nllength [start..<start + delta])))"
+  have "nllength [start..<start + delta] \<le> Suc (nlength (start + delta)) * delta"
+    using nllength_le_len_mult_max[of "[start..<start + delta]" "start + delta"] by simp
+  then have "?ttt \<le> Suc delta * (39 + 8 * nlength (start + delta)) + 3 + Suc (nlength (start + delta)) * delta"
+    by simp
+  also have "... \<le> 3 + Suc delta * (39 + 8 * nlength (start + delta)) + Suc delta * Suc (nlength (start + delta))"
+    by simp
+  also have "... = 3 + Suc delta * (39 + 8 * nlength (start + delta) + Suc (nlength (start + delta)))"
+    by algebra
+  also have "... = 3 + Suc delta * (40 + 9 * nlength (start + delta))"
+    by simp
+  also have "... \<le> Suc delta * (43 + 9 * nlength (start + delta))"
+    by simp
+  finally have "?ttt \<le> Suc delta * (43 + 9 * nlength (start + delta))" .
+  then show ?thesis
+    using tm5 assms transforms_monotone by simp
+qed
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_range *)
+
+lemma transforms_tm_rangeI [transforms_intros]:
+  fixes j1 j2 j3 :: tapeidx
+  fixes tps tps' :: "tape list" and k start delta :: nat
+  assumes "k \<ge> j3 + 3" "j1 \<noteq> j2" "0 < j1" "0 < j2" "j1 < j3" "j2 < j3" "length tps = k"
+  assumes
+    "tps ! j1 = (\<lfloor>start\<rfloor>\<^sub>N, 1)"
+    "tps ! j2 = (\<lfloor>delta\<rfloor>\<^sub>N, 1)"
+    "tps ! j3 = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! (j3 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = Suc delta * (43 + 9 * nlength (start + delta))"
+  assumes "tps' = tps
+    [j3 := (\<lfloor>[start..<start + delta]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+  shows "transforms (tm_range j1 j2 j3) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_range j1 j2 j3 .
+  show ?thesis
+    using assms loc.tm5_eq_tm_range loc.tm5' loc.tps5_def by simp
+qed
+
+
+subsection \<open>Creating singleton lists\<close>
+
+text \<open>
+The next Turing machine appends the symbol \textbf{|} to the symbols on
+tape~$j$. Thus it turns a number into a singleton list containing this number.
+\<close>
+
+definition tm_to_list :: "tapeidx \<Rightarrow> machine" where
+  "tm_to_list j \<equiv>
+    tm_right_until j {\<box>} ;;
+    tm_write j \<bar> ;;
+    tm_cr j"
+
+lemma tm_to_list_tm:
+  assumes "0 < j" and "j < k" and "G \<ge> 5"
+  shows "turing_machine k G (tm_to_list j)"
+  unfolding tm_to_list_def using tm_right_until_tm tm_write_tm tm_cr_tm assms by simp
+
+locale turing_machine_to_list =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_right_until j {\<box>}"
+definition "tm2 \<equiv> tm1 ;; tm_write j \<bar>"
+definition "tm3 \<equiv> tm2 ;; tm_cr j"
+
+lemma tm3_eq_tm_to_list: "tm3 = tm_to_list j"
+  using tm3_def tm2_def tm1_def tm_to_list_def by simp
+
+context
+  fixes tps0 :: "tape list" and k n :: nat
+  assumes jk: "0 < j" "j < k" "length tps0 = k"
+    and tps0: "tps0 ! j = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0[j := (\<lfloor>n\<rfloor>\<^sub>N, Suc (nlength n))]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = Suc (nlength n)"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: assms tps1_def tps0 jk)
+  show "rneigh (tps0 ! j) {0} (nlength n)"
+  proof (rule rneighI)
+    show "(tps0 ::: j) (tps0 :#: j + nlength n) \<in> {0}"
+      using tps0 jk by simp
+    show "\<And>n'. n' < nlength n \<Longrightarrow> (tps0 ::: j) (tps0 :#: j + n') \<notin> {0}"
+      using assms tps0 jk bit_symbols_canrepr contents_def by fastforce
+  qed
+qed
+
+definition "tps2 \<equiv> tps0[j := (\<lfloor>[n]\<rfloor>\<^sub>N\<^sub>L, Suc (nlength n))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = Suc (Suc (nlength n))"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: assms tps1_def tps0 jk)
+  have "numlist [n] = canrepr n @ [\<bar>]"
+    using numlist_def by simp
+  then show "tps2 = tps1[j := tps1 ! j |:=| \<bar>]"
+    using assms tps1_def tps2_def tps0 jk numlist_def nlcontents_def contents_snoc
+    by simp
+qed
+
+definition "tps3 \<equiv> tps0[j := (\<lfloor>[n]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm3:
+  assumes "ttt = 5 + 2 * nlength n"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps2_def tps0 jk time: assms tps2_def jk)
+  show "clean_tape (tps2 ! j)"
+    using tps2_def jk clean_tape_nlcontents by simp
+  show "tps3 = tps2[j := tps2 ! j |#=| 1]"
+    using tps3_def tps2_def jk by simp
+qed
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_tm_to_list *)
+
+lemma transforms_tm_to_listI [transforms_intros]:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k n :: nat
+  assumes "0 < j" "j < k" "length tps = k"
+  assumes "tps ! j = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 5 + 2 * nlength n"
+  assumes "tps' = tps[j := (\<lfloor>[n]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+  shows "transforms (tm_to_list j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_to_list j .
+  show ?thesis
+    using assms loc.tm3_eq_tm_to_list loc.tm3 loc.tps3_def by simp
+qed
+
+
+subsection \<open>Extending with a list\<close>
+
+text \<open>
+The next Turing machine extends the list on tape $j_1$ with the list on tape $j_2$.
+We assume that the tape head on $j_1$ is already at the end of the list.
+\<close>
+
+definition tm_extend :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_extend j1 j2 \<equiv> tm_cp_until j2 j1 {\<box>} ;; tm_cr j2"
+
+lemma tm_extend_tm:
+  assumes "0 < j1" and "G \<ge> 4" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_extend j1 j2)"
+  unfolding tm_extend_def using assms tm_cp_until_tm tm_cr_tm by simp
+
+locale turing_machine_extend =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_cp_until j2 j1 {\<box>}"
+definition "tm2 \<equiv> tm1 ;; tm_cr j2"
+
+lemma tm2_eq_tm_extend: "tm2 = tm_extend j1 j2"
+  unfolding tm2_def tm2_def tm1_def tm_extend_def by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and ns1 ns2 :: "nat list"
+  assumes jk: "0 < j1" "j1 < k" "j2 < k" "j1 \<noteq> j2" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = nltape ns1"
+    "tps0 ! j2 = (\<lfloor>ns2\<rfloor>\<^sub>N\<^sub>L, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j1 := nltape (ns1 @ ns2),
+   j2 := nltape ns2]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = Suc (nllength ns2)"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps1_def tps0 jk)
+  let ?n = "nllength ns2"
+  show "rneigh (tps0 ! j2) {0} ?n"
+  proof (rule rneighI)
+    show "(tps0 ::: j2) (tps0 :#: j2 + nllength ns2) \<in> {0}"
+      using tps0 nlcontents_def nllength_def jk by simp
+    show "\<And>i. i < nllength ns2 \<Longrightarrow> (tps0 ::: j2) (tps0 :#: j2 + i) \<notin> {0}"
+      using tps0 jk contents_def nlcontents_def nllength_def proper_symbols_numlist
+      by fastforce
+  qed
+  show "ttt = Suc (nllength ns2)"
+    using assms .
+  show "tps1 = tps0
+    [j2 := tps0 ! j2 |+| nllength ns2,
+     j1 := implant (tps0 ! j2) (tps0 ! j1) (nllength ns2)]"
+  proof -
+    have "implant (\<lfloor>ns2\<rfloor>\<^sub>N\<^sub>L, 1) (nltape ns1) (nllength ns2) = nltape (ns1 @ ns2)"
+      using nlcontents_def nllength_def implant_contents by (simp add: numlist_append)
+    moreover have "tps1 ! j2 = tps0 ! j2 |+| nllength ns2"
+      using tps0 jk tps1_def by simp
+    ultimately show ?thesis
+      using tps0 jk tps1_def by (metis fst_conv list_update_swap plus_1_eq_Suc snd_conv)
+  qed
+qed
+
+definition "tps2 \<equiv> tps0[j1 := nltape (ns1 @ ns2)]"
+
+lemma tm2:
+  assumes "ttt = 4 + 2 * nllength ns2"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps0 tps2_def tps1_def jk)
+  show "clean_tape (tps1 ! j2)"
+    using tps1_def jk clean_tape_nlcontents by simp
+  show "ttt = Suc (nllength ns2) + (tps1 :#: j2 + 2)"
+    using assms tps1_def jk by simp
+  show "tps2 = tps1[j2 := tps1 ! j2 |#=| 1]"
+    using tps1_def jk tps2_def tps0(2)
+    by (metis fst_conv length_list_update list_update_id list_update_overwrite nth_list_update)
+qed
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_extend *)
+
+lemma transforms_tm_extendI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and k :: nat and ns1 ns2 :: "nat list"
+  assumes "0 < j1" "j1 < k" "j2 < k" "j1 \<noteq> j2" "length tps = k"
+  assumes
+    "tps ! j1 = nltape ns1"
+    "tps ! j2 = (\<lfloor>ns2\<rfloor>\<^sub>N\<^sub>L, 1)"
+  assumes "ttt = 4 + 2 * nllength ns2"
+  assumes "tps' = tps[j1 := nltape (ns1 @ ns2)]"
+  shows "transforms (tm_extend j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_extend j1 j2 .
+  show ?thesis
+    using loc.tm2_eq_tm_extend loc.tm2 loc.tps2_def assms by simp
+qed
+
+text \<open>
+An enhanced version of the previous Turing machine, the next one erases the list
+on tape $j_2$ after appending it to tape $j_1$.
+\<close>
+
+definition tm_extend_erase :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_extend_erase j1 j2 \<equiv> tm_extend j1 j2 ;; tm_erase_cr j2"
+
+lemma tm_extend_erase_tm:
+  assumes "0 < j1" and "0 < j2" and "G \<ge> 4" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_extend_erase j1 j2)"
+  unfolding tm_extend_erase_def using assms tm_extend_tm tm_erase_cr_tm by simp
+
+lemma transforms_tm_extend_eraseI [transforms_intros]:
+  fixes j1 j2 :: tapeidx 
+  fixes tps tps' :: "tape list" and k :: nat and ns1 ns2 :: "nat list"
+  assumes "0 < j1" "j1 < k" "j2 < k" "j1 \<noteq> j2" "0 < j2" "length tps = k"
+  assumes
+    "tps ! j1 = nltape ns1"
+    "tps ! j2 = (\<lfloor>ns2\<rfloor>\<^sub>N\<^sub>L, 1)"
+  assumes "ttt = 11 + 4 * nllength ns2 "
+  assumes "tps' = tps
+    [j1 := nltape (ns1 @ ns2),
+     j2 := (\<lfloor>[]\<rfloor>, 1)]"
+  shows "transforms (tm_extend_erase j1 j2) tps ttt tps'"
+  unfolding tm_extend_erase_def
+proof (tform tps: assms)
+  let ?zs = "numlist ns2"
+  show "tps[j1 := nltape (ns1 @ ns2)] ::: j2 = \<lfloor>?zs\<rfloor>"
+    using assms by (simp add: nlcontents_def)
+  show "proper_symbols ?zs"
+    using proper_symbols_numlist by simp
+  show "ttt = 4 + 2 * nllength ns2 +
+      (tps[j1 := nltape (ns1 @ ns2)] :#: j2 + 2 * length (numlist ns2) + 6)"
+    using assms nllength_def by simp
+qed
+
+
+section \<open>Lists of lists of numbers\label{s:tm-numlistlist}\<close>
+
+text \<open>
+In this section we introduce a representation for lists of lists of numbers as
+symbol sequences over the quaternary alphabet @{text "\<zero>\<one>\<bar>\<sharp>"} and devise Turing
+machines for the few operations on such lists that we need.
+
+A tape containing such representations corresponds to a variable of type @{typ
+"nat list list"}. A tape in the start configuration corresponds to the empty
+list of lists of numbers.
+
+Many proofs in this section are copied from the previous section with minor
+modifications, mostly replacing the symbol @{text "\<bar>"} with @{text \<sharp>}.
+\<close>
+
+
+subsection \<open>Representation as symbol sequence\label{s:tm-numlistlist-repr}\<close>
+
+text \<open>
+We apply the same principle as for representing lists of numbers. To represent a
+list of lists of numbers, every element, which is now a list of numbers, is
+terminated by the symbol @{text \<sharp>}. In this way the empty symbol sequence
+represents the empty list of lists of numbers.  The list $[[]]$ containing only
+an empty list is represented by @{text \<sharp>} and the list $[[0]]$ containing only a
+list containing only a~0 is represented by @{text "\<bar>\<sharp>"}. As another example, the
+list $[[14,0,0,7],[],[0],[25]]$ is represented by @{text
+"\<zero>\<one>\<one>\<one>\<bar>\<bar>\<bar>\<one>\<one>\<one>\<bar>\<sharp>\<sharp>\<bar>\<sharp>\<one>\<zero>\<zero>\<one>\<one>\<bar>\<sharp>"}. The number of @{text \<sharp>} symbols equals
+the number of elements in the list.
+
+\null
+\<close>
+
+definition numlistlist :: "nat list list \<Rightarrow> symbol list" where
+  "numlistlist nss \<equiv> concat (map (\<lambda>ns. numlist ns @ [\<sharp>]) nss)"
+
+lemma numlistlist_Nil: "numlistlist [] = []"
+  using numlistlist_def by simp
+
+proposition "numlistlist [[]] = [\<sharp>]"
+  using numlistlist_def by (simp add: numlist_Nil)
+
+lemma proper_symbols_numlistlist: "proper_symbols (numlistlist nss)"
+proof (induction nss)
+  case Nil
+  then show ?case
+    using numlistlist_def by simp
+next
+  case (Cons ns nss)
+  have "numlistlist (ns # nss) = numlist ns @ [\<sharp>] @ concat (map (\<lambda>ns. numlist ns @ [\<sharp>]) nss)"
+    using numlistlist_def by simp
+  then have "numlistlist (ns # nss) = numlist ns @ [\<sharp>] @ numlistlist nss"
+    using numlistlist_def by simp
+  moreover have "proper_symbols (numlist ns)"
+    using proper_symbols_numlist by simp
+  moreover have "proper_symbols [\<sharp>]"
+    by simp
+  ultimately show ?case
+    using proper_symbols_append Cons by presburger
+qed
+
+lemma symbols_lt_append:
+  fixes xs ys :: "symbol list" and z :: symbol
+  assumes "symbols_lt z xs" and "symbols_lt z ys"
+  shows "symbols_lt z (xs @ ys)"
+  using assms prop_list_append by (simp add: nth_append)
+
+lemma symbols_lt_numlistlist:
+  assumes "H \<ge> 6"
+  shows "symbols_lt H (numlistlist nss)"
+proof (induction nss)
+  case Nil
+  then show ?case
+    using numlistlist_def by simp
+next
+  case (Cons ns nss)
+  have "numlistlist (ns # nss) = numlist ns @ [\<sharp>] @ concat (map (\<lambda>ns. numlist ns @ [\<sharp>]) nss)"
+    using numlistlist_def by simp
+  then have "numlistlist (ns # nss) = numlist ns @ [\<sharp>] @ numlistlist nss"
+    using numlistlist_def by simp
+  moreover have "symbols_lt H (numlist ns)"
+    using assms numlist_234 nth_mem by fastforce
+  moreover have "symbols_lt H [\<sharp>]"
+    using assms by simp
+  ultimately show ?case
+    using symbols_lt_append[of _ H] Cons by presburger
+qed
+
+lemma symbols_lt_prefix_eq:
+  assumes "(x @ [\<sharp>]) @ xs = (y @ [\<sharp>]) @ ys" and "symbols_lt 5 x" and "symbols_lt 5 y"
+  shows "x = y"
+proof -
+  have *: "x @ [\<sharp>] @ xs = y @ [\<sharp>] @ ys"
+      (is "?lhs = ?rhs")
+    using assms(1) by simp
+  show "x = y"
+  proof (cases "length x \<le> length y")
+    case True
+    then have "?lhs ! i = ?rhs ! i" if "i < length x" for i
+      using that * by simp
+    then have eq: "x ! i = y ! i" if "i < length x" for i
+      using that True by (metis Suc_le_eq le_trans nth_append)
+    have "?lhs ! (length x) = \<sharp>"
+      by (metis Cons_eq_appendI nth_append_length)
+    then have "?rhs ! (length x) = \<sharp>"
+      using * by metis
+    moreover have "y ! i \<noteq> \<sharp>" if "i < length y" for i
+      using that assms(3) by auto
+    ultimately have "length y \<le> length x"
+      by (metis linorder_le_less_linear nth_append)
+    then have "length y = length x"
+      using True by simp
+    then show ?thesis
+      using eq by (simp add: list_eq_iff_nth_eq)
+  next
+    case False
+    then have "?lhs ! i = ?rhs ! i" if "i < length y" for i
+      using that * by simp
+    have "?rhs ! (length y) = \<sharp>"
+      by (metis Cons_eq_appendI nth_append_length)
+    then have "?lhs ! (length y) = \<sharp>"
+      using * by metis
+    then have "x ! (length y) = \<sharp>"
+      using False by (simp add: nth_append)
+    then have False
+      using assms(2) False
+      by (simp add: order_less_le)
+    then show ?thesis
+      by simp
+  qed
+qed
+
+lemma numlistlist_inj: "numlistlist ns1 = numlistlist ns2 \<Longrightarrow> ns1 = ns2"
+proof (induction ns1 arbitrary: ns2)
+  case Nil
+  then show ?case
+    using numlistlist_def by simp
+next
+  case (Cons n ns1)
+  have 1: "numlistlist (n # ns1) = (numlist n @ [\<sharp>]) @ numlistlist ns1"
+    using numlistlist_def by simp
+  then have "numlistlist ns2 = (numlist n @ [\<sharp>]) @ numlistlist ns1"
+    using Cons by simp
+  then have "ns2 \<noteq> []"
+    using numlistlist_Nil by auto
+  then have 2: "ns2 = hd ns2 # tl ns2"
+    using `ns2 \<noteq> []` by simp
+  then have 3: "numlistlist ns2 = (numlist (hd ns2) @ [\<sharp>]) @ numlistlist (tl ns2)"
+    using numlistlist_def by (metis concat.simps(2) list.simps(9))
+
+  have 4: "hd ns2 = n"
+    using symbols_lt_prefix_eq 1 3 symbols_lt_numlist numlist_inj Cons by metis
+  then have "numlistlist ns2 = (numlist n @ [\<sharp>]) @ numlistlist (tl ns2)"
+    using 3 by simp
+  then have "numlistlist ns1 = numlistlist (tl ns2)"
+    using 1 by (simp add: Cons.prems)
+  then have "ns1 = tl ns2"
+    using Cons by simp
+  then show ?case
+    using 2 4 by simp
+qed
+
+lemma numlistlist_append: "numlistlist (xs @ ys) = numlistlist xs @ numlistlist ys"
+  using numlistlist_def by simp
+
+text \<open>
+Similar to @{text "\<lfloor>_\<rfloor>\<^sub>N"} and @{text "\<lfloor>_\<rfloor>\<^sub>N\<^sub>L"}, the tape contents for a list
+of list of numbers:
+\<close>
+
+definition nllcontents :: "nat list list \<Rightarrow> (nat \<Rightarrow> symbol)" ("\<lfloor>_\<rfloor>\<^sub>N\<^sub>L\<^sub>L") where
+  "\<lfloor>nss\<rfloor>\<^sub>N\<^sub>L\<^sub>L \<equiv> \<lfloor>numlistlist nss\<rfloor>"
+
+lemma clean_tape_nllcontents: "clean_tape (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L\<^sub>L, i)"
+  by (simp add: nllcontents_def proper_symbols_numlistlist)
+
+lemma nllcontents_Nil: "\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L\<^sub>L = \<lfloor>[]\<rfloor>"
+  using nllcontents_def by (simp add: numlistlist_Nil)
+
+text \<open>
+Similar to @{const nlength} and @{const nllength}, the length of the
+representation of a list of lists of numbers:
+\<close>
+
+definition nlllength :: "nat list list \<Rightarrow> nat" where
+  "nlllength nss \<equiv> length (numlistlist nss)"
+
+lemma nlllength: "nlllength nss = (\<Sum>ns\<leftarrow>nss. Suc (nllength ns))"
+  using nlllength_def numlistlist_def nllength_def by (induction nss) simp_all
+
+lemma nlllength_Nil [simp]: "nlllength [] = 0"
+  using nlllength_def numlistlist_def by simp
+
+lemma nlllength_Cons: "nlllength (ns # nss) = Suc (nllength ns) + nlllength nss"
+  by (simp add: nlllength)
+
+lemma length_le_nlllength: "length nss \<le> nlllength nss"
+  using nlllength sum_list_mono[of nss "\<lambda>_. 1" "\<lambda>ns. Suc (nllength ns)"] sum_list_const[of 1 nss]
+  by simp
+
+lemma member_le_nlllength_1: "ns \<in> set nss \<Longrightarrow> nllength ns \<le> nlllength nss - 1"
+  using nlllength by (induction nss) auto
+
+lemma nlllength_take:
+  assumes "i < length nss"
+  shows "nlllength (take i nss) + nllength (nss ! i) < nlllength nss"
+proof -
+  have "nss = take i nss @ [nss ! i] @ drop (Suc i) nss"
+    using assms by (metis Cons_eq_appendI append_self_conv2 id_take_nth_drop)
+  then have "numlistlist nss = numlistlist (take i nss) @ numlistlist [nss ! i] @ numlistlist (drop (Suc i) nss)"
+    using numlistlist_append by metis
+  then have "nlllength nss = nlllength (take i nss) + nlllength [nss ! i] + nlllength (drop (Suc i) nss)"
+    by (simp add: nlllength_def)
+  then have "nlllength nss \<ge> nlllength (take i nss) + nlllength [nss ! i]"
+    by simp
+  then have "nlllength nss \<ge> nlllength (take i nss) + Suc (nllength (nss ! i))"
+    using nlllength by simp
+  then show ?thesis
+    by simp
+qed
+
+lemma take_drop_numlistlist:
+  assumes "i < length ns"
+  shows "take (Suc (nllength (ns ! i))) (drop (nlllength (take i ns)) (numlistlist ns)) = numlist (ns ! i) @ [\<sharp>]"
+proof -
+  have "numlistlist ns = numlistlist (take i ns) @ numlistlist (drop i ns)"
+    using numlistlist_append by (metis append_take_drop_id)
+  moreover have "numlistlist (drop i ns) = numlistlist [ns ! i] @ numlistlist (drop (Suc i) ns)"
+    using assms numlistlist_append by (metis Cons_nth_drop_Suc append_Cons self_append_conv2)
+  ultimately have "numlistlist ns = numlistlist (take i ns) @ numlistlist [ns ! i] @ numlistlist (drop (Suc i) ns)"
+    by simp
+  then have "drop (nlllength (take i ns)) (numlistlist ns) = numlistlist [ns ! i] @ numlistlist (drop (Suc i) ns)"
+    by (simp add: nlllength_def)
+  then have "drop (nlllength (take i ns)) (numlistlist ns) = numlist (ns ! i) @ [\<sharp>] @ numlistlist (drop (Suc i) ns)"
+    using numlistlist_def by simp
+  then show ?thesis
+    by (simp add: nllength_def)
+qed
+
+corollary take_drop_numlistlist':
+  assumes "i < length ns"
+  shows "take (nllength (ns ! i)) (drop (nlllength (take i ns)) (numlistlist ns)) = numlist (ns ! i)"
+  using take_drop_numlistlist[OF assms] nllength_def by (metis append_assoc append_eq_conv_conj append_take_drop_id)
+
+corollary numlistlist_take_at_term:
+  assumes "i < length ns"
+  shows "numlistlist ns ! (nlllength (take i ns) + nllength (ns ! i)) = \<sharp>"
+  using assms take_drop_numlistlist nlllength_def numlistlist_append
+  by (smt (z3) append_eq_conv_conj append_take_drop_id lessI nllength_def nth_append_length nth_append_length_plus nth_take)
+
+lemma nlllength_take_Suc:
+  assumes "i < length ns"
+  shows "nlllength (take i ns) + Suc (nllength (ns ! i)) = nlllength (take (Suc i) ns)"
+proof -
+  have "ns = take i ns @ [ns ! i] @ drop (Suc i) ns"
+    using assms by (metis Cons_eq_appendI append_self_conv2 id_take_nth_drop)
+  then have "numlistlist ns = numlistlist (take i ns) @ numlistlist [ns ! i] @ numlistlist (drop (Suc i) ns)"
+    using numlistlist_append by metis
+  then have "nlllength ns = nlllength (take i ns) + nlllength [ns ! i] + nlllength (drop (Suc i) ns)"
+    by (simp add: nlllength_def)
+  moreover have "nlllength ns = nlllength (take (Suc i) ns) + nlllength (drop (Suc i) ns)"
+    using numlistlist_append by (metis append_take_drop_id length_append nlllength_def)
+  ultimately have "nlllength (take (Suc i) ns) = nlllength (take i ns) + nlllength [ns ! i]"
+    by simp
+  then show ?thesis
+    using nlllength by simp
+qed
+
+lemma numlistlist_take_at:
+  assumes "i < length ns" and "j < nllength (ns ! i)"
+  shows "numlistlist ns ! (nlllength (take i ns) + j) = numlist (ns ! i) ! j"
+proof -
+  have "ns = take i ns @ [ns ! i] @ drop (Suc i) ns"
+    using assms by (metis Cons_eq_appendI append_self_conv2 id_take_nth_drop)
+  then have "numlistlist ns = (numlistlist (take i ns) @ numlistlist [ns ! i]) @ numlistlist (drop (Suc i) ns)"
+    using numlistlist_append by (metis append_assoc)
+  moreover have "nlllength (take i ns) + j < nlllength (take i ns) + nlllength [ns ! i]"
+    using assms(2) nlllength by simp
+  ultimately have "numlistlist ns ! (nlllength (take i ns) + j) =
+      (numlistlist (take i ns) @ numlistlist [ns ! i]) ! (nlllength (take i ns) + j)"
+    by (metis length_append nlllength_def nth_append)
+  also have "... = numlistlist [ns ! i] ! j"
+    by (simp add: nlllength_def)
+  also have "... = (numlist (ns ! i) @ [\<sharp>]) ! j"
+    using numlistlist_def by simp
+  also have "... = numlist (ns ! i) ! j"
+    using assms(2) by (metis nllength_def nth_append)
+  finally show ?thesis .
+qed
+
+lemma nllcontents_rneigh_5:
+  assumes "i < length ns"
+  shows "rneigh (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L\<^sub>L, Suc (nlllength (take i ns))) {\<sharp>} (nllength (ns ! i))"
+proof (rule rneighI)
+  let ?tp = "(\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L\<^sub>L, Suc (nlllength (take i ns)))"
+  show "fst ?tp (snd ?tp + nllength (ns ! i)) \<in> {\<sharp>}"
+  proof -
+    have "snd ?tp + nllength (ns ! i) \<le> nlllength ns"
+      using nlllength_take assms by (simp add: Suc_leI)
+    then have "fst ?tp (snd ?tp + nllength (ns ! i)) =
+        numlistlist ns ! (nlllength (take i ns) + nllength (ns ! i))"
+      using nllcontents_def contents_inbounds nlllength_def by simp
+    then show ?thesis
+      using numlistlist_take_at_term assms by simp
+  qed
+  show "fst ?tp (snd ?tp + j) \<notin> {\<sharp>}" if "j < nllength (ns ! i)" for j
+  proof -
+    have "snd ?tp + nllength (ns ! i) \<le> nlllength ns"
+      using nlllength_take assms by (simp add: Suc_leI)
+    then have "snd ?tp + j \<le> nlllength ns"
+      using that by simp
+    then have "fst ?tp (snd ?tp + j) = numlistlist ns ! (nlllength (take i ns) + j)"
+      using nllcontents_def contents_inbounds nlllength_def by simp
+    then have "fst ?tp (snd ?tp + j) = numlist (ns ! i) ! j"
+      using assms that numlistlist_take_at by simp
+    moreover have "numlist (ns ! i) ! j \<noteq> \<sharp>"
+      using numlist_234 that nllength_def nth_mem by fastforce
+    ultimately show ?thesis
+      by simp
+  qed
+qed
+
+text \<open>
+A tape containing a list of lists of numbers, with the tape head after all
+the symbols:
+\<close>
+
+abbreviation nlltape :: "nat list list \<Rightarrow> tape" where
+  "nlltape ns \<equiv> (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L\<^sub>L, Suc (nlllength ns))"
+
+text \<open>
+Like before but with the tape head or at the beginning of the $i$-th list
+element:
+\<close>
+
+abbreviation nlltape' :: "nat list list \<Rightarrow> nat \<Rightarrow> tape" where
+  "nlltape' ns i \<equiv> (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L\<^sub>L, Suc (nlllength (take i ns)))"
+
+lemma nlltape'_0: "nlltape' ns 0 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+  using nlllength by simp
+
+lemma nlltape'_tape_read: "|.| (nlltape' nss i) = 0 \<longleftrightarrow> i \<ge> length nss"
+proof -
+  have "|.| (nlltape' nss i) = 0" if "i \<ge> length nss" for i
+  proof -
+    have "nlltape' nss i \<equiv> (\<lfloor>nss\<rfloor>\<^sub>N\<^sub>L\<^sub>L, Suc (nlllength nss))"
+      using that by simp
+    then show ?thesis
+      using nllcontents_def contents_outofbounds nlllength_def
+      by (metis Suc_eq_plus1 add.left_neutral fst_conv less_Suc0 less_add_eq_less snd_conv)
+  qed
+  moreover have "|.| (nlltape' nss i) \<noteq> 0" if "i < length nss" for i
+    using that nllcontents_def contents_inbounds nlllength_def nlllength_take proper_symbols_numlistlist
+    by (metis Suc_leI add_Suc_right diff_Suc_1 fst_conv less_add_same_cancel1 less_le_trans not_add_less2
+      plus_1_eq_Suc snd_conv zero_less_Suc)
+  ultimately show ?thesis
+    by (meson le_less_linear)
+qed
+
+
+subsection \<open>Appending an element\<close>
+
+text \<open>
+The next Turing machine is very similar to @{const tm_append}, just with
+terminator symbol @{text \<sharp>} instead of @{text "\<bar>"}. It appends a list of
+numbers given on tape $j_2$ to the list of lists of numbers on tape $j_1$.
+\<close>
+
+definition tm_appendl :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_appendl j1 j2 \<equiv>
+    tm_right_until j1 {\<box>} ;;
+    tm_cp_until j2 j1 {\<box>} ;;
+    tm_cr j2 ;;
+    tm_char j1 \<sharp>"
+
+lemma tm_appendl_tm:
+  assumes "0 < j1" and "G \<ge> 6" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_appendl j1 j2)"
+  unfolding tm_appendl_def using assms tm_right_until_tm tm_cp_until_tm tm_char_tm tm_cr_tm by simp
+
+locale turing_machine_appendl =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_right_until j1 {\<box>}"
+definition "tm2 \<equiv> tm1 ;; tm_cp_until j2 j1 {\<box>}"
+definition "tm3 \<equiv> tm2 ;; tm_cr j2"
+definition "tm4 \<equiv> tm3 ;; tm_char j1 \<sharp>"
+
+lemma tm4_eq_tm_append: "tm4 = tm_appendl j1 j2"
+  unfolding tm4_def tm3_def tm2_def tm1_def tm_appendl_def by simp
+
+context
+  fixes tps0 :: "tape list" and k i1 :: nat and ns :: "nat list" and nss :: "nat list list"
+  assumes jk: "length tps0 = k" "j1 < k" "j2 < k" "j1 \<noteq> j2" "0 < j1"
+    and i1: "i1 \<le> Suc (nlllength nss)"
+  assumes tps0:
+     "tps0 ! j1 = (\<lfloor>nss\<rfloor>\<^sub>N\<^sub>L\<^sub>L, i1)"
+     "tps0 ! j2 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+begin
+
+definition "tps1 \<equiv> tps0[j1 := nlltape nss]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = Suc (Suc (nlllength nss) - i1)"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: jk)
+  let ?l = "Suc (nlllength nss) - i1"
+  show "rneigh (tps0 ! j1) {0} ?l"
+  proof (rule rneighI)
+    show "(tps0 ::: j1) (tps0 :#: j1 + ?l) \<in> {0}"
+      using tps0 jk nllcontents_def nlllength_def by simp
+    show "(tps0 ::: j1) (tps0 :#: j1 + i) \<notin> {0}" if "i < Suc (nlllength nss) - i1" for i
+    proof -
+      have "i1 + i < Suc (nlllength nss)"
+        using that i1 by simp
+      then show ?thesis
+        using proper_symbols_numlistlist nlllength_def tps0 nllcontents_def contents_def
+        by (metis One_nat_def Suc_leI diff_Suc_1 fst_conv less_Suc_eq_0_disj less_nat_zero_code singletonD snd_conv)
+    qed
+  qed
+  show "ttt = Suc (Suc (nlllength nss) - i1)"
+    using assms(1) .
+  show "tps1 = tps0[j1 := tps0 ! j1 |+| Suc (nlllength nss) - i1]"
+    using tps1_def tps0 i1 by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j1 := (\<lfloor>numlistlist nss @ numlist ns\<rfloor>, Suc (nlllength nss) + nllength ns),
+   j2 := (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength ns))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 3 + nlllength nss - i1 + nllength ns"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: jk tps1_def)
+  have j1: "tps1 ! j1 = nlltape nss"
+    using tps1_def by (simp add: jk)
+  have j2: "tps1 ! j2 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tps1_def tps0 jk by simp
+  show "rneigh (tps1 ! j2) {0} (nllength ns)"
+  proof (rule rneighI)
+    show "(tps1 ::: j2) (tps1 :#: j2 + nllength ns) \<in> {0}"
+      using j2 by (simp add: nlcontents_def nllength_def)
+    show "\<And>i. i < nllength ns \<Longrightarrow> (tps1 ::: j2) (tps1 :#: j2 + i) \<notin> {0}"
+      using j2 tps0 contents_def nlcontents_def nllength_def proper_symbols_numlist by fastforce
+  qed
+  show "tps2 = tps1
+    [j2 := tps1 ! j2 |+| nllength ns,
+     j1 := implant (tps1 ! j2) (tps1 ! j1) (nllength ns)]"
+    (is "_ = ?rhs")
+  proof -
+    have "implant (tps1 ! j2) (tps1 ! j1) (nllength ns) = implant (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1) (nlltape nss) (nllength ns)"
+      using j1 j2 by simp
+    also have "... =
+      (\<lfloor>numlistlist nss @ (take (nllength ns) (drop (1 - 1) (numlist ns)))\<rfloor>,
+       Suc (length (numlistlist nss)) + nllength ns)"
+      using implant_contents nlcontents_def nllength_def nllcontents_def nlllength_def by simp
+    also have "... = (\<lfloor>numlistlist nss @ numlist ns\<rfloor>, Suc (length (numlistlist nss)) + nllength ns)"
+      by (simp add: nllength_def)
+    also have "... = (\<lfloor>numlistlist nss @ numlist ns\<rfloor>, Suc (nlllength nss) + nllength ns)"
+      using nlllength_def by simp
+    also have "... = tps2 ! j1"
+      using jk tps2_def by (metis nth_list_update_eq nth_list_update_neq)
+    finally have "implant (tps1 ! j2) (tps1 ! j1) (nllength ns) = tps2 ! j1" .
+    then have "tps2 ! j1 = implant (tps1 ! j2) (tps1 ! j1) (nllength ns)"
+      by simp
+    then have "tps2 ! j1 = ?rhs ! j1"
+      using tps1_def jk by (metis length_list_update nth_list_update_eq)
+    moreover have "tps2 ! j2 = ?rhs ! j2"
+      using tps2_def tps1_def jk j2 by simp
+    moreover have "tps2 ! j = ?rhs ! j" if "j < length tps2" "j \<noteq> j1" "j \<noteq> j2" for j
+      using that tps2_def tps1_def by simp
+    moreover have "length tps2 = length ?rhs"
+      using tps1_def tps2_def by simp
+    ultimately show ?thesis
+      using nth_equalityI by blast
+  qed
+  show "ttt = Suc (Suc (nlllength nss) - i1) + Suc (nllength ns)"
+    using assms(1) j1 tps0 i1 by simp
+qed
+
+definition "tps3 \<equiv> tps0
+  [j1 := (\<lfloor>numlistlist nss @ numlist ns\<rfloor>, Suc (nlllength nss) + nllength ns)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 6 + nlllength nss - i1 + 2 * nllength ns"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: jk i1 tps2_def)
+  let ?tp1 = "(\<lfloor>numlistlist nss @ numlist ns\<rfloor>, Suc (nlllength nss + nllength ns))"
+  let ?tp2 = "(\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, Suc (nllength ns))"
+  show "clean_tape (tps2 ! j2)"
+    using tps2_def jk by (simp add: clean_tape_nlcontents)
+  show "tps3 = tps2[j2 := tps2 ! j2 |#=| 1]"
+    using tps3_def tps2_def jk tps0(2)
+    by (metis fst_eqD length_list_update list_update_overwrite list_update_same_conv nth_list_update)
+  show "ttt = 3 + nlllength nss - i1 + nllength ns + (tps2 :#: j2 + 2)"
+    using assms tps2_def jk tps0 i1 by simp
+qed
+
+definition "tps4 \<equiv> tps0
+  [j1 := (\<lfloor>numlistlist (nss @ [ns])\<rfloor>, Suc (nlllength (nss @ [ns])))]"
+
+lemma tm4:
+  assumes "ttt = 7 + nlllength nss - i1 + 2 * nllength ns"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: jk tps3_def time: jk i1 assms)
+  show "tps4 = tps3[j1 := tps3 ! j1 |:=| \<sharp> |+| 1]"
+    (is "tps4 = ?tps")
+  proof -
+    have "tps3 ! j1 = (\<lfloor>numlistlist nss @ numlist ns\<rfloor>, Suc (nlllength nss) + nllength ns)"
+      using tps3_def jk by simp
+    then have "?tps = tps0[j1 := (\<lfloor>numlistlist nss @ numlist ns\<rfloor>, Suc (nlllength nss + nllength ns)) |:=| \<sharp> |+| 1]"
+      using tps3_def by simp
+    moreover have "(\<lfloor>numlistlist nss @ numlist ns\<rfloor>, Suc (nlllength nss + nllength ns)) |:=| \<sharp> |+| 1 =
+        (\<lfloor>numlistlist (nss @ [ns])\<rfloor>, Suc (nlllength (nss @ [ns])))"
+      (is "?lhs = ?rhs")
+    proof -
+      have "?lhs =
+        (\<lfloor>numlistlist nss @ numlist ns\<rfloor>(Suc (nlllength nss + nllength ns) := \<sharp>),
+         Suc (Suc (nlllength nss + nllength ns)))"
+        by simp
+      also have "... =
+        (\<lfloor>numlistlist nss @ numlist ns\<rfloor>(Suc (nlllength nss + nllength ns) := \<sharp>),
+         Suc (nlllength (nss @ [ns])))"
+        using nlllength_def numlistlist_def nllength_def numlist_def by simp
+      also have "... = (\<lfloor>(numlistlist nss @ numlist ns) @ [\<sharp>]\<rfloor>, Suc (nlllength (nss @ [ns])))"
+        using contents_snoc nlllength_def nllength_def by (metis length_append)
+      also have "... = (\<lfloor>numlistlist nss @ numlist ns @ [\<sharp>]\<rfloor>, Suc (nlllength (nss @ [ns])))"
+        by simp
+      also have "... = (\<lfloor>numlistlist (nss @ [ns])\<rfloor>, Suc (nlllength (nss @ [ns])))"
+        using numlistlist_def by simp
+      finally show "?lhs = ?rhs" .
+    qed
+    ultimately show ?thesis
+      using tps4_def by auto
+  qed
+qed
+
+end  (* context *)
+
+end  (* locale turing_machine_appendl *)
+
+lemma transforms_tm_appendlI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k i1 :: nat and ns :: "nat list" and nss :: "nat list list"
+  assumes "0 < j1"
+  assumes "length tps = k" "j1 < k" "j2 < k" "j1 \<noteq> j2"
+    and "i1 \<le> Suc (nlllength nss)"
+  assumes
+    "tps ! j1 = (\<lfloor>nss\<rfloor>\<^sub>N\<^sub>L\<^sub>L, i1)"
+    "tps ! j2 = (\<lfloor>ns\<rfloor>\<^sub>N\<^sub>L, 1)"
+  assumes "ttt = 7 + nlllength nss - i1 + 2 * nllength ns"
+  assumes "tps' = tps
+    [j1 := nlltape (nss @ [ns])]"
+  shows "transforms (tm_appendl j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_appendl j1 j2 .
+  show ?thesis
+    using loc.tps4_def loc.tm4 loc.tm4_eq_tm_append assms nllcontents_def by simp
+qed
+
+subsection \<open>Extending with a list\<close>
+
+text \<open>
+The next Turing machine extends a list of lists of numbers with another list of
+lists of numbers. It is in fact the same TM as for extending a list of numbers
+because in both cases extending means simply copying the contents from one tape
+to another.  We introduce a new name for this TM and express the semantics in
+terms of lists of lists of numbers.  The proof is almost the same except with
+@{const nllength} replaced by @{const nlllength} and so on.
+\<close>
+
+definition tm_extendl :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_extendl \<equiv> tm_extend"
+
+lemma tm_extendl_tm:
+  assumes "0 < j1" and "G \<ge> 4" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_extendl j1 j2)"
+  unfolding tm_extendl_def using assms tm_extend_tm by simp
+
+locale turing_machine_extendl =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_cp_until j2 j1 {\<box>}"
+definition "tm2 \<equiv> tm1 ;; tm_cr j2"
+
+lemma tm2_eq_tm_extendl: "tm2 = tm_extendl j1 j2"
+  unfolding tm2_def tm2_def tm1_def tm_extendl_def tm_extend_def by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and nss1 nss2 :: "nat list list"
+  assumes jk: "0 < j1" "j1 < k" "j2 < k" "j1 \<noteq> j2" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = nlltape nss1"
+    "tps0 ! j2 = (\<lfloor>nss2\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j1 := nlltape (nss1 @ nss2),
+   j2 := nlltape nss2]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = Suc (nlllength nss2)"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps1_def tps0 jk time: assms)
+  let ?n = "nlllength nss2"
+  show "rneigh (tps0 ! j2) {\<box>} ?n"
+  proof (rule rneighI)
+    show "(tps0 ::: j2) (tps0 :#: j2 + nlllength nss2) \<in> {\<box>}"
+      using tps0 nllcontents_def nlllength_def jk by simp
+    show "\<And>i. i < nlllength nss2 \<Longrightarrow> (tps0 ::: j2) (tps0 :#: j2 + i) \<notin> {\<box>}"
+      using tps0 jk contents_def nllcontents_def nlllength_def proper_symbols_numlistlist
+      by fastforce
+  qed
+  show "tps1 = tps0
+    [j2 := tps0 ! j2 |+| nlllength nss2,
+     j1 := implant (tps0 ! j2) (tps0 ! j1) (nlllength nss2)]"
+  proof -
+    have "implant (\<lfloor>nss2\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1) (nlltape nss1) (nlllength nss2) = nlltape (nss1 @ nss2)"
+      using nllcontents_def nlllength_def implant_contents by (simp add: numlistlist_append)
+    moreover have "tps1 ! j2 = tps0 ! j2 |+| nlllength nss2"
+      using tps0 jk tps1_def by simp
+    ultimately show ?thesis
+      using tps0 jk tps1_def by (metis fst_conv list_update_swap plus_1_eq_Suc snd_conv)
+  qed
+qed
+
+definition "tps2 \<equiv> tps0[j1 := nlltape (nss1 @ nss2)]"
+
+lemma tm2:
+  assumes "ttt = 4 + 2 * nlllength nss2"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps1_def tps2_def jk time: assms tps1_def jk)
+  show "clean_tape (tps1 ! j2)"
+    using tps1_def jk clean_tape_nllcontents by simp
+  show "tps2 = tps1[j2 := tps1 ! j2 |#=| 1]"
+    using tps1_def jk tps2_def tps0(2)
+    by (metis fst_conv length_list_update list_update_id list_update_overwrite nth_list_update)
+qed
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_extendl *)
+
+lemma transforms_tm_extendlI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and k :: nat and nss1 nss2 :: "nat list list"
+  assumes "0 < j1" "j1 < k" "j2 < k" "j1 \<noteq> j2" "length tps = k"
+  assumes
+    "tps ! j1 = nlltape nss1"
+    "tps ! j2 = (\<lfloor>nss2\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+  assumes "ttt = 4 + 2 * nlllength nss2"
+  assumes "tps' = tps[j1 := nlltape (nss1 @ nss2)]"
+  shows "transforms (tm_extendl j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_extendl j1 j2 .
+  show ?thesis
+    using loc.tm2_eq_tm_extendl loc.tm2 loc.tps2_def assms by simp
+qed
+
+text \<open>
+The next Turing machine erases the appended list.
+\<close>
+
+definition tm_extendl_erase :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_extendl_erase j1 j2 \<equiv> tm_extendl j1 j2 ;; tm_erase_cr j2"
+
+lemma tm_extendl_erase_tm:
+  assumes "0 < j1" and "0 < j2" and "G \<ge> 4" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_extendl_erase j1 j2)"
+  unfolding tm_extendl_erase_def using assms tm_extendl_tm tm_erase_cr_tm by simp
+
+lemma transforms_tm_extendl_eraseI [transforms_intros]:
+  fixes tps tps' :: "tape list" and j1 j2 :: tapeidx and ttt k :: nat and nss1 nss2 :: "nat list list"
+  assumes "0 < j1" "j1 < k" "j2 < k" "j1 \<noteq> j2" "0 < j2" "length tps = k"
+  assumes
+    "tps ! j1 = nlltape nss1"
+    "tps ! j2 = (\<lfloor>nss2\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+  assumes "ttt = 11 + 4 * nlllength nss2 "
+  assumes "tps' = tps
+    [j1 := nlltape (nss1 @ nss2),
+     j2 := (\<lfloor>[]\<rfloor>, 1)]"
+  shows "transforms (tm_extendl_erase j1 j2) tps ttt tps'"
+  unfolding tm_extendl_erase_def
+proof (tform tps: assms)
+  let ?zs = "numlistlist nss2"
+  show "tps[j1 := nlltape (nss1 @ nss2)] ::: j2 = \<lfloor>?zs\<rfloor>"
+    using assms by (simp add: nllcontents_def)
+  show "proper_symbols ?zs"
+    using proper_symbols_numlistlist by simp
+  show "ttt = 4 + 2 * nlllength nss2 +
+      (tps[j1 := nlltape (nss1 @ nss2)] :#: j2 + 2 * length (numlistlist nss2) + 6)"
+    using assms nlllength_def by simp
+qed
+
+
+subsection \<open>Moving to the next element\<close>
+
+text \<open>
+Iterating over a list of lists of numbers works with the same Turing machine,
+@{const tm_nextract}, as for lists of numbers. We just have to set the parameter
+$z$ to the terminator symbol @{text \<sharp>}.  For the proof
+we can also just copy from the previous section, replacing the symbol @{text "\<bar>"}
+by @{text \<sharp>} and @{const nllength} by @{const nlllength}, etc.
+
+\null
+\<close>
+
+locale turing_machine_nextract_5 =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_erase_cr j2"
+definition "tm2 \<equiv> tm1 ;; tm_cp_until j1 j2 {\<sharp>}"
+definition "tm3 \<equiv> tm2 ;; tm_cr j2"
+definition "tm4 \<equiv> tm3 ;; tm_right j1"
+
+lemma tm4_eq_tm_nextract: "tm4 = tm_nextract \<sharp> j1 j2"
+  unfolding tm1_def tm2_def tm3_def tm4_def tm_nextract_def by simp
+
+context
+  fixes tps0 :: "tape list" and k idx :: nat and nss :: "nat list list" and dummy :: "nat list"
+  assumes jk: "j1 < k" "j2 < k" "0 < j1" "0 < j2" "j1 \<noteq> j2" "length tps0 = k"
+    and idx: "idx < length nss"
+    and tps0:
+      "tps0 ! j1 = nlltape' nss idx"
+      "tps0 ! j2 = (\<lfloor>dummy\<rfloor>\<^sub>N\<^sub>L, 1)"
+begin
+
+definition "tps1 \<equiv> tps0[j2 := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 7 + 2 * nllength dummy"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: jk idx tps0 tps1_def assms)
+  show "proper_symbols (numlist dummy)"
+    using proper_symbols_numlist by simp
+  show "tps1 = tps0[j2 := (\<lfloor>[]\<rfloor>, 1)]"
+    using tps1_def by (simp add: nlcontents_def numlist_Nil)
+  show "tps0 ::: j2 = \<lfloor>numlist dummy\<rfloor>"
+    using tps0 by (simp add: nlcontents_def)
+  show "ttt = tps0 :#: j2 + 2 * length (numlist dummy) + 6"
+    using tps0 assms nllength_def by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j1 := (\<lfloor>nss\<rfloor>\<^sub>N\<^sub>L\<^sub>L, nlllength (take (Suc idx) nss)),
+   j2 := (\<lfloor>nss ! idx\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (nss ! idx)))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 7 + 2 * nllength dummy + Suc (nllength (nss ! idx))"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: jk idx tps0 tps2_def tps1_def time: assms)
+  show "rneigh (tps1 ! j1) {\<sharp>} (nllength (nss ! idx))"
+    using tps1_def tps0 jk by (simp add: idx nllcontents_rneigh_5)
+  show "tps2 = tps1
+    [j1 := tps1 ! j1 |+| nllength (nss ! idx),
+     j2 := implant (tps1 ! j1) (tps1 ! j2) (nllength (nss ! idx))]"
+     (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show len: "length ?l = length ?r"
+      using tps1_def tps2_def jk by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      consider "i = j1" | "i = j2" | "i \<noteq> j1 \<and> i \<noteq> j2"
+        by auto
+      then show ?thesis
+      proof (cases)
+        case 1
+        then show ?thesis
+          using tps0 that tps1_def tps2_def jk nlllength_take_Suc[OF idx] idx by simp
+      next
+        case 2
+        then have lhs: "?l ! i = (\<lfloor>nss ! idx\<rfloor>\<^sub>N\<^sub>L, Suc (nllength (nss ! idx)))"
+          using tps2_def jk by simp
+        let ?i = "Suc (nlllength (take idx nss))"
+        have i1: "?i > 0"
+          by simp
+        have "nllength (nss ! idx) + (?i - 1) \<le> nlllength nss"
+          using idx nlllength_take by (metis add.commute diff_Suc_1 less_or_eq_imp_le)
+        then have i2: "nllength (nss ! idx) + (?i - 1) \<le> length (numlistlist nss)"
+          using nlllength_def by simp
+        have "?r ! i = implant (tps1 ! j1) (tps1 ! j2) (nllength (nss ! idx))"
+          using 2 tps1_def jk by simp
+        also have "... = implant (\<lfloor>nss\<rfloor>\<^sub>N\<^sub>L\<^sub>L, ?i) (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1) (nllength (nss ! idx))"
+          using tps1_def jk tps0 by simp
+        also have "... =
+          (\<lfloor>[] @ (take (nllength (nss ! idx)) (drop (?i - 1) (numlistlist nss)))\<rfloor>,
+           Suc (length []) + nllength (nss ! idx))"
+          using implant_contents[OF i1 i2] nllcontents_def nlcontents_def numlist_Nil by (metis One_nat_def list.size(3))
+        finally have "?r ! i =
+          (\<lfloor>[] @ (take (nllength (nss ! idx)) (drop (?i - 1) (numlistlist nss)))\<rfloor>,
+           Suc (length []) + nllength (nss ! idx))" .
+        then have "?r ! i =
+          (\<lfloor>take (nllength (nss ! idx)) (drop (nlllength (take idx nss)) (numlistlist nss))\<rfloor>,
+           Suc (nllength (nss ! idx)))"
+          by simp
+        then have "?r ! i = (\<lfloor>numlist (nss ! idx)\<rfloor>, Suc (nllength (nss ! idx)))"
+          using take_drop_numlistlist'[OF idx] by simp
+        then show ?thesis
+          using lhs nlcontents_def by simp
+      next
+        case 3
+        then show ?thesis
+          using that tps1_def tps2_def jk by simp
+      qed
+    qed
+  qed
+qed
+
+definition "tps3 \<equiv> tps0
+  [j1 := (\<lfloor>nss\<rfloor>\<^sub>N\<^sub>L\<^sub>L, nlllength (take (Suc idx) nss)),
+   j2 := (\<lfloor>nss ! idx\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 11 + 2 * nllength dummy + 2 * (nllength (nss ! idx))"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: jk idx tps0 tps2_def tps3_def assms)
+  show "clean_tape (tps2 ! j2)"
+    using tps2_def jk clean_tape_nlcontents by simp
+qed
+
+definition "tps4 \<equiv> tps0
+  [j1 := nlltape' nss (Suc idx),
+   j2 := (\<lfloor>nss ! idx\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm4:
+  assumes "ttt = 12 + 2 * nllength dummy + 2 * (nllength (nss ! idx))"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def by (tform tps: jk idx tps0 tps3_def tps4_def assms)
+
+end  (* context *)
+
+end  (* locale turing_machine_nextract *)
+
+lemma transforms_tm_nextract_5I [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and k idx :: nat and nss :: "nat list list" and dummy :: "nat list"
+  assumes "j1 < k" "j2 < k" "0 < j1" "0 < j2" "j1 \<noteq> j2" "length tps = k"
+    and "idx < length nss"
+  assumes
+    "tps ! j1 = nlltape' nss idx"
+    "tps ! j2 = (\<lfloor>dummy\<rfloor>\<^sub>N\<^sub>L, 1)"
+  assumes "ttt = 12 + 2 * nllength dummy + 2 * (nllength (nss ! idx))"
+  assumes "tps' = tps
+    [j1 := nlltape' nss (Suc idx),
+     j2 := (\<lfloor>nss ! idx\<rfloor>\<^sub>N\<^sub>L, 1)]"
+  shows "transforms (tm_nextract \<sharp> j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_nextract_5 j1 j2 .
+  show ?thesis
+    using assms loc.tm4 loc.tps4_def loc.tm4_eq_tm_nextract by simp
+qed
+
+end
diff --git a/thys/Cook_Levin/Memorizing.thy b/thys/Cook_Levin/Memorizing.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Memorizing.thy
@@ -0,0 +1,1301 @@
+section \<open>Memorizing in states\label{s:tm-memorizing}\<close>
+
+theory Memorizing
+  imports Elementary
+begin
+
+text \<open>
+Some Turing machines are best described by allowing them to memorize values in
+their states.  For example, a TM that adds two binary numbers could memorize the
+carry bit in states. In the textbook definition of TMs, with arbitrary state
+space, this can be represented by a state space of the form $Q \times \{0, 1\}$,
+where 0 and 1 represent the memorized values. In our simplified definition of
+TMs, where the state space is an interval of natural numbers, this does not
+work. However, there is a workaround. Since we can have arbitrarily many
+tapes, we can make the TM store this value on an additional tape. Such a
+memorization tape could be used to write/read a symbol representing the
+memorized value. The tape head would never move on such a tape. The behavior of
+the TM can then depend on the memorized value.
+
+By adding several such tapes we can even have more than one value stored
+simultaneously as well. However, this method increases the number of tapes, and
+one part of the proof of the Cook-Levin theorem is showing that every TM can be
+simulated on a two-tape TM (see Chapter~\ref{s:oblivious-two-tape}).  How to
+remove such memorization tapes again without changing the behavior of the TM is
+the subject of this section.
+
+The straightforward idea is to multiply the states by the number of possible
+values. So if the original TM has $Q$ non-halting states and memorizes $G$
+different values, the new TM has $Q\cdot G$ non-halting states. It would be
+natural to map a pair $(q, g)$ of state and memorized value to $q \cdot G + g$
+or to $g \cdot Q + q$. However, there is a small technical problem.
+
+The memorization tape is initialized, like all tapes in a start configuration,
+with the head on the leftmost cell, which contains the start symbol. Thus the
+initially memorized value is the number~1 representing~$\triangleright$. The new
+TM must start in the start state, which we have fixed at~0. Thus the state-value
+pair $(0, 1)$ must be mapped to~0, which neither of the two natural mappings
+does.  Our workaround is to use the mapping $(q, g) \mapsto ((g - 1) \bmod G)
+\cdot Q + q$.
+
+The following function maps a Turing machine $M$ that memorizes one value from
+$\{0,\dots,G-1\}$ on its last tape to a TM that has one tape less, has $G$ times
+the number of non-halting states, and behaves just like $M$. The name
+``cartesian'' for this function is just a funny term I made up.
+\<close>
+
+definition cartesian :: "machine \<Rightarrow> nat \<Rightarrow> machine" where
+  "cartesian M G \<equiv>
+   concat
+    (map (\<lambda>h. map (\<lambda>q rs.
+                      let (q', as) = (M ! q) (rs @ [(h + 1) mod G])
+                      in (if q' = length M then G * length M else (fst (last as) + G - 1) mod G * length M + q',
+                          butlast as))
+              [0..<length M])
+     [0..<G])"
+
+lemma length_concat_const:
+  assumes "\<And>h. length (f h) = c"
+  shows "length (concat (map f [0..<G])) = G * c"
+  using assms by (induction G; simp)
+
+lemma length_cartesian: "length (cartesian M G) = G * length M"
+  using cartesian_def by (simp add: length_concat_const)
+
+lemma concat_nth:
+  assumes "\<And>h. length (f h) = c"
+    and "xs = concat (map f [0..<G])"
+    and "h < G"
+    and "q < c"
+  shows "xs ! (h * c + q) = f h ! q"
+  using assms(2,3)
+proof (induction G arbitrary: xs)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc G)
+  then have 1: "xs = concat (map f [0..<G]) @ f G" (is "xs = ?ys @ f G")
+    by simp
+  show ?case
+  proof (cases "h < G")
+    case True
+    then have "h * c \<le> (G - 1) * c"
+      by auto
+    then have "h * c \<le> G * c - c"
+      using True by (simp add: diff_mult_distrib)
+    then have "h * c + q \<le> G * c - c + q"
+      using assms(4) by simp
+    then have "h * c + q < G * c"
+      using assms(4) True \<open>h * c \<le> (G - 1) * c\<close> mult_eq_if by force
+    then have "h * c + q < length ?ys"
+      using length_concat_const assms by metis
+    then have "xs ! (h * c + q) = ?ys ! (h * c + q)"
+      using 1 by (simp add: nth_append)
+    then show ?thesis
+      using Suc True by simp
+  next
+    case False
+    then show ?thesis
+      using "1" Suc.prems(2) assms(1)
+      by (metis add_diff_cancel_left' length_concat_const less_SucE not_add_less1 nth_append)
+  qed
+qed
+
+lemma cartesian_at:
+  assumes "M' = cartesian M b" and "h < b" and "q < length M"
+  shows "(M' ! (h * length M + q)) rs =
+    (let (q', as) = (M ! q) (rs @ [(h + 1) mod b])
+     in (if q' = length M then b * length M else (fst (last as) + b - 1) mod b * length M + q',
+         butlast as))"
+proof -
+  define f where "f =
+   (\<lambda>h. map (\<lambda>q. \<lambda>rs.
+      let (q', as) = (M ! q) (rs @ [(h + 1) mod b])
+      in (if q' = length M then b * length M else (fst (last as) + b - 1) mod b * length M + q',
+          butlast as))
+    [0..<length M])"
+  then have "length (f h) = length M" for h
+    by simp
+  moreover have "M' = concat (map f [0..<b])"
+    using assms(1) cartesian_def f_def by simp
+  ultimately have "M' ! (h * length M + q) = f h ! q"
+    using concat_nth assms(2,3) by blast
+  then show ?thesis
+    using f_def by (simp add: assms(3))
+qed
+
+lemma concat_nth_ex:
+  assumes "\<And>h. length (f h) = c"
+    and "xs = concat (map f [0..<G])"
+    and "j < G * c"
+  shows "\<exists>i h. i < c \<and> h < G \<and> xs ! j = f h ! i"
+  using assms(2,3)
+proof (induction G arbitrary: xs)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc G)
+  then have *: "xs = concat (map f [0..<G]) @ f G" (is "xs = ?ys @ f G")
+    by simp
+  show ?case
+  proof (cases "j < G * c")
+  case True
+    then have "\<exists>i h. i < c \<and> h < G \<and> ?ys ! j = f h ! i"
+      using Suc by simp
+    then have "\<exists>i h. i < c \<and> h < Suc G \<and> ?ys ! j = f h ! i"
+      using less_SucI by blast
+    then have "\<exists>i h. i < c \<and> h < Suc G \<and> xs ! j = f h ! i"
+      using True * by (simp add: assms(1) length_concat_const nth_append)
+    then show ?thesis .
+  next
+    case False
+    then have "j \<ge> G * c"
+      by simp
+    define h where "h = G"
+    then have h: "h < Suc G"
+      by simp
+    define i where "i = j - G * c"
+    then have i: "i < c"
+      using False Suc.prems(2) by auto
+    have "xs ! j = f h ! i"
+      using assms by (simp add: "*" False h_def i_def length_concat_const nth_append)
+    then show ?thesis
+      using h i by auto
+  qed
+qed
+
+text \<open>
+The cartesian TM has one tape less than the original TM.
+\<close>
+
+lemma cartesian_num_tapes:
+  assumes "turing_machine (Suc k) G M"
+    and "M' = cartesian M b"
+    and "length rs = k"
+    and "q' < length M'"
+  shows "length (snd ((M' ! q') rs)) = k"
+proof -
+  define q where "q = q' mod length M"
+  define h where "h = q' div length M"
+  then have "h < b" "q' = h * length M + q"
+    using q_def assms(2) assms(4) length_cartesian less_mult_imp_div_less by auto
+  then have "q < length M"
+    using q_def assms(2,4) length_cartesian
+    by (metis add_lessD1 length_0_conv length_greater_0_conv mod_less_divisor mult_0_right)
+
+  have "(M' ! q') rs =
+    (let (q', as) = (M ! q) (rs @ [(h + 1) mod b])
+     in (if q' = length M then b * length M else (fst (last as) + b - 1) mod b * length M + q',
+         butlast as))"
+    using cartesian_at[OF assms(2) `h < b` `q < length M`] `q' = h * length M + q` by simp
+  then have "snd ((M' ! q') rs) = (let (q', as) = (M ! q) (rs @ [(h + 1) mod b]) in butlast as)"
+    by (metis (no_types, lifting) case_prod_unfold snd_conv)
+  then have *: "snd ((M' ! q') rs) = butlast (snd ((M ! q) (rs @ [(h + 1) mod b])))"
+    by (simp add: case_prod_unfold)
+
+  have "length (rs @ [(h + 1) mod b]) = Suc k"
+    using assms(3) by simp
+  then have "length (snd ((M ! q) (rs @ [(h + 1) mod b]))) = Suc k"
+    using assms(1) \<open>q < length M\<close> turing_commandD(1) turing_machine_def nth_mem by metis
+  then show ?thesis
+    using * by simp
+qed
+
+text \<open>
+The cartesian TM of a TM with alphabet $G$ also has the alphabet $G$ provided it
+memorizes at most $G$ values.
+\<close>
+
+lemma cartesian_tm:
+  assumes "turing_machine (Suc k) G M"
+    and "M' = cartesian M b"
+    and "k \<ge> 2"
+    and "b \<le> G"
+    and "b > 0"
+  shows "turing_machine k G M'"
+proof
+  show "G \<ge> 4"
+    using assms(1) turing_machine_def by simp
+  show "2 \<le> k"
+    using assms(3) .
+
+  define f where "f =
+   (\<lambda>h. map (\<lambda>i rs.
+              let (q, as) = (M ! i) (rs @ [(h + 1) mod b])
+              in (if q = length M then b * length M else (fst (last as) + b - 1) mod b * length M + q,
+                  butlast as))
+      [0..<length M])"
+  then have 1: "\<And>h. length (f h) = length M"
+    by simp
+  have 2: "M' = concat (map f [0..<b])"
+    using f_def assms(2) cartesian_def by simp
+
+  show "turing_command k (length M') G (M' ! j)" if "j < length M'" for j
+  proof
+    have 3: "j < b * length M"
+      using that by (simp add: assms(2) length_cartesian)
+    with 1 2 concat_nth_ex have "\<exists>i h. i < length M \<and> h < b \<and> M' ! j = f h ! i"
+      by blast
+    then obtain i h where
+      i: "i < length M" and
+      h: "h < b" and
+      cmd: "M' ! j = (\<lambda>rs.
+          let (q, as) = (M ! i) (rs @ [(h + 1) mod b])
+          in (if q = length M then b * length M else (fst (last as) + b - 1) mod b * length M + q,
+              butlast as))"
+      using f_def by auto
+    have "(h + 1) mod b < b"
+      using h by auto
+    then have modb: "(h + 1) mod b < G"
+      using assms(4) by linarith
+
+    have tc: "turing_command (Suc k) (length M) G (M ! i)"
+      using i assms(1) turing_machine_def by simp
+
+    show goal1: "\<And>gs. length gs = k \<Longrightarrow> length ([!!] (M' ! j) gs) = length gs"
+    proof -
+      fix gs :: "symbol list"
+      assume a: "length gs = k"
+      let ?q = "fst ((M ! i) (gs @ [(h + 1) mod b]))"
+      let ?as = "snd ((M ! i) (gs @ [(h + 1) mod b]))"
+      have "(M' ! j) gs =
+          (if ?q = length M then b * length M else (fst (last ?as) + b - 1) mod b * length M + ?q,
+          butlast ?as)"
+        using cmd by (metis (no_types, lifting) case_prod_unfold)
+      then have "[!!] (M' ! j) gs = butlast ?as"
+        by simp
+      moreover have "length ?as = Suc k"
+        using a turing_commandD(1)[OF tc] by simp
+      ultimately show "length ([!!] (M' ! j) gs) = length gs"
+        by (simp add: a)
+    qed
+    show "(M' ! j) gs [.] ja < G"
+      if "length gs = k" and
+        "(\<And>i. i < length gs \<Longrightarrow> gs ! i < G)" and
+        "ja < length gs"
+      for gs ja
+    proof -
+      let ?q = "fst ((M ! i) (gs @ [(h + 1) mod b]))"
+      let ?as = "snd ((M ! i) (gs @ [(h + 1) mod b]))"
+      have *: "(M' ! j) gs =
+          (if ?q = length M then b * length M else (fst (last ?as) + b - 1) mod b * length M + ?q,
+          butlast ?as)"
+        using cmd by (metis (no_types, lifting) case_prod_unfold)
+      have "length (gs @ [(h + 1) mod b]) = Suc k"
+        using that by simp
+      moreover have "(gs @ [(h + 1) mod b]) ! i < G" if "i < length (gs @ [(h + 1) mod b])" for i
+        using that by (metis \<open>\<And>i. i < length gs \<Longrightarrow> gs ! i < G\<close> modb
+          length_append_singleton less_Suc_eq nth_append nth_append_length)
+      ultimately have "(\<forall>j<length (gs @ [(h + 1) mod b]). (M ! i) (gs @ [(h + 1) mod b]) [.] j < G)"
+        using that turing_commandD(2)[OF tc] by simp
+      moreover have "butlast ?as ! ja = ?as ! ja"
+        by (metis * goal1 nth_butlast snd_conv that(1) that(3))
+      ultimately show ?thesis
+        using "*" that(3) by auto
+    qed
+    show "(M' ! j) gs [.] 0 = gs ! 0" if "length gs = k" and "0 < k" for gs
+    proof -
+      let ?q = "fst ((M ! i) (gs @ [(h + 1) mod b]))"
+      let ?as = "snd ((M ! i) (gs @ [(h + 1) mod b]))"
+      have *: "(M' ! j) gs =
+          (if ?q = length M then b * length M else (fst (last ?as) + b - 1) mod b * length M + ?q,
+            butlast ?as)"
+        using cmd by (metis (no_types, lifting) case_prod_unfold)
+      have "length (gs @ [(h + 1) mod b]) = Suc k"
+        using that by simp
+      then have "(M ! i) (gs @ [(h + 1) mod b]) [.] 0 = gs ! 0"
+        using that turing_commandD(3)[OF tc] by (simp add: nth_append)
+      then show ?thesis
+        using that * by (metis goal1 nth_butlast snd_conv)
+    qed
+    show "[*] ((M' ! j) gs) \<le> length M'" if "length gs = k" for gs
+    proof -
+      let ?q = "[*] ((M ! i) (gs @ [(h + 1) mod b]))"
+      let ?as = "snd ((M ! i) (gs @ [(h + 1) mod b]))"
+      have *: "(M' ! j) gs =
+        (if ?q = length M then b * length M else (fst (last ?as) + b - 1) mod b * length M + ?q,
+          butlast ?as)"
+        using cmd by (metis (no_types, lifting) case_prod_unfold)
+      have "length (gs @ [h]) = Suc k"
+        using that by simp
+      then have "?q \<le> length M"
+        using assms(1) i turing_commandD(4)[OF tc] by (metis length_append_singleton)
+      show ?thesis
+      proof (cases "?q = length M")
+        case True
+        then show ?thesis
+          using * by (simp add: assms(2) length_cartesian)
+      next
+        case False
+        then have "?q < length M"
+          using `?q \<le> length M` by simp
+        then have **: "[*] ((M' ! j) gs) = (fst (last ?as) + b - 1) mod b * length M + ?q"
+          using * by simp
+        have "(fst (last ?as) + b - 1) mod b \<le> b - 1"
+          using h less_imp_Suc_add by fastforce
+        have "(fst (last ?as) + b - 1) mod b * length M \<le> b * length M - length M"
+          using h less_imp_Suc_add by fastforce
+        then have "(fst (last ?as) + b - 1) mod b * length M + ?q \<le> b * length M - length M + ?q"
+          by simp
+        then have "(fst (last ?as) + b - 1) mod b * length M + ?q < b * length M"
+          using `?q < length M` 3 assms(5) by auto
+        then show ?thesis
+          using length_cartesian ** assms(2) by simp
+      qed
+    qed
+  qed
+qed
+
+text \<open>
+A special case of the previous lemma is $b = G$:
+\<close>
+
+corollary cartesian_tm':
+  assumes "turing_machine (Suc k) G M"
+    and "M' = cartesian M G"
+    and "k \<ge> 2"
+  shows "turing_machine k G M'"
+  using assms cartesian_tm by (metis gr0I not_numeral_le_zero order_refl turing_machine_def)
+
+text \<open>
+A cartesian TM assumes essentially the same configurations the original machine
+does, except that it has one tape less and the states have a greater number. We
+call these configurations ``squished'', another fancy made-up term alluding to
+the removal of one tape.
+
+\null
+\<close>
+
+definition squish :: "nat \<Rightarrow> nat \<Rightarrow> config \<Rightarrow> config" where
+  "squish G Q cfg \<equiv>
+     let (q, tps) = cfg
+     in (if q \<ge> Q then G * Q else ( |.| (last tps) + G - 1) mod G * Q + q, butlast tps)"
+
+lemma squish:
+  "squish G Q cfg =
+    (if fst cfg \<ge> Q then G * Q else ( |.| (last (snd cfg)) + G - 1) mod G * Q + fst cfg, butlast (snd cfg))"
+  using squish_def by (simp add: case_prod_beta)
+
+lemma squish_head_pos:
+  assumes "||cfg|| > 2"
+  shows "squish G Q cfg <#> 0 = cfg <#> 0"
+    and "squish G Q cfg <#> 1 = cfg <#> 1"
+  using assms squish
+    by (metis One_nat_def Suc_1 Suc_lessD length_butlast less_diff_conv nth_butlast plus_1_eq_Suc snd_conv,
+        metis One_nat_def Suc_1 length_butlast less_diff_conv nth_butlast plus_1_eq_Suc snd_conv)
+
+lemma mod_less:
+  fixes q Q h G :: nat
+  assumes "q < Q" and "0 < G"
+  shows "h mod G * Q + q < G * Q"
+proof -
+  have "h mod G \<le> G - 1"
+    using assms(2) less_Suc_eq_le by fastforce
+  then have "h mod G * Q \<le> (G - 1) * Q"
+    by simp
+  then have "h mod G * Q \<le> G * Q - Q"
+    by (simp add: left_diff_distrib')
+  then have "h mod G * Q + q \<le> G * Q - Q + q"
+    by simp
+  then have "h mod G * Q + q \<le> G * Q - 1"
+    using assms by simp
+  then show ?thesis
+    by (metis One_nat_def Suc_pred add.left_neutral add.right_neutral add_mono_thms_linordered_semiring(1)
+      assms le_simps(2) linorder_not_less mult_pos_pos zero_le)
+qed
+
+lemma squish_halt_state:
+  assumes "G > 0" and "fst cfg \<le> Q"
+  shows "fst (squish G Q cfg) = G * Q \<longleftrightarrow> fst cfg = Q"
+proof
+  show "fst cfg = Q \<Longrightarrow> fst (squish G Q cfg) = G * Q"
+    by (simp add: squish)
+  show "fst (squish G Q cfg) = G * Q \<Longrightarrow> fst cfg = Q"
+  proof (rule ccontr)
+    assume a: "fst (squish G Q cfg) = G * Q"
+    assume "fst cfg \<noteq> Q"
+    then have "fst cfg < Q"
+      using assms(2) by simp
+    then have "fst (squish G Q cfg) = ( |.| (last (snd cfg)) + G - 1) mod G * Q + fst cfg"
+      using squish by simp
+    also have "... < G * Q"
+      using mod_less[OF `fst cfg < Q` assms(1)] by simp
+    finally have "fst (squish G Q cfg) < G * Q" .
+    with a show False
+      by simp
+  qed
+qed
+
+lemma butlast_replicate: "butlast (replicate k x) = replicate (k - Suc 0) x"
+  by (intro nth_equalityI) (simp_all add: nth_butlast)
+
+lemma squish_start_config: "G \<ge> 4 \<Longrightarrow> k \<ge> 2 \<Longrightarrow> squish G Q (start_config (Suc k) zs) = start_config k zs"
+  using squish_def start_config_def by (simp add: butlast_replicate)
+
+text \<open>
+The cartesian Turing machine only works properly if the original TM never moves
+its head on the last tape. We call a tape of a TM $M$ \emph{immobile} if $M$
+never moves the head on the tape.
+\<close>
+
+definition immobile :: "machine \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
+ "immobile M j k \<equiv> \<forall>q rs. q < length M \<longrightarrow> length rs = k \<longrightarrow> (M ! q) rs [~] j = Stay"
+
+lemma immobileI [intro]:
+  assumes "\<And>q rs. q < length M \<Longrightarrow> length rs = k \<Longrightarrow> (M ! q) rs [~] j = Stay"
+  shows "immobile M j k"
+  using immobile_def assms by simp
+
+text \<open>
+If the head never moves on tape $k$, the head will stay in position $0$.
+\<close>
+
+lemma immobile_head_pos_proper:
+  assumes "proper_machine (Suc k) M"
+    and "immobile M k (Suc k)"
+    and "||cfg|| = Suc k"
+  shows "execute M cfg t <#> k = cfg <#> k"
+proof (induction t)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc t)
+  have "execute M cfg (Suc t) = exe M (execute M cfg t)"
+    (is "_ = exe M ?cfg")
+    by simp
+  show ?case
+  proof (cases "fst ?cfg \<ge> length M")
+    case True
+    then have "exe M ?cfg = ?cfg"
+      using exe_ge_length by simp
+    then show ?thesis
+      by (simp add: Suc.IH)
+  next
+    case False
+    let ?cmd = "M ! (fst ?cfg)"
+    let ?rs = "config_read ?cfg"
+    have "exe M ?cfg = sem ?cmd ?cfg"
+      using False exe_def by simp
+    moreover have "proper_command (Suc k) (M ! (fst ?cfg))"
+      using assms(1) False by simp
+    ultimately have "exe M ?cfg <!> k = act (snd (?cmd ?rs) ! k) (?cfg <!> k)"
+      using assms execute_num_tapes_proper lessI sem_snd by presburger
+    then show ?thesis
+      using False Suc act assms execute_num_tapes_proper immobile_def read_length by simp
+  qed
+qed
+
+lemma immobile_head_pos:
+  assumes "turing_machine (Suc k) G M"
+    and "immobile M k (Suc k)"
+    and "||cfg|| = Suc k"
+  shows "execute M cfg t <#> k = cfg <#> k"
+proof (induction t)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc t)
+  have "execute M cfg (Suc t) = exe M (execute M cfg t)"
+    (is "_ = exe M ?cfg")
+    by simp
+  show ?case
+  proof (cases "fst ?cfg \<ge> length M")
+    case True
+    then have "exe M ?cfg = ?cfg"
+      using exe_ge_length by simp
+    then show ?thesis
+      by (simp add: Suc.IH)
+  next
+    case False
+    let ?cmd = "M ! (fst ?cfg)"
+    let ?rs = "config_read ?cfg"
+    have "exe M ?cfg = sem ?cmd ?cfg"
+      using False exe_def by simp
+    moreover have "proper_command (Suc k) (M ! (fst ?cfg))"
+      using assms(1) False by (metis turing_commandD(1) linorder_not_le turing_machineD(3))
+    ultimately have "exe M ?cfg <!> k = act (snd (?cmd ?rs) ! k) (?cfg <!> k)"
+      using assms execute_num_tapes lessI sem_snd by presburger
+    then show ?thesis
+      using False Suc act assms execute_num_tapes immobile_def read_length by simp
+  qed
+qed
+
+text \<open>
+Sequentially combining two Turing machines with an immobile tape yields a Turing
+machine with the same immobile tape.
+\<close>
+
+lemma immobile_sequential:
+  assumes "turing_machine k G M1"
+    and "turing_machine k G M2"
+    and "immobile M1 j k"
+    and "immobile M2 j k"
+  shows "immobile (M1 ;; M2) j k"
+proof
+  let ?M = "M1 ;; M2"
+  fix q :: nat and rs :: "symbol list"
+  assume q: "q < length ?M" and rs: "length rs = k"
+  show "(?M ! q) rs [~] j = Stay"
+  proof (cases "q < length M1")
+    case True
+    then have "?M ! q = M1 ! q"
+      by (simp add: nth_append turing_machine_sequential_def)
+    then show ?thesis
+      using assms(3) immobile_def by (simp add: True rs)
+  next
+    case False
+    then have "?M ! q = relocate_cmd (length M1) (M2 ! (q - length M1))"
+      using q turing_machine_sequential_nth' by simp
+    then show ?thesis
+      using relocate_cmd_head False assms(4) q rs length_turing_machine_sequential immobile_def
+      by simp
+  qed
+qed
+
+text \<open>
+A loop also keeps a tape immobile.
+\<close>
+
+lemma immobile_loop:
+  assumes "turing_machine k G M1"
+    and "turing_machine k G M2"
+    and "immobile M1 j k"
+    and "immobile M2 j k"
+    and "j < k"
+  shows "immobile (WHILE M1 ; cond DO M2 DONE) j k"
+proof
+  let ?loop = "WHILE M1 ; cond DO M2 DONE"
+  have "?loop =
+      M1 @
+      [cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)] @
+      (relocate (length M1 + 1) M2) @
+      [cmd_jump (\<lambda>_. True) 0 0]"
+      (is "_ = M1 @ [?a] @ ?bs @ [?c]")
+    using turing_machine_loop_def by simp
+  then have loop: "?loop = (M1 @ [?a]) @ (?bs @ [?c])"
+    by simp
+  fix q :: nat
+  assume q: "q < length ?loop"
+  fix rs :: "symbol list"
+  assume rs: "length rs = k"
+  consider
+      "q < length M1"
+    | "q = length M1"
+    | "length M1 < q \<and> q \<le> length M1 + length M2"
+    | "length M1 + length M2 < q"
+    by linarith
+  then show "(?loop ! q) rs [~] j = Stay"
+  proof (cases)
+    case 1
+    then have "?loop ! q = M1 ! q"
+      by (simp add: nth_append turing_machine_loop_def)
+    then show ?thesis
+      using assms(3) 1 rs immobile_def by simp
+  next
+    case 2
+    then have "?loop ! q = cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)"
+      by (simp add: nth_append turing_machine_loop_def)
+    then show ?thesis
+      using rs cmd_jump_def assms(5) by simp
+  next
+    case 3
+    then have "?loop ! q = (?bs @ [?c]) ! (q - (length M1 + 1))"
+      using nth_append[of "M1 @ [?a]" "?bs @ [?c]"] loop by simp
+    moreover have "q - (length M1 + 1) < length ?bs"
+      using 3 length_relocate by auto
+    ultimately have "?loop ! q = ?bs ! (q - (length M1 + 1))"
+      by (simp add: nth_append)
+    then show ?thesis
+      using assms(4,5) relocate_cmd_head 3 relocate rs immobile_def by auto
+  next
+    case 4
+    then have "q = length M1 + length M2 + 1"
+      using q turing_machine_loop_len by simp
+    then have "?loop ! q = ?c"
+      using turing_machine_loop_def
+      by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 append_assoc length_append list.size(3)
+        list.size(4) nth_append_length plus_nat.simps(2) length_relocate)
+    then show ?thesis
+      using rs cmd_jump_def assms(5) by simp
+  qed
+qed
+
+text \<open>
+An immobile tape stays immobile when further tapes are appended. We only need
+this for the special case of two-tape Turing machines.
+\<close>
+
+lemma immobile_append_tapes:
+  assumes "j < k" and "j > 1" and "k \<ge> 2" and "turing_machine 2 G M"
+  shows "immobile (append_tapes 2 k M) j k"
+proof
+  let ?M = "append_tapes 2 k M"
+  fix q :: nat
+  assume q: "q < length ?M"
+  fix rs :: "symbol list"
+  assume rs: "length rs = k"
+  have "q < length M"
+    using assms q by (metis length_append_tapes)
+  show "(?M ! q) rs [~] j = Stay"
+  proof -
+    have "(?M ! q) rs =
+         (fst ((M ! q) (take 2 rs)), snd ((M ! q) (take 2 rs)) @ (map (\<lambda>j. (rs ! j, Stay)) [2..<k]))"
+      using append_tapes_nth by (simp add: append_tapes_nth \<open>q < length M\<close> rs)
+    then have "(?M ! q) rs [~] j =
+         snd ((snd ((M ! q) (take 2 rs)) @ (map (\<lambda>j. (rs ! j, Stay)) [2..<k])) ! j)"
+      using assms by simp
+    also have "... = snd ((map (\<lambda>j. (rs ! j, Stay)) [2..<k]) ! (j - 2))"
+    proof -
+      have "length (take 2 rs) = 2"
+        using rs assms(3) by simp
+      then have "length ([!!] (M ! q) (take 2 rs)) = 2"
+        using assms rs by (metis turing_commandD(1) \<open>q < length M\<close> nth_mem turing_machine_def)
+      then show ?thesis
+        using nth_append[of "snd ((M ! q) (take 2 rs))" "map (\<lambda>j. (rs ! j, Stay)) [2..<k]" j] assms by simp
+    qed
+    finally show ?thesis
+      using assms(1,2) by simp
+  qed
+qed
+
+text \<open>
+For the elementary Turing machines we introduced in
+Section~\ref{s:tm-elementary} all tapes are immobile but the ones given as
+parameters.
+\<close>
+
+lemma immobile_tm_trans_until:
+  assumes "j \<noteq> j1" and "j \<noteq> j2" and "j < k"
+  shows "immobile (tm_trans_until j1 j2 H f) j k"
+  using assms tm_trans_until_def cmd_trans_until_def by auto
+
+lemma immobile_tm_ltrans_until:
+  assumes "j \<noteq> j1" and "j \<noteq> j2" and "j < k"
+  shows "immobile (tm_ltrans_until j1 j2 H f) j k"
+  using assms tm_ltrans_until_def cmd_ltrans_until_def by auto
+
+lemma immobile_tm_left_until:
+  assumes "j \<noteq> j'" and "j < k"
+  shows "immobile (tm_left_until H j') j k"
+  using assms tm_left_until_def cmd_left_until_def by auto
+
+lemma immobile_tm_start:
+  assumes "j \<noteq> j'" and "j < k"
+  shows "immobile (tm_start j') j k"
+  using tm_start_def immobile_tm_left_until[OF assms] by metis
+
+lemma immobile_tm_write:
+  assumes "j < k"
+  shows "immobile (tm_write j' h) j k"
+  using assms tm_write_def cmd_write_def by auto
+
+lemma immobile_tm_write_many:
+  assumes "j < k"
+  shows "immobile (tm_write_many J h) j k"
+  using assms tm_write_many_def cmd_write_many_def by auto
+
+lemma immobile_tm_right:
+  assumes "j \<noteq> j'" and "j < k"
+  shows "immobile (tm_right j') j k"
+  using assms tm_right_def cmd_right_def by auto
+
+lemma immobile_tm_rtrans:
+  assumes "j \<noteq> j'" and "j < k"
+  shows "immobile (tm_rtrans j' f) j k"
+  using assms tm_rtrans_def cmd_rtrans_def by auto
+
+lemma immobile_tm_left:
+  assumes "j \<noteq> j'" and "j < k"
+  shows "immobile (tm_left j') j k"
+  using assms tm_left_def cmd_left_def by auto
+
+lemma mod_inc_dec: "(h::nat) < G \<Longrightarrow> ((h + G - 1) mod G + 1) mod G = h"
+  using mod_Suc_eq by auto
+
+lemma last_length: "length xs = Suc k \<Longrightarrow> last xs = xs ! k"
+  by (metis diff_Suc_1 last_conv_nth length_0_conv nat.simps(3))
+
+text \<open>
+The tapes used for memorizing the values have blank symbols in every cell but
+possibly for the leftmost cell. In keeping with funny names, we call such tapes
+@{term onesie} tapes.
+\<close>
+
+definition onesie :: "symbol \<Rightarrow> tape" ("\<lceil>_\<rceil>") where
+  "\<lceil>h\<rceil> \<equiv> (\<lambda>x. if x = 0 then h else \<box>, 0)"
+
+lemma onesie_1: "\<lceil>\<triangleright>\<rceil> = (\<lfloor>[]\<rfloor>, 0)"
+  unfolding onesie_def contents_def by auto
+
+lemma onesie_read [simp]: "|.| \<lceil>h\<rceil> = h"
+  using onesie_def by simp
+
+lemma onesie_write: "\<lceil>x\<rceil> |:=| y = \<lceil>y\<rceil>"
+  using onesie_def by auto
+
+lemma act_onesie: "act (h, Stay) \<lceil>x\<rceil> = \<lceil>h\<rceil>"
+  using onesie_def by auto
+
+text \<open>
+We now consider the semantics of cartesian Turing machines. Roughly speaking, a
+cartesian TM assumes the squished configurations of the original TM.  A crucial
+assumption here is that the original TM only ever memorizes a symbol from a
+certain range of symbols, with one relaxation: when switching to the halting
+state, any symbol may be written to the memorization tape. The reason is that
+there is only one halting state even for the cartesian TM, and thus the halting
+state is not subject to the mapping of states implemented by the @{const
+cartesian} operation.
+
+In the following lemma, @{text "\<lceil>\<triangleright>\<rceil>"} is the memorization tape. It has the
+start symbol because in the start configuration all tapes have the start symbol
+in the leftmost cell.
+\<close>
+
+lemma cartesian_execute:
+  assumes "turing_machine (Suc k) G M"
+    and "immobile M k (Suc k)"
+    and "k \<ge> 2"
+    and "b > 0"
+    and "length tps = k"
+    and "\<And>t. execute M (0, tps @ [\<lceil>\<triangleright>\<rceil>]) t <.> k < b \<or> fst (execute M (0, tps @ [\<lceil>\<triangleright>\<rceil>]) t) = length M"
+  shows "execute (cartesian M b) (0, tps) t =
+    squish b (length M) (execute M (0, tps @ [\<lceil>\<triangleright>\<rceil>]) t)"
+proof (induction t)
+  case 0
+  then show ?case
+    using squish by simp
+next
+  case (Suc t)
+  let ?M' = "cartesian M b"
+  have len: "length ?M' = b * length M"
+    using length_cartesian by simp
+  let ?cfg = "execute M (0, tps @ [\<lceil>\<triangleright>\<rceil>]) t"
+  have 1: "?cfg <#> k = 0"
+    using assms(1,2,5) immobile_head_pos onesie_def by auto
+  have 3: "||?cfg|| = Suc k"
+    using assms(1,5) execute_num_tapes by auto
+  let ?Q = "length M"
+  let ?squish = "squish b ?Q"
+  let ?scfg = "?squish ?cfg"
+  obtain q tps where qtps: "?cfg = (q, tps)"
+    by fastforce
+  have "length tps = Suc k"
+    using 3 qtps by simp
+  then have last: "last tps = tps ! k"
+    using assms(4) by (metis diff_Suc_1 last_conv_nth length_greater_0_conv zero_less_Suc)
+
+  have "exe ?M' ?scfg = ?squish (exe M ?cfg)"
+  proof (cases "q \<ge> length M")
+    case True
+    then have t1: "exe M ?cfg = ?cfg"
+      using exe_def qtps by auto
+    have "?scfg = (b * length M, butlast tps)"
+      using True squish qtps by simp
+    then have "exe ?M' ?scfg = ?scfg"
+      using exe_def len by simp
+    with t1 show ?thesis
+      by simp
+  next
+    case False
+    then have scfg: "?scfg = (( |.| (last tps) + b - 1) mod b * length M + q, butlast tps)"
+        (is "_ = (?q, _)")
+      using squish qtps by simp
+    moreover have q_less: "?q < length ?M'"
+      using mod_less False length_cartesian assms(4) by simp
+    ultimately have 9: "exe ?M' ?scfg = sem (?M' ! ?q) ?scfg"
+      using exe_def by simp
+    let ?cmd' = "?M' ! ?q"
+    let ?h = "( |.| (last tps) + b - 1) mod b"
+    have "q < length M"
+      using False by simp
+    then have 4: "|.| (last tps) < b"
+      using assms last qtps False by (metis fst_conv less_not_refl3 snd_conv)
+    have h_less: "?h < b"
+      using 4 by simp
+    then have "?cmd' \<equiv> \<lambda>rs.
+        (let (q', as) = (M ! q) (rs @ [(?h + 1) mod b])
+         in (if q' = length M then b * length M else (fst (last as) + b - 1) mod b * length M + q',
+             butlast as))"
+      using cartesian_at[OF _ h_less `q < length M`] by presburger
+    then have cmd': "?cmd' \<equiv> \<lambda>rs.
+        (let (q', as) = (M ! q) (rs @ [ |.| (last tps)])
+         in (if q' = length M then b * length M else (fst (last as) + b - 1) mod b * length M + q',
+             butlast as))"
+      using mod_inc_dec[OF 4] by simp
+    let ?rs' = "config_read ?scfg"
+    have 10: "sem ?cmd' ?scfg =
+        (let (newstate, as) = ?cmd' ?rs'
+         in (newstate, map (\<lambda>(a, tp). act a tp) (zip as (butlast tps))))"
+      using scfg by (simp add: sem_def)
+    let ?newstate' = "fst (?cmd' ?rs')"
+    let ?as' = "snd (?cmd' ?rs')"
+    have 11: "sem ?cmd' ?scfg =
+         (?newstate', map (\<lambda>(a, tp). act a tp) (zip ?as' (butlast tps)))"
+      using 10 by (simp add: case_prod_beta)
+    with 9 have lhs: "exe ?M' ?scfg =
+         (?newstate', map (\<lambda>(a, tp). act a tp) (zip ?as' (butlast tps)))"
+      by simp
+
+    let ?cmd = "M ! q"
+    let ?rs = "config_read ?cfg"
+    let ?newstate = "fst (?cmd ?rs)"
+    let ?as = "snd (?cmd ?rs)"
+    have "?squish (exe M ?cfg) = ?squish (sem ?cmd ?cfg)"
+      using qtps False exe_def by simp
+    also have "... = ?squish (?newstate, map (\<lambda>(a, tp). act a tp) (zip ?as (snd ?cfg)))"
+      by (metis sem)
+    also have "... = ?squish (?newstate, map (\<lambda>(a, tp). act a tp) (zip ?as tps))"
+        (is "_ = ?squish (_, ?tpsSuc)")
+      using qtps by simp
+    also have "... =
+      (if ?newstate \<ge> ?Q then b * ?Q else ( |.| (last ?tpsSuc) + b - 1) mod b * ?Q + ?newstate,
+       butlast ?tpsSuc)"
+      using squish by simp
+    finally have rhs: "?squish (exe M ?cfg) =
+      (if ?newstate \<ge> ?Q then b * ?Q else ( |.| (last ?tpsSuc) + b - 1) mod b * ?Q + ?newstate,
+       butlast ?tpsSuc)" .
+
+    have "read (butlast tps) @ [ |.| (last tps)] = read tps"
+      using `length tps = Suc k` read_def
+      by (metis (no_types, lifting) last_map length_0_conv map_butlast map_is_Nil_conv old.nat.distinct(1) snoc_eq_iff_butlast)
+    then have rs'_read: "?rs' @ [ |.| (last tps)] = read tps"
+      using scfg by simp
+
+    have fst: "fst (?cmd' ?rs') =
+      (if ?newstate \<ge> ?Q then b * ?Q else ( |.| (last ?tpsSuc) + b - 1) mod b * ?Q + ?newstate)"
+    proof -
+      have "fst (?cmd' ?rs') \<equiv> fst (
+        (let (q', as) = (M ! q) (?rs' @ [ |.| (last tps)])
+         in (if q' = length M then b * length M else (fst (last as) + b - 1) mod b * length M + q',
+             butlast as)))"
+        using cmd' by simp
+      then have "fst (?cmd' ?rs') =
+         (if fst ((M ! q) (?rs' @ [ |.| (last tps)])) = length M
+          then b * length M
+          else (fst (last (snd ((M ! q) (?rs' @ [ |.| (last tps)])))) + b - 1) mod b * length M +
+            fst ((M ! q) (?rs' @ [ |.| (last tps)])))"
+        by (auto simp add: Let_def split_beta)
+      then have lhs: "fst (?cmd' ?rs') =
+         (if fst ((M ! q) (read tps)) = length M
+          then b * ?Q
+          else (fst (last (snd ((M ! q) (read tps)))) + b - 1) mod b * ?Q + fst ((M ! q) (read tps)))"
+        using rs'_read by simp
+
+      have *: "|.| (last (map (\<lambda>(a, tp). act a tp) (zip ?as tps))) = fst (last (snd ((M ! q) (read tps))))"
+      proof -
+        have "length ?as = Suc k"
+          using "3" \<open>q < length M\<close> assms(1) read_length turing_machine_def
+          by (metis turing_commandD(1) nth_mem)
+        then have "length (map (\<lambda>(a, tp). act a tp) (zip ?as tps)) = Suc k"
+          using `length tps = Suc k` by simp
+        then have "last (map (\<lambda>(a, tp). act a tp) (zip ?as tps)) =
+            (map (\<lambda>(a, tp). act a tp) (zip ?as tps)) ! k"
+          using last_length by blast
+        moreover have "proper_command (Suc k) ?cmd"
+          using \<open>q < length M\<close> assms(1) turing_machine_def turing_commandD(1) nth_mem by blast
+        ultimately have 1: "last (map (\<lambda>(a, tp). act a tp) (zip ?as tps)) = act (?as ! k) (tps ! k)"
+          using "3" \<open>q < length M\<close> assms(1) qtps sem' sem_snd_tm by auto
+
+        have "snd (?as ! k) = Stay"
+          using assms(2) `length tps = Suc k` "3" \<open>q < length M\<close> read_length immobile_def
+          by simp
+        then have "act (?as ! k) (tps ! k) = (tps ! k) |:=| (fst (?as ! k))"
+          by (metis act_Stay' prod.collapse)
+        then have "|.| (act (?as ! k) (tps ! k)) = fst (?as ! k)"
+          by simp
+        with 1 have 2: "|.| (last (map (\<lambda>(a, tp). act a tp) (zip ?as tps))) = fst (?as ! k)"
+          by simp
+
+        have "fst (last (snd ((M ! q) (read tps)))) = fst (last ?as)"
+          using qtps by simp
+        then have "fst (last (snd ((M ! q) (read tps)))) = fst (?as ! k)"
+          using `length ?as = Suc k` by (simp add: last_length)
+        with 2 show ?thesis
+          by simp
+      qed
+
+      have "(if fst ((M ! q) ?rs) \<ge> ?Q
+         then b * ?Q
+         else ( |.| (last ?tpsSuc) + b - 1) mod b * ?Q + fst ((M ! q) ?rs)) =
+        (if fst ((M ! q) (read tps)) \<ge> ?Q
+         then b * ?Q
+         else ( |.| (last ?tpsSuc) + b - 1) mod b * ?Q + fst ((M ! q) (read tps)))"
+        using qtps by simp
+      also have "... =
+        (if fst ((M ! q) (read tps)) = ?Q
+         then b * ?Q
+         else ( |.| (last ?tpsSuc) + b - 1) mod b * ?Q + fst ((M ! q) (read tps)))"
+        using assms(1) turing_machine_def
+        by (metis (mono_tags, lifting) "3" turing_commandD(4) \<open>q < length M\<close> le_antisym nth_mem prod.sel(2) qtps read_length)
+      also have "... =
+         (if fst ((M ! q) (read tps)) = length M
+          then b * ?Q
+          else (fst (last (snd ((M ! q) (read tps)))) + b - 1) mod b * ?Q + fst ((M ! q) (read tps)))"
+        using * by simp
+      finally show ?thesis
+        using lhs by simp
+    qed
+
+    have snd: "map (\<lambda>(a, tp). act a tp) (zip ?as' (butlast tps)) =
+        butlast (map (\<lambda>(a, tp). act a tp) (zip ?as tps))"
+    proof (rule nth_equalityI)
+      let ?lhs = "map (\<lambda>(a, tp). act a tp) (zip ?as' (butlast tps))"
+      let ?rhs = "butlast (map (\<lambda>(a, tp). act a tp) (zip ?as tps))"
+      have "||?scfg|| = k"
+        using \<open>length tps = Suc k\<close> scfg by simp
+      then have "length ?rs' = k"
+        by (simp add: read_length)
+      then have "length ?as' = k"
+        using cartesian_num_tapes q_less assms(1,3) by simp
+      moreover have "length (butlast tps) = k"
+        using `length tps = Suc k` by simp
+      ultimately have "length ?lhs = k"
+        by simp
+
+      have "length ?as = Suc k"
+        using \<open>length tps = Suc k\<close> \<open>q < length M\<close> assms(1) qtps read_length turing_machine_def
+        by (metis "3" turing_commandD(1) nth_mem)
+      then have "length ?rhs = k"
+        using `length tps = Suc k` by simp
+      then show "length ?lhs = length ?rhs"
+        using `length ?lhs = k` by simp
+
+      show "?lhs ! j = ?rhs ! j" if "j < length ?lhs" for j
+      proof -
+        have "j < k"
+          using that `length ?lhs = k` by auto
+
+        have "length (butlast tps) = k"
+          using \<open>length (butlast tps) = k\<close> by blast
+        then have lhs: "?lhs ! j = act (?as' ! j) (tps ! j)"
+          using `j < k` `length ?as' = k` by (simp add: nth_butlast)
+
+        have rhs: "?rhs ! j = act (?as ! j) (tps ! j)"
+          using `j < k` `length ?as = Suc k` `length tps = Suc k` by (simp add: nth_butlast)
+
+        have "?as' ! j = snd (
+            (let (q', as) = (M ! q) (?rs' @ [ |.| (last tps)])
+             in (if q' = length M then b * length M else (fst (last as) + b - 1) mod b * length M + q',
+                 butlast as))) ! j"
+          using cmd' by simp
+        also have "... = snd (
+            ((if fst ((M ! q) (?rs' @ [ |.| (last tps)])) = length M
+              then b * length M
+              else (fst (last (snd ((M ! q) (?rs' @ [ |.| (last tps)])))) + b - 1) mod b * length M + fst ((M ! q) (?rs' @ [ |.| (last tps)])),
+             butlast (snd ((M ! q) (?rs' @ [ |.| (last tps)])))))) ! j"
+          by (metis (no_types, lifting) case_prod_unfold)
+        also have "... = butlast (snd ((M ! q) (?rs' @ [ |.| (last tps)]))) ! j"
+          by simp
+        finally have "?as' ! j = butlast (snd ((M ! q) (?rs' @ [ |.| (last tps)]))) ! j" .
+        then have as'_j: "?as' ! j = butlast (snd ((M ! q) (read tps))) ! j"
+          using rs'_read by simp
+
+        have "?as ! j = snd ((M ! q) (read tps)) ! j"
+          using qtps by simp
+        moreover have "?as ! j = (butlast ?as) ! j"
+          using `length ?as = Suc k` `j < k` by (simp add: nth_butlast)
+        ultimately have "?as ! j = butlast (snd ((M ! q) (read tps))) ! j"
+          using qtps by simp
+        then have "?as ! j = ?as' ! j"
+          using as'_j by simp
+        then show ?thesis
+          using lhs rhs by simp
+      qed
+    qed
+    then show ?thesis
+      using fst lhs rhs by simp
+  qed
+  then show ?case
+    by (simp add: Suc.IH)
+qed
+
+text \<open>
+One assumption of the previous lemma is that the memorization tape can only
+contain a symbol from a certain range (except in the halting state). One way to
+achieve this is for the Turing machine to only ever write a symbol from that
+range to the memorization tape (or switch to the halting state). Formally:
+\<close>
+
+definition bounded_write :: "machine \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
+  "bounded_write M k b \<equiv>
+    \<forall>q rs. q < length M \<longrightarrow> length rs = Suc k \<longrightarrow> (M ! q) rs [.] k < b \<or> fst ((M ! q) rs) = length M"
+
+text \<open>
+The advantage of @{const bounded_write} is that it is a relatively easy to prove
+property of a Turing machine. With @{const bounded_write} the previous lemma,
+@{thm [source] cartesian_execute}, turns into the following one, where the
+assumption $b > 0$ becomes $b > 1$ because initially the memorization tape has
+the start symbol, represented by the number~1.
+
+\null
+\<close>
+
+lemma cartesian_execute_onesie:
+  assumes "turing_machine (Suc k) G M"
+    and "immobile M k (Suc k)"
+    and "k \<ge> 2"
+    and "b > 1"
+    and "length tps = k"
+    and "bounded_write M k b"
+  shows "execute (cartesian M b) (0, tps) t = squish b (length M) (execute M (0, tps @ [\<lceil>\<triangleright>\<rceil>]) t)"
+proof -
+  have "execute M (0, tps @ [\<lceil>\<triangleright>\<rceil>]) t <.> k < b \<or> fst (execute M (0, tps @ [\<lceil>\<triangleright>\<rceil>]) t) = length M"
+    for t
+  proof (induction t)
+    case 0
+    then show ?case
+      using assms by auto
+  next
+    case (Suc t)
+    let ?tps = "tps @ [\<lceil>\<triangleright>\<rceil>]"
+    have *: "execute M (0, ?tps) (Suc t) = exe M (execute M (0, ?tps) t)"
+        (is "_ = exe M ?cfg")
+      by simp
+    show ?case
+    proof (cases "fst ?cfg \<ge> length M")
+      case True
+      then show ?thesis
+        using * Suc exe_ge_length by presburger
+    next
+      case False
+      let ?rs = "config_read ?cfg"
+      let ?q = "fst ?cfg"
+      let ?tps = "snd ?cfg"
+      have len: "length ?tps = Suc k"
+        using assms(1,5) execute_num_tapes by simp
+      have pos: "?tps :#: k = 0"
+        using assms immobile_head_pos onesie_def by auto
+      have lenrs: "length ?rs = Suc k"
+        using len read_length by simp
+      have **: "exe M ?cfg = sem (M ! ?q) ?cfg"
+        using False exe_lt_length by simp
+      have ***: "sem (M ! ?q) ?cfg <!> k = act ((M ! ?q) ?rs [!] k) (?tps ! k)"
+      proof -
+        have "proper_command (Suc k) (M ! ?q)"
+          by (metis False turing_commandD(1) assms(1) le_less_linear nth_mem turing_machine_def)
+        then show ?thesis
+          using len sem_snd by blast
+      qed
+
+      have "(M ! ?q) ?rs [~] k = Stay"
+        using assms(2) lenrs False immobile_def by simp
+      then have act: "act ((M ! ?q) ?rs [!] k) (?tps ! k) = (?tps ! k) |:=| ((M ! ?q) ?rs [.] k)"
+        using act_Stay' by (metis prod.collapse)
+       show ?thesis
+      proof (cases "(M ! ?q) ?rs [.] k < b")
+        case True
+        then have "sem (M ! ?q) ?cfg <.> k < b"
+          using pos *** act by simp
+        then show ?thesis
+          using * ** by simp
+      next
+        case halt: False
+        then have "fst ((M ! ?q) ?rs) = length M"
+          using assms(6) bounded_write_def lenrs False le_less_linear by blast
+        then show ?thesis
+          using * ** sem_fst by simp
+      qed
+    qed
+  qed
+  then show ?thesis
+    using cartesian_execute[OF assms(1-3) _ assms(5)] assms(4) by simp
+qed
+
+text \<open>
+In the following lemma, the term @{term "\<lceil>c\<rceil>"} reflects the fact that in
+the halting state the memorized symbol can be anything.
+\<close>
+
+lemma cartesian_transforms_onesie:
+  assumes "turing_machine (Suc k) G M"
+    and "immobile M k (Suc k)"
+    and "k \<ge> 2"
+    and "b > 1"
+    and "bounded_write M k b"
+    and "length tps = k"
+    and "transforms M (tps @ [\<lceil>\<triangleright>\<rceil>]) t (tps' @ [\<lceil>c\<rceil>])"
+  shows "transforms (cartesian M b) tps t tps'"
+proof -
+  have "execute M (0, tps @ [\<lceil>\<triangleright>\<rceil>]) t = (length M, tps' @ [\<lceil>c\<rceil>])"
+    using transforms_def transits_def by (metis (no_types, lifting) assms(7) execute_after_halting_ge fst_conv)
+  then have "execute (cartesian M b) (0, tps) t = squish b (length M) (length M, tps' @ [\<lceil>c\<rceil>])"
+    using assms cartesian_execute_onesie by simp
+  moreover from this have "fst (execute (cartesian M b) (0, tps) t) = b * length M"
+    using squish_halt_state[of b _ "length M"] One_nat_def assms(4) by simp
+  ultimately have "execute (cartesian M b) (0, tps) t = (b * length M, tps')"
+    using squish by simp
+  then show ?thesis
+    using transforms_def transits_def length_cartesian by auto
+qed
+
+text \<open>
+A Turing machine with alphabet $G$, when started on a symbol sequence over $G$,
+is guaranteed to only write symbols from $G$ to any of its tapes, including any
+memorization tapes. Therefore the last assumption of
+lemma~@{thm [source] cartesian_execute} is satisfied. So in the case of the start
+configuration we do not need any extra assumptions such as @{const
+bounded_write}. This is formalized in the next lemma. The downside is that it
+can only be applied to ``finished'' TMs but not to reusable TMs, because these
+do not usually start in the start state.
+\<close>
+
+lemma cartesian_execute_start_config:
+  assumes "turing_machine (Suc k) G M"
+    and "immobile M k (Suc k)"
+    and "k \<ge> 2"
+    and "\<forall>i<length zs. zs ! i < G"
+  shows "execute (cartesian M G) (start_config k zs) t =
+    squish G (length M) (execute M (start_config (Suc k) zs) t)"
+proof -
+  let ?tps = "snd (start_config k zs)"
+  have "snd (start_config (Suc k) zs) =
+    (\<lambda>i. if i = 0 then 1 else if i \<le> length zs then zs ! (i - 1) else 0, 0) #
+        replicate k (\<lambda>i. if i = 0 then 1 else 0, 0)"
+    using start_config_def by auto
+  also have "... = (\<lambda>i. if i = 0 then 1 else if i \<le> length zs then zs ! (i - 1) else 0, 0) #
+        replicate (k - 1) (\<lambda>i. if i = 0 then 1 else 0, 0) @ [(\<lambda>i. if i = 0 then 1 else 0, 0)]"
+    using assms(3)
+    by (metis (no_types, lifting) One_nat_def Suc_1 Suc_le_D Suc_pred less_Suc_eq_0_disj replicate_Suc replicate_append_same)
+  also have "... = snd (start_config k zs) @ [(\<lambda>i. if i = 0 then 1 else 0, 0)]"
+    using start_config_def by auto
+  finally have "snd (start_config (Suc k) zs) = snd (start_config k zs) @ [\<lceil>\<triangleright>\<rceil>]"
+    using onesie_def by auto
+  then have *: "start_config (Suc k) zs = (0, ?tps @ [\<lceil>\<triangleright>\<rceil>])"
+    using start_config_def by simp
+  then have "execute M (0, ?tps @ [\<lceil>\<triangleright>\<rceil>]) t <.> k < G" for t
+    using assms(1,4) by (metis lessI tape_alphabet)
+  moreover have "G \<ge> 2"
+    using assms(1) turing_machine_def by simp
+  moreover have "length ?tps = k"
+    using start_config_length assms(3) by simp
+  ultimately have "execute (cartesian M G) (0, ?tps) t =
+      squish G (length M) (execute M (0, ?tps @ [\<lceil>\<triangleright>\<rceil>]) t)"
+    using cartesian_execute[OF assms(1-3)] by simp
+  moreover have "start_config k zs = (0, ?tps)"
+    using start_config_def by simp
+  ultimately show ?thesis
+    using * by simp
+qed
+
+text \<open>
+So far we have only considered single memorization tapes. But of course we
+can have more than one by iterating the @{const cartesian} function. Applying
+this functions once removes the final memorization tape, but leaves others
+intact, that is, it maintains immobile tapes:
+\<close>
+
+lemma cartesian_immobile:
+  assumes "turing_machine (Suc k) G M"
+    and "j < k"
+    and "immobile M j (Suc k)"
+    and "M' = cartesian M G"
+  shows "immobile M' j k"
+proof standard+
+  fix q :: nat and rs :: "symbol list"
+  assume q: "q < length M'" and rs: "length rs = k"
+  have "q < G * length M"
+    using assms(1,4) q length_cartesian by simp
+  then have "G > 0"
+    using gr0I by fastforce
+  have "length M > 0"
+    using \<open>q < G * length M\<close> by auto
+  define h where "h = q div length M"
+  moreover define i where "i = q mod length M"
+  then have "i < length M"
+    using \<open>0 < length M\<close> mod_less_divisor by simp
+  have "h < G"
+    using i_def h_def \<open>q < G * length M\<close> less_mult_imp_div_less by blast
+  have "q = h * length M + i"
+    using h_def i_def by simp
+  then have "M' ! q = (\<lambda>rs.
+      (let (q', as) = (M ! i) (rs @ [(h + 1) mod G])
+       in (if q' = length M then G * length M else (fst (last as) + G - 1) mod G * length M + q',
+           butlast as)))"
+    using assms(1,4) `h < G` `i < length M` cartesian_at by auto
+  then have "(M' ! q) rs =
+      (let (q', as) = (M ! i) (rs @ [(h + 1) mod G])
+       in (if q' = length M then G * length M else (fst (last as) + G - 1) mod G * length M + q',
+           butlast as))" for rs
+    by simp
+  then have "(M' ! q) rs =
+      (let qas = (M ! i) (rs @ [(h + 1) mod G])
+       in (if fst qas = length M then G * length M else (fst (last (snd qas)) + G - 1) mod G * length M + fst qas,
+           butlast (snd qas)))" for rs
+    by (metis (no_types, lifting) old.prod.case prod.collapse)
+  then have "(M' ! q) rs =
+      (if (fst ((M ! i) (rs @ [(h + 1) mod G]))) = length M
+       then G * length M
+       else (fst (last (snd ((M ! i) (rs @ [(h + 1) mod G])))) + G - 1) mod G * length M + fst ((M ! i) (rs @ [(h + 1) mod G])),
+       butlast (snd ((M ! i) (rs @ [(h + 1) mod G]))))" for rs
+    by metis
+  then have 1: "snd ((M' ! q) rs) = butlast (snd ((M ! i) (rs @ [(h + 1) mod G])))" for rs
+    by simp
+
+  have len: "length (rs @ [(h + 1) mod G]) = Suc k"
+    by (simp add: rs)
+  then have 2: "(M ! i) (rs @ [(h + 1) mod G]) [~] j = Stay"
+    using immobile_def assms(3) len \<open>i < length M\<close> by blast
+  have "length (snd ((M ! i) (rs @ [(h + 1) mod G]))) = Suc k"
+    using len assms(1) turing_machine_def by (metis turing_commandD(1) \<open>i < length M\<close> turing_machineD(3))
+  then have "butlast (snd ((M ! i) (rs @ [(h + 1) mod G]))) ! j =
+      snd ((M ! i) (rs @ [(h + 1) mod G])) ! j"
+    using assms(2) by (simp add: nth_butlast)
+  then have "snd ((M' ! q) rs) ! j = snd ((M ! i) (rs @ [(h + 1) mod G])) ! j"
+    using 1 by simp
+  then show "(M' ! q) rs [~] j = Stay"
+    using 2 by simp
+qed
+
+text \<open>
+With the next function, @{term icartesian}, we can strip several memorization
+tapes off.
+\<close>
+
+fun icartesian :: "nat \<Rightarrow> machine \<Rightarrow> nat \<Rightarrow> machine" where
+  "icartesian 0 M G = M" |
+  "icartesian (Suc k) M G = icartesian k (cartesian M G) G"
+
+text \<open>
+Applying @{const icartesian} maintains the property of being a Turing machine.
+We show that only for the special case that all tapes but the input and output
+tapes are memorization tapes. In this case, we end up with a two-tape machine.
+\<close>
+
+lemma icartesian_tm:
+  assumes "turing_machine (k + 2) G M"
+    and "\<And>j. j < k \<Longrightarrow> immobile M (j + 2) (k + 2)"
+  shows "turing_machine 2 G (icartesian k M G)"
+  using assms(1,2)
+proof (induction k arbitrary: M)
+  case 0
+  then show ?case
+    by (metis add.left_neutral icartesian.simps(1))
+next
+  case (Suc k)
+  let ?M = "cartesian M G"
+  have "turing_machine (Suc (k + 2)) G M"
+    using Suc by simp
+  moreover have "k + 2 \<ge> 2"
+    by simp
+  ultimately have "turing_machine (k + 2) G ?M"
+    using \<open>turing_machine (Suc (k + 2)) G M\<close> cartesian_tm' by blast
+  moreover have "\<And>j. j < k \<Longrightarrow> immobile ?M (j + 2) (k + 2)"
+    using cartesian_immobile Suc by simp
+  ultimately have "turing_machine 2 G (icartesian k ?M G)"
+    using Suc by simp
+  then show "turing_machine 2 G (icartesian (Suc k) M G)"
+    by simp
+qed
+
+text \<open>
+At this point we ought to prove something about the semantics of @{const
+icartesian}. However, we will only need one specific result, which we can only
+express at the end of Section~\ref{s:oblivious-tm} after we have introduced
+oblivious Turing machines.
+\<close>
+
+end
diff --git a/thys/Cook_Levin/NP.thy b/thys/Cook_Levin/NP.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/NP.thy
@@ -0,0 +1,702 @@
+chapter \<open>Time complexity\label{s:TC}\<close>
+
+theory NP
+  imports Elementary Composing Symbol_Ops
+begin
+
+text \<open>
+In order to formulate the Cook-Levin theorem we need to formalize \SAT{} and
+$\NP$-completeness. This chapter is devoted to the latter and hence introduces
+the complexity class $\NP$ and the concept of polynomial-time many-one
+reduction. Moreover, although not required for the Cook-Levin theorem, it
+introduces the class $\mathcal{P}$ and contains a proof of $\mathcal{P}
+\subseteq \NP$ (see Section~\ref{s:TC-subseteq}). The chapter concludes with
+some easy results about $\mathcal{P}$, $\NP$ and reducibility in
+Section~\ref{s:TC-more}.
+\<close>
+
+
+section \<open>The time complexity classes DTIME, $\mathcal{P}$, and $\NP$\label{s:TC-NP}\<close>
+
+text \<open>
+Arora and Barak~\cite[Definitions 1.12, 1.13]{ccama} define
+$\mathrm{DTIME}(T(n))$ as the set of all languages that can be decided in time
+$c \cdot T(n)$ for some $c > 0$ and $\mathcal{P} =
+\bigcup_{c\geq1}\mathrm{DTIME}(n^c)$. However since $0^c = 0$ for $c\geq 1$,
+this means that for a language $L$ to be in $\mathcal{P}$, the Turing machine
+deciding $L$ must check the empty string in zero steps. For a Turing machine to
+halt in zero steps, it must start in the halting state, which limits its
+usefulness. Because of this technical issue we define $\mathrm{DTIME}(T(n))$ as
+the set of all languages that can be decided with a running time in $O(T(n))$,
+which seems a common enough alternative~\cite{lv-aikc,sipser2006,cz-dtime}.
+\<close>
+
+text \<open>
+Languages are sets of strings, and deciding a language means computing its
+characteristic function.
+\<close>
+
+type_synonym language = "string set"
+
+definition characteristic :: "language \<Rightarrow> (string \<Rightarrow> string)" where
+  "characteristic L \<equiv> (\<lambda>x. [x \<in> L])"
+
+definition DTIME :: "(nat \<Rightarrow> nat) \<Rightarrow> language set" where
+  "DTIME T \<equiv> {L. \<exists>k G M T'.
+    turing_machine k G M \<and>
+    big_oh T' T \<and>
+    computes_in_time k M (characteristic L) T'}"
+
+definition complexity_class_P :: "language set" ("\<P>") where
+  "\<P> \<equiv> \<Union>c\<in>{1..}. DTIME (\<lambda>n. n ^ c)"
+
+text \<open>
+A language $L$ is in $\NP$ if there is a polynomial $p$ and a polynomial-time
+Turing machine, called the \emph{verifier}, such that for all strings
+$x\in\bbOI^*$,
+\[
+  x\in L \longleftrightarrow
+    \exists u\in\bbOI^{p(|x|)}: M(\langle x, u\rangle) = \bbbI.
+\]
+The string $u$ does not seem to have a name in general, but in case the verifier
+outputs $\bbbI$ on input $\langle x, u\rangle$ it is called a
+\emph{certificate} for $x$~\cite[Definition~2.1]{ccama}.
+\<close>
+
+definition complexity_class_NP :: "language set" ("\<N>\<P>") where
+  "\<N>\<P> \<equiv> {L. \<exists>k G M p T fverify.
+    turing_machine k G M \<and>
+    polynomial p \<and>
+    big_oh_poly T \<and>
+    computes_in_time k M fverify T \<and>
+    (\<forall>x. x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>]))}"
+
+text \<open>
+The definition of $\NP$ is the one place where we need an actual polynomial
+function, namely $p$, rather than a function that is merely bounded by a
+polynomial. This raises the question as to the definition of a polynomial
+function. Arora and Barak~\cite{ccama} do not seem to give a definition in the
+context of $\NP$ but explicitly state that polynomial functions are mappings
+$\nat \to \nat$.  Presumably they also have the form $f(n) = \sum_{i=0}^d
+a_i\cdot n^i$, as polynomials do.  We have filled in the gap in this definition
+in Section~\ref{s:tm-basic-bigoh} by letting the coefficients $a_i$ be natural
+numbers.
+
+Regardless of whether this is the meaning intended by Arora and Barak, the
+choice is justified because with it the verifier-based definition of $\NP$ is
+equivalent to the original definition via nondeterministic Turing machines
+(NTMs). In the usual equivalence proof (for example, Arora and
+Barak~\cite[Theorem~2.6]{ccama}) a verifier TM and an NTM are constructed.
+
+For the one direction, if a language is decided by a polynomial-time NTM then a
+verifier TM can be constructed that simulates the NTM on input $x$ by using the
+bits in the string $u$ for the nondeterministic choices. The strings $u$ have
+the length $p(|x|)$. So for this construction to work, there must be a polynomial
+$p$ that bounds the running time of the NTM. Clearly, a polynomial function with
+natural coefficients exists with that property.
+
+For the other direction, assume a language has a verifier TM where $p$ is a
+polynomial function with natural coefficients. An NTM deciding this language
+receives $x$ as input, then ``guesses'' a string $u$ of length $p(|x|)$, and
+then runs the verifier on the pair $\langle x, u\rangle$. For this NTM to run in
+polynomial time, $p$ must be computable in time polynomial in $|x|$. We have
+shown this to be the case in lemma @{thm [source] transforms_tm_polynomialI} in
+Section~\ref{s:tm-arithmetic-poly}.
+\<close>
+
+text \<open>
+A language $L_1$ is polynomial-time many-one reducible to a language $L_2$ if
+there is a polynomial-time computable function $f_\mathit{reduce}$ such that for all
+$x$, $x\in L_1$ iff.\ $f_\mathit{reduce}(x) \in L_2$.
+\<close>
+
+definition reducible (infix "\<le>\<^sub>p" 50) where
+  "L\<^sub>1 \<le>\<^sub>p L\<^sub>2 \<equiv> \<exists>k G M T freduce.
+    turing_machine k G M \<and>
+    big_oh_poly T \<and>
+    computes_in_time k M freduce T \<and>
+    (\<forall>x. x \<in> L\<^sub>1 \<longleftrightarrow> freduce x \<in> L\<^sub>2)"
+
+abbreviation NP_hard :: "language \<Rightarrow> bool" where
+  "NP_hard L \<equiv> \<forall>L'\<in>\<N>\<P>. L' \<le>\<^sub>p L"
+
+definition NP_complete :: "language \<Rightarrow> bool" where
+  "NP_complete L \<equiv> L \<in> \<N>\<P> \<and> NP_hard L"
+
+text \<open>
+Requiring $c \geq 1$ in the definition of $\mathcal{P}$ is not essential:
+\<close>
+
+lemma in_P_iff: "L \<in> \<P> \<longleftrightarrow> (\<exists>c. L \<in> DTIME (\<lambda>n. n ^ c))"
+proof
+  assume "L \<in> \<P>"
+  then show "\<exists>c. L \<in> DTIME (\<lambda>n. n ^ c)"
+    unfolding complexity_class_P_def using Suc_le_eq by auto
+next
+  assume "\<exists>c. L \<in> DTIME (\<lambda>n. n ^ c)"
+  then obtain c where "L \<in> DTIME (\<lambda>n. n ^ c)"
+    by auto
+  then obtain k G M T where M:
+    "turing_machine k G M"
+    "big_oh T (\<lambda>n. n ^ c)"
+    "computes_in_time k M (characteristic L) T"
+    using DTIME_def by auto
+  moreover have "big_oh T (\<lambda>n. n ^ Suc c)"
+  proof -
+    obtain c0 n0 :: nat where c0n0: "\<forall>n>n0. T n \<le> c0 * n ^ c"
+      using M(2) big_oh_def by auto
+    have "\<forall>n>n0. T n \<le> c0 * n ^ Suc c"
+    proof standard+
+      fix n assume "n0 < n"
+      then have "n ^ c \<le> n ^ Suc c"
+        using pow_mono by simp
+      then show "T n \<le> c0 * n ^ Suc c"
+        using c0n0 by (metis \<open>n0 < n\<close> add.commute le_Suc_ex mult_le_mono2 trans_le_add2)
+    qed
+    then show ?thesis
+      using big_oh_def by auto
+  qed
+  ultimately have "\<exists>c>0. L \<in> DTIME (\<lambda>n. n ^ c)"
+    using DTIME_def by blast
+  then show "L \<in> \<P>"
+    unfolding complexity_class_P_def by auto
+qed
+
+
+section \<open>Restricting verifiers to one-bit output\label{s:np-alt}\<close>
+
+text \<open>
+The verifier Turing machine in the definition of $\NP$ can output any symbol
+sequence. In this section we restrict it to outputting only the symbol sequence
+\textbf{1} or \textbf{0}. This is equivalent to the definition because it is
+easy to check if a symbol sequence differs from \textbf{1} and if so change it
+to \textbf{0}, as we show below.
+
+The advantage of this restriction is that if we can make the TM halt with the
+output tape head on cell number~1, the output tape symbol read in the final step
+equals the output of the TM. We will exploit this in Chapter~\ref{s:Reducing},
+where we show how to reduce any language $L\in\NP$ to \SAT{}.
+
+The next Turing machine checks if the symbol sequence on tape $j$ differs from
+the one-symbol sequence \textbf{1} and if so turns it into \textbf{0}. It thus
+ensures that the tape contains only one bit symbol.
+
+\null
+\<close>
+
+definition tm_make_bit :: "tapeidx \<Rightarrow> machine" where
+  "tm_make_bit j \<equiv>
+    tm_cr j ;;
+    IF \<lambda>rs. rs ! j = \<one> THEN
+      tm_right j ;;
+      IF \<lambda>rs. rs ! j = \<box> THEN
+        []
+      ELSE
+        tm_set j [\<zero>]
+      ENDIF
+    ELSE
+      tm_set j [\<zero>]
+    ENDIF"
+
+lemma tm_make_bit_tm:
+  assumes "G \<ge> 4" and "0 < j" and "j < k"
+  shows "turing_machine k G (tm_make_bit j)"
+  unfolding tm_make_bit_def
+  using assms tm_right_tm tm_set_tm tm_cr_tm Nil_tm turing_machine_branch_turing_machine
+  by simp
+
+locale turing_machine_make_bit =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_cr j"
+definition "tmT1 \<equiv> tm_right j"
+definition "tmT12 \<equiv> IF \<lambda>rs. rs ! j = \<box> THEN [] ELSE tm_set j [\<zero>] ENDIF"
+definition "tmT2 \<equiv> tmT1 ;; tmT12"
+definition "tm12 \<equiv> IF \<lambda>rs. rs ! j = \<one> THEN tmT2 ELSE tm_set j [\<zero>] ENDIF"
+definition "tm2 \<equiv> tm1 ;; tm12"
+
+lemma tm2_eq_tm_make_bit: "tm2 \<equiv> tm_make_bit j"
+  unfolding tm_make_bit_def tm2_def tm12_def tmT2_def tmT12_def tmT1_def tm1_def by simp
+
+context
+  fixes tps0 :: "tape list" and zs :: "symbol list"
+  assumes jk: "j < length tps0"
+    and zs: "proper_symbols zs"
+  assumes tps0: "tps0 ::: j = \<lfloor>zs\<rfloor>"
+begin
+
+lemma clean: "clean_tape (tps0 ! j)"
+  using zs tps0 contents_clean_tape' by simp
+
+definition "tps1 \<equiv> tps0[j := (\<lfloor>zs\<rfloor>, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = tps0 :#: j + 2"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def by (tform tps: assms jk clean tps0 tps1_def)
+
+definition "tpsT1 \<equiv> tps0[j := (\<lfloor>zs\<rfloor>, 2)]"
+
+lemma tmT1 [transforms_intros]:
+  assumes "ttt = 1"
+  shows "transforms tmT1 tps1 ttt tpsT1"
+  unfolding tmT1_def
+proof (tform tps: assms tps1_def jk)
+  show "tpsT1 = tps1[j := tps1 ! j |+| 1] "
+    using tps1_def tpsT1_def jk
+    by (metis Suc_1 fst_conv list_update_overwrite nth_list_update_eq plus_1_eq_Suc snd_conv)
+qed
+
+definition "tpsT2 \<equiv> tps0
+  [j := if length zs \<le> 1 then (\<lfloor>zs\<rfloor>, 2) else (\<lfloor>[\<zero>]\<rfloor>, 1)]"
+
+lemma tmT12 [transforms_intros]:
+  assumes "ttt = 14 + 2 * length zs"
+  shows "transforms tmT12 tpsT1 ttt tpsT2"
+  unfolding tmT12_def
+proof (tform tps: assms tpsT1_def tps0 jk zs)
+  show "8 + tpsT1 :#: j + 2 * length zs + Suc (2 * length [\<zero>]) + 1 \<le> ttt"
+    using tpsT1_def jk assms by simp
+  have "read tpsT1 ! j = \<lfloor>zs\<rfloor> 2"
+    using tpsT1_def jk tapes_at_read' by (metis fst_conv length_list_update nth_list_update_eq snd_conv)
+  moreover have "\<lfloor>zs\<rfloor> 2 = \<box> \<longleftrightarrow> length zs \<le> 1"
+    using zs contents_def
+    by (metis Suc_1 diff_Suc_1 less_imp_le_nat linorder_le_less_linear not_less_eq_eq zero_neq_numeral)
+  ultimately have "read tpsT1 ! j = \<box> \<longleftrightarrow> length zs \<le> 1"
+    by simp
+  then show
+      "read tpsT1 ! j \<noteq> \<box> \<Longrightarrow> tpsT2 = tpsT1[j := (\<lfloor>[\<zero>]\<rfloor>, 1)]"
+      "read tpsT1 ! j = \<box> \<Longrightarrow> tpsT2 = tpsT1"
+    using tpsT1_def tpsT2_def jk by simp_all
+qed
+
+lemma tmT2 [transforms_intros]:
+  assumes "ttt = 15 + 2 * length zs"
+  shows "transforms tmT2 tps1 ttt tpsT2"
+  unfolding tmT2_def by (tform time: assms)
+
+definition "tps2 \<equiv> tps0
+  [j := if zs = [\<one>] then (\<lfloor>zs\<rfloor>, 2) else (\<lfloor>[\<zero>]\<rfloor>, 1)]"
+
+lemma tm12 [transforms_intros]:
+  assumes "ttt = 17 + 2 * length zs"
+  shows "transforms tm12 tps1 ttt tps2"
+  unfolding tm12_def
+proof (tform tps: assms tps0 jk zs tps1_def)
+  have "read tps1 ! j = \<lfloor>zs\<rfloor> 1"
+    using tps1_def jk tapes_at_read' by (metis fst_conv length_list_update nth_list_update_eq snd_conv)
+  then have *: "read tps1 ! j = \<one> \<longleftrightarrow> \<lfloor>zs\<rfloor> 1 = \<one>"
+    by simp
+  show "read tps1 ! j \<noteq> \<one> \<Longrightarrow> tps2 = tps1[j := (\<lfloor>[\<zero>]\<rfloor>, 1)]"
+    using * tps2_def tps1_def by auto
+  show "tps2 = tpsT2" if "read tps1 ! j = \<one>"
+  proof (cases "zs = [\<one>]")
+    case True
+    then show ?thesis
+      using * tps2_def tpsT2_def by simp
+  next
+    case False
+    then have "\<lfloor>zs\<rfloor> 1 = \<one>"
+      using * that by simp
+    then have "length zs > 1"
+      using False contents_def contents_outofbounds
+      by (metis One_nat_def Suc_length_conv diff_Suc_1 length_0_conv linorder_neqE_nat nth_Cons_0 zero_neq_numeral)
+    then show ?thesis
+      using * tps2_def tpsT2_def by auto
+  qed
+  show "8 + tps1 :#: j + 2 * length zs + Suc (2 * length [\<zero>]) + 1 \<le> ttt"
+    using tps1_def jk assms by simp
+qed
+
+lemma tm2:
+  assumes "ttt = 19 + 2 * length zs + tps0 :#: j"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: assms tps0 jk zs tps1_def)
+
+end
+
+end  (* locale *)
+
+lemma transforms_tm_make_bitI [transforms_intros]:
+  fixes j :: tapeidx 
+  fixes tps tps' :: "tape list" and zs :: "symbol list" and ttt :: nat
+  assumes "j < length tps" and "proper_symbols zs"
+  assumes "tps ::: j = \<lfloor>zs\<rfloor>"
+  assumes "ttt = 19 + 2 * length zs + tps :#: j"
+  assumes "tps' = tps
+    [j := if zs = [\<one>] then (\<lfloor>zs\<rfloor>, 2) else (\<lfloor>[\<zero>]\<rfloor>, 1)]"
+  shows "transforms (tm_make_bit j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_make_bit j .
+  show ?thesis
+    using assms loc.tps2_def loc.tm2 loc.tm2_eq_tm_make_bit by simp
+qed
+
+lemma output_length_le_time:
+  assumes "turing_machine k G M"
+    and "tps ::: 1 = \<lfloor>zs\<rfloor>"
+    and "proper_symbols zs"
+    and "transforms M (snd (start_config k xs)) t tps"
+  shows "length zs \<le> t"
+proof -
+  have 1: "execute M (start_config k xs) t = (length M, tps)"
+    using assms transforms_def transits_def
+    by (metis (no_types, lifting) execute_after_halting_ge fst_conv start_config_def sndI)
+  moreover have "k > 1"
+    using assms(1) turing_machine_def by simp
+  ultimately have "((execute M (start_config k xs) t) <:> 1) i = \<box>" if "i > t" for i
+    using assms blank_after_time that by (meson zero_less_one)
+  then have "(tps ::: 1) i = \<box>" if "i > t" for i
+    using 1 that by simp
+  then have *: "\<lfloor>zs\<rfloor> i = \<box>" if "i > t" for i
+    using assms(2) that by simp
+  show ?thesis
+  proof (rule ccontr)
+    assume "\<not> length zs \<le> t"
+    then have "length zs > t"
+      by simp
+    then have "\<lfloor>zs\<rfloor> (Suc t) \<noteq> \<box>"
+      using contents_inbounds assms(3) contents_def proper_symbols_ne0 by simp
+    then show False
+      using * by simp
+  qed
+qed
+
+text \<open>
+This is the alternative definition of $\NP$, which restricts the verifier
+to output only strings of length one:
+\<close>
+
+lemma NP_output_len_1:
+  "\<N>\<P> = {L. \<exists>k G M p T fverify.
+    turing_machine k G M \<and>
+    polynomial p \<and>
+    big_oh_poly T \<and>
+    computes_in_time k M fverify T \<and>
+    (\<forall>y. length (fverify y) = 1) \<and>
+    (\<forall>x. x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>]))}"
+  (is "_ = ?M")
+proof
+  show "?M \<subseteq> \<N>\<P>"
+    using complexity_class_NP_def by fast
+  define Q where "Q = (\<lambda>L k G M p T fverify.
+    turing_machine k G M \<and>
+    polynomial p \<and>
+    big_oh_poly T \<and>
+    computes_in_time k M fverify T \<and>
+    (\<forall>x. (x \<in> L) = (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>])))"
+  have alt: "complexity_class_NP = {L::language. \<exists>k G M p T fverify. Q L k G M p T fverify}"
+    unfolding complexity_class_NP_def Q_def by simp
+  show "\<N>\<P> \<subseteq> ?M"
+  proof
+    fix L assume "L \<in> \<N>\<P>"
+    then obtain k G M p T fverify where "Q L k G M p T fverify"
+      using alt by blast
+    then have ex:
+      "turing_machine k G M \<and>
+       polynomial p \<and>
+       big_oh_poly T \<and>
+       computes_in_time k M fverify T \<and>
+       (\<forall>x. (x \<in> L) = (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>]))"
+      using Q_def by simp
+
+    have "k \<ge> 2" and "G \<ge> 4"
+      using ex turing_machine_def by simp_all
+
+    define M' where "M' = M ;; tm_make_bit 1"
+    define f' where "f' = (\<lambda>y. if fverify y = [\<bbbI>] then [\<bbbI>] else [\<bbbO>])"
+    define T' where "T' = (\<lambda>n. 19 + 4 * T n)"
+
+    have "turing_machine k G M'"
+      unfolding M'_def using \<open>2 \<le> k\<close> \<open>4 \<le> G\<close> ex tm_make_bit_tm by simp
+    moreover have "polynomial p"
+      using ex by simp
+    moreover have "big_oh_poly T'"
+      using T'_def ex big_oh_poly_const big_oh_poly_prod big_oh_poly_sum by simp
+    moreover have "computes_in_time k M' f' T'"
+    proof
+      fix y
+      let ?cfg = "start_config k (string_to_symbols y)"
+      obtain tps where
+        1: "tps ::: 1 = string_to_contents (fverify y)" and
+        2: "transforms M (snd ?cfg) (T (length y)) tps"
+        using ex computes_in_timeD by blast
+      have len_tps: "length tps \<ge> 2"
+        by (smt (z3) "2" \<open>2 \<le> k\<close> ex execute_num_tapes start_config_length less_le_trans numeral_2_eq_2
+          prod.sel(2) transforms_def transits_def zero_less_Suc)
+      define zs where "zs = string_to_symbols (fverify y)"
+      then have zs: "tps ::: 1 = \<lfloor>zs\<rfloor>" "proper_symbols zs"
+        using 1 by auto
+      have transforms_MI [transforms_intros]: "transforms M (snd ?cfg) (T (length y)) tps"
+        using 2 by simp
+      define tps' where
+        "tps' = tps[1 := if zs = [\<one>] then (\<lfloor>zs\<rfloor>, 2) else (\<lfloor>[\<zero>]\<rfloor>, 1)]"
+
+      have "transforms M' (snd ?cfg) (T (length y) + (19 + (tps :#: Suc 0 + 2 * length zs))) tps'"
+        unfolding M'_def by (tform tps: zs len_tps tps'_def)
+      moreover have "T (length y) + (19 + (tps :#: Suc 0 + 2 * length zs)) \<le> T' (length y)"
+      proof -
+        have "tps :#: Suc 0 \<le> T (length y)"
+          using 2 transforms_def transits_def start_config_def ex head_pos_le_time `2 \<le> k`
+          by (smt (verit, ccfv_threshold) One_nat_def Suc_1 Suc_le_lessD leD linorder_le_less_linear
+            order_less_le_trans prod.sel(2))
+        moreover have "length zs \<le> T (length y)"
+          using zs 2 ex output_length_le_time by auto
+        ultimately show ?thesis
+          using T'_def 1 2 by simp
+      qed
+      ultimately have *: "transforms M' (snd ?cfg) (T' (length y)) tps'"
+        using transforms_monotone by simp
+
+      have "tps' ::: 1 = (if zs = [\<one>] then tps ::: 1 else \<lfloor>[\<zero>]\<rfloor>)"
+        using tps'_def len_tps zs(1) by simp
+      also have "... = (if zs = [\<one>] then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[\<zero>]\<rfloor>)"
+        using zs(1) by simp
+      also have "... = (if string_to_symbols (fverify y) = [3] then \<lfloor>[3]\<rfloor> else \<lfloor>[2]\<rfloor>)"
+        using zs_def by simp
+      also have "... = (if fverify y = [\<bbbI>] then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[\<zero>]\<rfloor>)"
+        by auto
+      also have "... = (if fverify y = [\<bbbI>] then string_to_contents [\<bbbI>] else string_to_contents [\<bbbO>])"
+        by auto
+      also have "... = string_to_contents (if fverify y = [\<bbbI>] then [\<bbbI>] else [\<bbbO>])"
+        by simp
+      also have "... = string_to_contents (f' y)"
+        using f'_def by auto
+      finally have "tps' ::: 1 = string_to_contents (f' y)" .
+
+      then show "\<exists>tps'. tps' ::: 1 = string_to_contents (f' y) \<and>
+          transforms M' (snd ?cfg) (T' (length y)) tps'"
+        using * by auto
+    qed
+    moreover have "\<forall>y. length (f' y) = 1"
+      using f'_def by simp
+    moreover have "(\<forall>x. x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> f' \<langle>x, u\<rangle> = [\<bbbI>]))"
+      using ex f'_def by auto
+    ultimately show "L \<in> ?M"
+      by blast
+  qed
+qed
+
+
+
+section \<open>$\mathcal{P}$ is a subset of $\NP$\label{s:TC-subseteq}\<close>
+
+text \<open>
+Let $L\in\mathcal{P}$ be a language and $M$ a Turing machine that decides $L$ in
+polynomial time. To show $L\in\NP$ we could use a TM that extracts the first
+element from the input $\langle x, u\rangle$ and runs $M$ on $x$. We do not have
+to construct such a TM explicitly because we have shown that the extraction of
+the first pair element is computable in polynomial time (lemma~@{thm [source]
+tm_first_computes}), and by assumption the characteristic function of $L$ is
+computable in polynomial time, too.  The composition of these two functions is
+the verifier function required by the definition of $\NP$. And by lemma~@{thm
+[source] computes_composed_poly} the composition of polynomial-time functions is
+polynomial-time, too.
+
+\null
+\<close>
+
+theorem P_subseteq_NP: "\<P> \<subseteq> \<N>\<P>"
+proof
+  fix L :: language
+  assume "L \<in> \<P>"
+  then obtain c where c: "L \<in> DTIME (\<lambda>n. n ^ c)"
+    using complexity_class_P_def by auto
+  then obtain k G M T' where M:
+    "turing_machine k G M"
+    "computes_in_time k M (characteristic L) T'"
+    "big_oh T' (\<lambda>n. n ^ c)"
+    using DTIME_def by auto
+  then have 4: "big_oh_poly T'"
+    using big_oh_poly_def by auto
+
+  define f where "f = (\<lambda>x. symbols_to_string (first (bindecode (string_to_symbols x))))"
+  define T :: "nat \<Rightarrow> nat" where "T = (\<lambda>n. 9 + 4 * n)"
+  have 1: "turing_machine 3 6 tm_first"
+    by (simp add: tm_first_tm)
+  have 2: "computes_in_time 3 tm_first f T"
+    using f_def T_def tm_first_computes by simp
+  have 3: "big_oh_poly T"
+  proof -
+    have "big_oh_poly (\<lambda>n. 9)"
+      using big_oh_poly_const by simp
+    moreover have "big_oh_poly (\<lambda>n. 4 * n)"
+      using big_oh_poly_const big_oh_poly_prod big_oh_poly_poly[of 1] by simp
+    ultimately show ?thesis
+      using big_oh_poly_sum T_def by simp
+  qed
+
+  define fverify where "fverify = characteristic L \<circ> f"
+  then have *: "\<exists>T k G M. big_oh_poly T \<and> turing_machine k G M \<and> computes_in_time k M fverify T"
+    using M 1 2 3 4 computes_composed_poly by simp
+
+  then have fverify: "fverify \<langle>x, u\<rangle> = [x \<in> L]" for x u
+    using f_def first_pair symbols_to_string_to_symbols fverify_def characteristic_def
+    by simp
+
+  define p :: "nat \<Rightarrow> nat" where "p = (\<lambda>_. 0)"
+  then have "polynomial p"
+    using const_polynomial by simp
+  moreover have "\<forall>x. x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>])"
+    using fverify p_def by simp
+  ultimately show "L \<in> \<N>\<P>"
+    using * complexity_class_NP_def by fast
+qed
+
+
+section \<open>More about $\mathcal{P}$, $\NP$, and reducibility\label{s:TC-more}\<close>
+
+text \<open>
+We prove some low-hanging fruits about the concepts introduced in this chapter.
+None of the results are needed to show the Cook-Levin theorem.
+\<close>
+
+text \<open>
+A language can be reduced to itself by the identity function. Hence reducibility
+is a reflexive relation.
+
+\null
+\<close>
+
+lemma reducible_refl: "L \<le>\<^sub>p L"
+proof -
+  let ?M = "tm_id"
+  let ?T = "\<lambda>n. Suc (Suc n)"
+  have "turing_machine 2 4 ?M"
+    using tm_id_tm by simp
+  moreover have "big_oh_poly ?T"
+  proof -
+    have "big_oh_poly (\<lambda>n. n + 2)"
+      using big_oh_poly_const big_oh_poly_id big_oh_poly_sum by blast
+    then show ?thesis
+      by simp
+  qed
+  moreover have "computes_in_time 2 ?M id ?T"
+    using computes_id by simp
+  moreover have "\<forall>x. x \<in> L \<longleftrightarrow> id x \<in> L"
+    by simp
+  ultimately show "L \<le>\<^sub>p L"
+    using reducible_def by metis
+qed
+
+text \<open>
+Reducibility is also transitive. If $L_1 \leq_p L_2$ by a TM $M_1$ and $L_2
+\leq_p L_3$ by a TM $M_2$ we merely have to run $M_2$ on the output of $M_1$ to
+show that $L_1 \leq_p L_3$. Again this is merely the composition of two
+polynomial-time computable functions.
+\<close>
+
+lemma reducible_trans:
+  assumes "L\<^sub>1 \<le>\<^sub>p L\<^sub>2" and "L\<^sub>2 \<le>\<^sub>p L\<^sub>3"
+  shows "L\<^sub>1 \<le>\<^sub>p L\<^sub>3"
+proof -
+  obtain k1 G1 M1 T1 f1 where 1:
+     "turing_machine k1 G1 M1 \<and>
+      big_oh_poly T1 \<and>
+      computes_in_time k1 M1 f1 T1 \<and>
+      (\<forall>x. x \<in> L\<^sub>1 \<longleftrightarrow> f1 x \<in> L\<^sub>2)"
+    using assms(1) reducible_def by metis
+  moreover obtain k2 G2 M2 T2 f2 where 2:
+     "turing_machine k2 G2 M2 \<and>
+      big_oh_poly T2 \<and>
+      computes_in_time k2 M2 f2 T2 \<and>
+      (\<forall>x. x \<in> L\<^sub>2 \<longleftrightarrow> f2 x \<in> L\<^sub>3)"
+    using assms(2) reducible_def by metis
+  ultimately obtain T k G M where
+      "big_oh_poly T \<and> turing_machine k G M \<and> computes_in_time k M (f2 \<circ> f1) T"
+    using computes_composed_poly by metis
+  moreover have "\<forall>x. x \<in> L\<^sub>1 \<longleftrightarrow> f2 (f1 x) \<in> L\<^sub>3"
+    using 1 2 by simp
+  ultimately show ?thesis
+    using reducible_def by fastforce
+qed
+
+text \<open>
+The usual way to show that a language is $\NP$-hard is to reduce another $\NP$-hard
+language to it.
+\<close>
+
+lemma ex_reducible_imp_NP_hard:
+  assumes "NP_hard L'" and "L' \<le>\<^sub>p L"
+  shows "NP_hard L"
+  using reducible_trans assms by auto
+
+text \<open>
+The converse is also true because reducibility is a reflexive relation.
+\<close>
+
+lemma NP_hard_iff_reducible: "NP_hard L \<longleftrightarrow> (\<exists>L'. NP_hard L' \<and> L' \<le>\<^sub>p L)"
+proof
+  show "NP_hard L \<Longrightarrow> \<exists>L'. NP_hard L' \<and> L' \<le>\<^sub>p L"
+    using reducible_refl by auto
+  show "\<exists>L'. NP_hard L' \<and> L' \<le>\<^sub>p L \<Longrightarrow> NP_hard L"
+    using ex_reducible_imp_NP_hard by blast
+qed
+
+lemma NP_complete_reducible:
+  assumes "NP_complete L'" and "L \<in> \<N>\<P>" and "L' \<le>\<^sub>p L"
+  shows "NP_complete L"
+  using assms NP_complete_def reducible_trans by blast
+
+text \<open>
+In a sense the complexity class $\mathcal{P}$ is closed under reduction.
+\<close>
+
+lemma P_closed_reduction:
+  assumes "L \<in> \<P>" and "L' \<le>\<^sub>p L"
+  shows "L' \<in> \<P>"
+proof -
+  obtain c where c: "L \<in> DTIME (\<lambda>n. n ^ c)"
+    using assms(1) complexity_class_P_def by auto
+  then obtain k G M T where M:
+    "turing_machine k G M"
+    "computes_in_time k M (characteristic L) T"
+    "big_oh T (\<lambda>n. n ^ c)"
+    using DTIME_def by auto
+  then have T: "big_oh_poly T"
+    using big_oh_poly_def by auto
+
+  obtain k' G' M' T' freduce where M':
+    "turing_machine k' G' M'"
+    "big_oh_poly T'"
+    "computes_in_time k' M' freduce T'"
+    "(\<forall>x. x \<in> L' \<longleftrightarrow> freduce x \<in> L)"
+    using reducible_def assms(2) by auto
+
+  obtain T2 k2 G2 M2 where M2:
+    "big_oh_poly T2"
+    "turing_machine k2 G2 M2"
+    "computes_in_time k2 M2 (characteristic L \<circ> freduce) T2"
+    using M T M' computes_composed_poly by metis
+
+  obtain d where d: "big_oh T2 (\<lambda>n. n ^ d)"
+    using big_oh_poly_def M2(1) by auto
+
+  have "characteristic L \<circ> freduce = characteristic L'"
+    using characteristic_def M'(4) by auto
+  then have "\<exists>k G M T'. turing_machine k G M \<and> big_oh T' (\<lambda>n. n ^ d) \<and> computes_in_time k M (characteristic L') T'"
+    using M2 d by auto
+  then have "L' \<in> DTIME (\<lambda>n. n ^ d)"
+    using DTIME_def by simp
+  then show ?thesis
+    using in_P_iff by auto
+qed
+
+text \<open>
+The next lemmas are items~2 and~3 of Theorem~2.8 of the textbook~\cite{ccama}.
+Item~1 is the transitivity of the reduction, already proved in lemma @{thm
+[source] reducible_trans}.
+\<close>
+
+lemma P_eq_NP:
+  assumes "NP_hard L" and "L \<in> \<P>"
+  shows "\<P> = \<N>\<P>"
+  using assms P_closed_reduction P_subseteq_NP by auto
+
+lemma NP_complete_imp:
+  assumes "NP_complete L"
+  shows "L \<in> \<P> \<longleftrightarrow> \<P> = \<N>\<P>"
+  using assms NP_complete_def P_eq_NP by auto
+
+end
diff --git a/thys/Cook_Levin/Oblivious.thy b/thys/Cook_Levin/Oblivious.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Oblivious.thy
@@ -0,0 +1,1635 @@
+chapter \<open>Obliviousness\label{s:oblivious}\<close>
+
+text \<open>
+In order to show that \SAT{} is $\NP$-hard we will eventually show how to reduce
+an arbitrary language $L \in \NP$ to \SAT{}. The proof can only use properties
+of $L$ common to all languages in $\NP$. The definition of $\NP$ provides us
+with a verifier Turing machine $M$ for $L$, of which we only know that it is
+running in polynomial time. In addition by lemma~@{text NP_output_len_1} we can
+assume that $M$ outputs a single bit symbol. In this chapter we are going to
+show that we can make additional assumptions about $M$, namely:
+
+\begin{enumerate}
+  \item $M$ has only two tapes.
+  \item $M$ halts on $\langle x, u\rangle$ with the output tape head on the
+    symbol \textbf{1} iff.\ $u$ is a certificate for $x$.
+  \item $M$ is \emph{oblivious}, which means that on any input $x$ the head
+  positions of $M$ on all its tapes depend only on the \emph{length} of $x$, not
+  on the symbols in $x$~\cite[Remark~1.7]{ccama}.
+\end{enumerate}
+
+These additional properties will somewhat simplify the reduction of $L$ to
+\SAT{}, more precisely the construction of the CNF formulas (see
+Chapter~\ref{s:Reducing}).
+
+In order to achieve this goal we will show how to simulate any polynomial-time
+multi-tape TM in polynomial time on a two-tape oblivious TM that halts with
+the output tape head on cell~1.
+
+Given a polynomial-time $k$-tape TM $M$, the basic approach is to construct a
+two-tape TM that encodes the $k$ tapes of $M$ on its output tape in such a way
+that every cell encodes $k$ symbols of $M$ and flags for $M$'s tape heads.  This
+is the same idea as used by Dalvit and
+Thiemann~\cite{Multitape_To_Singletape_TM-AFP} and originally Hartmanis and
+Stearns~\cite{hs65} for simulating a multi-tape TM on a single-tape TM. After
+all our two-tape simulator can only properly use a single tape (the output/work
+tape). This simulator has roughly a quadratic running time overhead and so keeps
+the running time polynomial. However, it is not generally an oblivious TM.
+
+To make the simulator TM oblivious, we have it initially ``format'' a section on
+the output tape that is long enough to hold everything $M$ is going to write and
+whose length only depends on the input length. To simulate one step of $M$, the
+simulator then sweeps its output tape head all the way from the start of the
+tape to the end of the formatted space and back again, moving one cell per step.
+During these sweeps it executes one step of the simulation of $M$. Since the
+size of the formatted space only depends on the input length, the simulator
+performs the same head movements on inputs of the same length, resulting in an
+oblivious behavior. Moreover, it is easy to make it halt with the output tape
+head on cell number~1.
+
+The formatter TM is described in Section~~\ref{s:oblivious-polynomial}. The
+simulator TM is then constructed in Section~\ref{s:oblivious-two-tape}. Finally
+Section~\ref{s:oblivious-np} states the main result of this chapter.
+
+Before any of this, however, we have to define some basic concepts surrounding
+obliviousness.
+\<close>
+
+
+section \<open>Oblivious Turing machines\label{s:oblivious-tm}\<close>
+
+theory Oblivious
+  imports Memorizing
+begin
+
+text \<open>
+This section provides us with the tools for showing that a Turing machine is
+oblivious and for combining oblivious TMs into more complex oblivious TMs.
+
+So far our analysis of Turing machines involved their semantics and running time
+bounds. For this we mainly used the @{const transforms} predicate, which relates
+a start configuration and a halting configuration and an upper bound for the
+running time of a TM to transit from the one configuration to the other. To deal
+with obliviousness, we need to look more closely and inspect the sequence of
+tape head positions during the TM's execution, rather than only the running
+time.
+
+The subsections in this section roughly correspond to Sections~\ref{s:tm-basic}
+to~\ref{s:tm-memorizing}. In the first subsection we introduce a predicate
+@{term trace} analogous to @{const transforms} and show its behavior under
+sequential composition of TMs and loops (we will not need branches). The next
+subsection shows the head position sequences for those few elementary TMs from
+Section~\ref{s:tm-elementary} that we need for our more complex oblivious TMs
+later. These constructions will also heavily use the memorization-in-states
+technique from Section~\ref{s:tm-memorizing}, which we adapt to this chapter's
+needs in the final subsection.
+\<close>
+
+
+subsection \<open>Traces and head positions\<close>
+
+text \<open>
+In order to show that a Turing machine is oblivious we need to keep track of its
+head positions. Consider a machine $M$ that transits from a configuration @{term
+cfg1} to a configuration @{term cfg2} in $t$ steps.  We call the sequence of
+head positions on the first two tapes a \emph{trace}. If we ignore the initial
+head positions, the length of a trace equals $t$. Moreover we will only
+consider traces where $M$ either does not halt or halts in the very last step.
+These two properties mean, for example, that we can simply concatenate a trace
+of a TM that halts and trace of another TM and get the trace of the sequential
+execution of both TMs.  Similarly, analysing while loops is simplified by these
+two extra assumptions. The next predicate defines what it means for a list
+@{term "es :: (nat \<times> nat) list"} to be a trace.
+\<close>
+
+definition trace :: "machine \<Rightarrow> config \<Rightarrow> (nat \<times> nat) list \<Rightarrow> config \<Rightarrow> bool" where
+  "trace M cfg1 es cfg2 \<equiv>
+     execute M cfg1 (length es) = cfg2 \<and>
+     (\<forall>i<length es. fst (execute M cfg1 i) < length M) \<and>
+     (\<forall>i<length es. execute M cfg1 (Suc i) <#> 0 = fst (es ! i)) \<and>
+     (\<forall>i<length es. execute M cfg1 (Suc i) <#> 1 = snd (es ! i))"
+
+text \<open>
+We will consider traces for machines with more than two tapes, too, but only for
+auxiliary constructions in combination with the memorizing-in-states technique.
+Therefore our definition is limited to start configurations with two tapes. A
+machine is \emph{oblivious} if there is a function mapping the input length
+to the trace that takes the machine from the start configuration with that
+input to a halting configuration.
+\<close>
+
+definition oblivious :: "machine \<Rightarrow> bool" where
+  "oblivious M \<equiv> \<exists>e.
+    (\<forall>zs. bit_symbols zs \<longrightarrow> (\<exists>tps. trace M (start_config 2 zs) (e (length zs)) (length M, tps)))"
+
+lemma trace_Nil: "trace M cfg [] cfg"
+  unfolding trace_def by simp
+
+lemma traceI:
+  assumes "execute M (q1, tps1) (length es) = (q2, tps2)"
+    and "\<And>i. i < length es \<Longrightarrow> fst (execute M (q1, tps1) i) < length M"
+    and "\<And>i. i < length es \<Longrightarrow>
+      execute M (q1, tps1) (Suc i) <#> 0 = fst (es ! i) \<and>
+      execute M (q1, tps1) (Suc i) <#> 1 = snd (es ! i)"
+  shows "trace M (q1, tps1) es (q2, tps2)"
+  using trace_def assms by simp
+
+lemma traceI':
+  assumes "execute M cfg1 (length es) = cfg2"
+    and "\<And>i. i < length es \<Longrightarrow> fst (execute M cfg1 i) < length M"
+    and "\<And>i. i < length es \<Longrightarrow>
+      execute M cfg1 (Suc i) <#> 0 = fst (es ! i) \<and>
+      execute M cfg1 (Suc i) <#> 1 = snd (es ! i)"
+  shows "trace M cfg1 es cfg2"
+  using trace_def assms by simp
+
+lemma trace_additive:
+  assumes "trace M (q1, tps1) es1 (q2, tps2)" and "trace M (q2, tps2) es2 (q3, tps3)"
+  shows "trace M (q1, tps1) (es1 @ es2) (q3, tps3)"
+proof (rule traceI)
+  let ?es = "es1 @ es2"
+  show "execute M (q1, tps1) (length (es1 @ es2)) = (q3, tps3)"
+    using trace_def assms by (simp add: execute_additive)
+  show "fst (execute M (q1, tps1) i) < length M" if "i < length ?es" for i
+  proof (cases "i < length es1")
+    case True
+    then show ?thesis
+      using that assms(1) trace_def by simp
+  next
+    case False
+    have "execute M (q1, tps1) (length es1 + (i - length es1)) = execute M (q2, tps2) (i - length es1)"
+      using execute_additive that assms(1) trace_def by blast
+    then have *: "execute M (q1, tps1) i = execute M (q2, tps2) (i - length es1)"
+      using False by simp
+    have "i - length es1 < length es2"
+      using that False by simp
+    then have "fst (execute M (q2, tps2) (i - length es1)) < length M"
+      using assms(2) trace_def by simp
+    then show ?thesis
+      using * by simp
+  qed
+  show "execute M (q1, tps1) (Suc i) <#> 0 = fst (?es ! i) \<and>
+        execute M (q1, tps1) (Suc i) <#> 1 = snd (?es ! i)"
+    if "i < length ?es" for i
+  proof (cases "i < length es1")
+    case True
+    then show ?thesis
+      using that assms(1) trace_def by (simp add: nth_append)
+  next
+    case False
+    have "execute M (q1, tps1) (length es1 + (Suc i - length es1)) = execute M (q2, tps2) (Suc i - length es1)"
+      using execute_additive that assms(1) trace_def by blast
+    then have *: "execute M (q1, tps1) (Suc i) = execute M (q2, tps2) (Suc (i - length es1))"
+      using False by (simp add: Suc_diff_le)
+    have "i - length es1 < length es2"
+      using that False by simp
+    then have "execute M (q2, tps2) (Suc (i - length es1)) <#> 0 = fst (es2 ! (i - length es1))"
+      and "execute M (q2, tps2) (Suc (i - length es1)) <#> 1 = snd (es2 ! (i - length es1))"
+      using assms(2) trace_def by simp_all
+    then show ?thesis
+      using * by (simp add: False nth_append)
+  qed
+qed
+
+lemma trace_additive':
+  assumes "trace M cfg1 es1 cfg2" and "trace M cfg2 es2 cfg3"
+  shows "trace M cfg1 (es1 @ es2) cfg3"
+  using trace_additive assms by (metis prod.collapse)
+
+text \<open>
+We mostly consider traces from the start state to the halting state, for which
+we introduce the next predicate.
+\<close>
+
+definition traces :: "machine \<Rightarrow> tape list \<Rightarrow> (nat \<times> nat) list \<Rightarrow> tape list \<Rightarrow> bool" where
+  "traces M tps1 es tps2 \<equiv> trace M (0, tps1) es (length M, tps2)"
+
+text \<open>
+The relation between @{const traces} and @{const trace} is like that between
+@{const transforms} and @{const transits}.
+\<close>
+
+lemma tracesI [intro]:
+  assumes "execute M (0, tps1) (length es) = (length M, tps2)"
+    and "\<And>i. i < length es \<Longrightarrow> fst (execute M (0, tps1) i) < length M"
+    and "\<And>i. i < length es \<Longrightarrow>
+      execute M (0, tps1) (Suc i) <#> 0 = fst (es ! i) \<and>
+      execute M (0, tps1) (Suc i) <#> 1 = snd (es ! i)"
+  shows "traces M tps1 es tps2"
+  using traces_def trace_def assms by simp
+
+lemma traces_additive:
+  assumes "trace M (0, tps1) es1 (0, tps2)"
+    and "traces M tps2 es2 tps3"
+  shows "traces M tps1 (es1 @ es2) tps3"
+  using assms traces_def trace_additive by simp
+
+lemma execute_trace_append:
+  assumes "trace M1 (0, tps1) es1 (length M1, tps2)" (is "trace _ ?cfg1 _ _")
+    and "t \<le> length es1"
+  shows "execute (M1 @ M2) (0, tps1) t = execute M1 (0, tps1) t"
+    (is "execute ?M _ _ = _")
+  using assms(2)
+proof (induction t)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc t)
+  then have "t < length es1"
+    by simp
+  then have 1: "fst (execute M1 ?cfg1 t) < length M1"
+    using traces_def trace_def assms(1) by simp
+  have 2: "length ?M = length M1 + length M2"
+    using length_turing_machine_sequential by simp
+  have "execute ?M ?cfg1 (Suc t) = exe ?M (execute ?M ?cfg1 t)"
+    by simp
+  also have "... = exe ?M (execute M1 ?cfg1 t)" (is "_ = exe _ ?cfg")
+    using Suc by simp
+  also have "... = sem (?M ! (fst ?cfg)) ?cfg"
+    using 1 2 exe_def by simp
+  also have "... = sem (M1 ! (fst ?cfg)) ?cfg"
+    using 1 by (simp add: nth_append turing_machine_sequential_def)
+  also have "... = exe M1 (execute M1 ?cfg1 t)"
+    using exe_def 1 by simp
+  also have "... = execute M1 ?cfg1 (Suc t)"
+    by simp
+  finally show ?case .
+qed
+
+
+subsection \<open>Increasing the number of tapes\<close>
+
+text \<open>
+This is lemma @{thm [source] transforms_append_tapes} adapted for @{const
+traces}.
+\<close>
+
+lemma traces_append_tapes:
+  assumes "turing_machine 2 G M" and "length tps1 = 2" and "traces M tps1 es tps2"
+  shows "traces (append_tapes 2 (2 + length tps') M) (tps1 @ tps') es (tps2 @ tps')"
+proof
+  let ?M = "append_tapes 2 (2 + length tps') M"
+  show "execute ?M (0, tps1 @ tps') (length es) = (length ?M, tps2 @ tps')"
+  proof -
+    have "execute M (0, tps1) (length es) = (length M, tps2)"
+      using assms(3) by (simp add: trace_def traces_def)
+    moreover have "execute ?M (0, tps1 @ tps') (length es) =
+        (fst (execute M (0, tps1) (length es)), snd (execute M (0, tps1) (length es)) @ tps')"
+      using execute_append_tapes'[OF assms(1-2)] by simp
+    ultimately show ?thesis
+      by (simp add: length_append_tapes)
+  qed
+  show "fst (execute ?M (0, tps1 @ tps') i) < length ?M" if "i < length es" for i
+  proof -
+    have "fst (execute M (0, tps1) i) < length M"
+      using that assms(3) trace_def traces_def by blast
+    then show "fst (execute ?M (0, tps1 @ tps') i) < length ?M"
+      by (metis (no_types) assms(1,2) execute_append_tapes' fst_conv length_append_tapes)
+  qed
+  show "snd (execute ?M (0, tps1 @ tps') (Suc i)) :#: 0 = fst (es ! i) \<and>
+        snd (execute ?M (0, tps1 @ tps') (Suc i)) :#: 1 = snd (es ! i)"
+    if "i < length es" for i
+  proof -
+    have "snd (execute ?M (0, tps1 @ tps') (Suc i)) = snd (execute M (0, tps1) (Suc i)) @ tps'"
+      using execute_append_tapes' assms by (metis snd_conv)
+    moreover have "||execute M (0, tps1) (Suc i)|| = 2"
+      using assms(1,2) by (metis execute_num_tapes snd_conv)
+    ultimately show ?thesis
+      using that assms by (simp add: nth_append trace_def traces_def)
+  qed
+qed
+
+
+subsection \<open>Combining Turing machines\<close>
+
+text \<open>
+Traces for sequentially composed Turing machines are just concatenated traces of
+the individual machines.
+\<close>
+
+lemma traces_sequential:
+  assumes "traces M1 tps1 es1 tps2" and "traces M2 tps2 es2 tps3"
+  shows "traces (M1 ;; M2) tps1 (es1 @ es2) tps3"
+proof
+  let ?M = "M1 ;; M2"
+  let ?cfg1 = "(0, tps1)"
+  let ?cfg1' = "(length M1, tps2)"
+  let ?cfg2 = "(0, tps2)"
+  let ?cfg2' = "(length M2, tps3)"
+  let ?es = "es1 @ es2"
+  have 3: "execute M1 ?cfg1 (length es1) = ?cfg1'"
+    using assms(1) traces_def trace_def by simp
+  have "fst ?cfg1 = 0"
+    by simp
+  have 4: "execute M2 ?cfg2 (length es2) = ?cfg2'"
+    using assms(2) traces_def trace_def by auto
+  have "?cfg1' = ?cfg2 <+=> length M1"
+    by simp
+  have 2: "length ?M = length M1 + length M2"
+    using length_turing_machine_sequential by simp
+  have t_le: "execute ?M ?cfg1 t = execute M1 ?cfg1 t" if "t \<le> length es1" for t
+    using that
+  proof (induction t)
+    case 0
+    then show ?case
+      by simp
+  next
+    case (Suc t)
+    then have "t < length es1"
+      by simp
+    then have 1: "fst (execute M1 ?cfg1 t) < length M1"
+      using traces_def trace_def assms(1) by simp
+    have "execute ?M ?cfg1 (Suc t) = exe ?M (execute ?M ?cfg1 t)"
+      by simp
+    also have "... = exe ?M (execute M1 ?cfg1 t)" (is "_ = exe _ ?cfg")
+      using Suc by simp
+    also have "... = sem (?M ! (fst ?cfg)) ?cfg"
+      using 1 2 exe_def by simp
+    also have "... = sem (M1 ! (fst ?cfg)) ?cfg"
+      using 1 by (simp add: nth_append turing_machine_sequential_def)
+    also have "... = exe M1 (execute M1 ?cfg1 t)"
+      using exe_def 1 by simp
+    also have "... = execute M1 ?cfg1 (Suc t)"
+      by simp
+    finally show ?case .
+  qed
+  have t_ge: "execute ?M ?cfg1 (length es1 + t) = execute M2 ?cfg2 t <+=> length M1"
+      if "t \<le> length es2" for t
+    using that
+  proof (induction t)
+    case 0
+    then show ?case
+      using t_le 3 by simp
+  next
+    case (Suc t)
+    have "execute ?M ?cfg1 (length es1 + Suc t) = execute ?M ?cfg1 (Suc (length es1 + t))"
+      by simp
+    also have "... = exe ?M (execute ?M ?cfg1 (length es1 + t))"
+      by simp
+    also have "... = exe ?M (execute M2 ?cfg2 t <+=> length M1)"
+        (is "_ = exe _ (?cfg <+=> _)")
+      using Suc by simp
+    also have "... = (exe M2 (execute M2 ?cfg2 t)) <+=> length M1"
+      using exe_relocate by simp
+    also have "... = execute M2 ?cfg2 (Suc t) <+=> length M1"
+      by simp
+    finally show ?case .
+  qed
+  show "fst (execute ?M ?cfg1 i) < length ?M" if "i < length ?es" for i
+  proof (cases "i < length es1")
+    case True
+    then show ?thesis
+      using t_le assms(1) traces_def trace_def 2 by auto
+  next
+    case False
+    then obtain i' where "i = length es1 + i'" "i' \<le> length es2"
+      by (metis \<open>i < length (es1 @ es2)\<close> add_diff_inverse_nat add_le_cancel_left length_append less_or_eq_imp_le)
+    then show ?thesis
+      using t_ge assms(2) traces_def trace_def that 2 by simp
+  qed
+  show "execute ?M ?cfg1 (length ?es) = (length ?M, tps3)"
+    by (simp add: 2 4 t_ge)
+  show "execute ?M ?cfg1 (Suc i) <#> 0 = fst (?es ! i) \<and>
+        execute ?M ?cfg1 (Suc i) <#> 1 = snd (?es ! i)"
+        if "i < length ?es" for i
+  proof (cases "i < length es1")
+    case True
+    then have "Suc i \<le> length es1"
+      by simp
+    then have "execute ?M ?cfg1 (Suc i) = execute M1 ?cfg1 (Suc i)"
+      using t_le by blast
+    then show ?thesis
+      using assms(1) traces_def trace_def by (simp add: True nth_append)
+  next
+    case False
+    have 8: "i - length es1 < length es2"
+      using False that by simp
+    with False have "Suc i - length es1 \<le> length es2"
+      by simp
+    then have "execute ?M ?cfg1 (Suc i) = execute M2 ?cfg2 (Suc i - length es1) <+=> length M1"
+      using t_ge False by fastforce
+    moreover have "?es ! i = es2 ! (i - length es1)"
+      by (simp add: False nth_append)
+    moreover have "execute M2 ?cfg2 (Suc i) <#> 0 = fst (es2 ! i) \<and>
+        execute M2 ?cfg2 (Suc i) <#> 1 = snd (es2 ! i)" if "i < length es2" for i
+        using that assms(2) traces_def trace_def by simp
+    ultimately show ?thesis
+      by (metis "8" False Nat.add_diff_assoc le_less_linear plus_1_eq_Suc snd_conv)
+  qed
+qed
+
+text \<open>
+Next we show how to derive traces for machines created by the @{text WHILE}
+operation. If the condition is false, the trace of the loop is the trace for the
+machine computing the condition plus a singleton trace for the jump.
+\<close>
+
+lemma tm_loop_sem_false_trace:
+  assumes "traces M1 tps0 es1 tps1"
+    and "\<not> cond (read tps1)"
+  shows "trace
+            (WHILE M1 ; cond DO M2 DONE)
+            (0, tps0)
+            (es1 @ [(tps1 :#: 0, tps1 :#: 1)])
+            (length M1 + length M2 + 2, tps1)"
+    (is "trace ?M _ _ _")
+proof (rule traceI)
+  let ?C1 = "M1"
+  let ?C2 = "[cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)]"
+  let ?C3 = "relocate (length M1 + 1) M2"
+  let ?C4 = "[cmd_jump (\<lambda>_. True) 0 0]"
+  let ?C34 = "?C3 @ ?C4"
+  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
+    using turing_machine_loop_def by simp
+  then have 1: "?M ! (length M1) = cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)"
+    by simp
+  let ?es = "es1 @ [(tps1 :#: 0, tps1 :#: 1)]"
+  show goal1: "execute ?M (0, tps0) (length ?es) = (length M1 + length M2 + 2, tps1)"
+  proof -
+    have "execute ?M (0, tps0) (length es1) = execute M1 (0, tps0) (length es1)"
+      using execute_trace_append assms by (simp add: traces_def turing_machine_loop_def)
+    then have 2: "execute ?M (0, tps0) (length es1) = (length M1, tps1) "
+      using assms trace_def traces_def by simp
+    have "execute ?M (0, tps0) (length ?es) = execute ?M (0, tps0) (Suc (length es1))"
+      by simp
+    also have "... = exe ?M (execute ?M (0, tps0) (length es1))"
+      by simp
+    also have "... = exe ?M (length M1, tps1)"
+      using 2 by simp
+    also have "... = sem (cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)) (length M1, tps1)"
+      by (simp add: "1" exe_lt_length turing_machine_loop_len)
+    also have "... = (length M1 + length M2 + 2, tps1)"
+      using assms(2) sem_jump by simp
+    finally show ?thesis .
+  qed
+  show "fst (execute ?M (0, tps0) i) < length ?M" if "i < length ?es" for i
+  proof (cases "i < length es1")
+    case True
+    then have "execute ?M (0, tps0) i = execute M1 (0, tps0) i"
+      using execute_trace_append assms parts by (simp add: traces_def)
+    then show ?thesis
+      using assms(1) trace_def traces_def True turing_machine_loop_len by auto
+  next
+    case False
+    with that have "i = length es1"
+      by simp
+    then show ?thesis
+      using assms(1) trace_def traces_def turing_machine_loop_len
+      by (simp add: execute_trace_append parts)
+  qed
+  show "execute ?M (0, tps0) (Suc i) <#> 0 = fst (?es ! i) \<and>
+        execute ?M (0, tps0) (Suc i) <#> 1 = snd (?es ! i)"
+    if "i < length ?es" for i
+  proof (cases "i < length es1")
+    case True
+    then have "Suc i \<le> length es1"
+      by simp
+    then have "execute ?M (0, tps0) (Suc i) = execute M1 (0, tps0) (Suc i)"
+      using execute_trace_append assms parts by (metis traces_def)
+    then show ?thesis
+      using assms(1) trace_def traces_def True by (simp add: nth_append)
+  next
+    case False
+    with that have "Suc i = length ?es"
+      by simp
+    then show ?thesis
+      using goal1 by simp
+  qed
+qed
+
+lemma tm_loop_sem_false_traces:
+  assumes "traces M1 tps0 es1 tps1"
+    and "\<not> cond (read tps1)"
+    and "es = es1 @ [(tps1 :#: 0, tps1 :#: 1)]"
+  shows "traces (WHILE M1 ; cond DO M2 DONE) tps0 es tps1"
+  using tm_loop_sem_false_trace assms traces_def turing_machine_loop_len by fastforce
+
+text \<open>
+If the loop condition evaluates to true, the trace of one iteration is the
+concatenation of the traces of the condition machine and the loop body machine
+with two additional singleton traces for the jumps.
+\<close>
+
+lemma tm_loop_sem_true_traces:
+  assumes "traces M1 tps0 es1 tps1"
+    and "traces M2 tps1 es2 tps2"
+    and "cond (read tps1)"
+  shows "trace
+            (WHILE M1 ; cond DO M2 DONE)
+            (0, tps0)
+            (es1 @ [(tps1 :#: 0, tps1 :#: 1)] @ es2 @ [(tps2 :#: 0, tps2 :#: 1)])
+            (0, tps2)"
+    (is "trace ?M _ ?es _")
+proof (rule traceI)
+  let ?C1 = "M1"
+  let ?C2 = "[cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)]"
+  let ?C3 = "relocate (length M1 + 1) M2"
+  let ?C4 = "[cmd_jump (\<lambda>_. True) 0 0]"
+  let ?C34 = "?C3 @ ?C4"
+  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
+    using turing_machine_loop_def by simp
+  then have 1: "?M ! (length M1) = cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)"
+    by simp
+  from parts have parts': "?M = ((?C1 @ ?C2) @ ?C3) @ ?C4"
+    by simp
+  have len_M: "length ?M = length M1 + length M2 + 2"
+    using turing_machine_loop_len assms by simp
+  have len_es: "length ?es = length es1 + length es2 + 2"
+    by simp
+
+  have exec_1: "execute ?M (0, tps0) t = execute M1 (0, tps0) t" if "t \<le> length es1" for t
+    using execute_trace_append assms by (simp add: parts that traces_def)
+
+  have exec_2: "execute ?M (0, tps0) (length es1 + 1) = (length M1 + 1, tps1)"
+  proof -
+    have "execute ?M (0, tps0) (length es1) = execute M1 (0, tps0) (length es1)"
+      using execute_trace_append assms by (simp add: traces_def turing_machine_loop_def)
+    then have 2: "execute ?M (0, tps0) (length es1) = (length M1, tps1) "
+      using assms trace_def traces_def by simp
+    have "execute ?M (0, tps0) (length es1 + 1) = execute ?M (0, tps0) (Suc (length es1))"
+      by simp
+    also have "... = exe ?M (execute ?M (0, tps0) (length es1))"
+      by simp
+    also have "... = exe ?M (length M1, tps1)"
+      using 2 by simp
+    also have "... = sem (cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)) (length M1, tps1)"
+      by (simp add: "1" exe_lt_length turing_machine_loop_len)
+    also have "... = (length M1 + 1, tps1)"
+      using assms(3) sem_jump by simp
+    finally show ?thesis .
+  qed
+
+  have exec_3': "execute ?M (0, tps0) (length es1 + 1 + t) = execute M2 (0, tps1) t <+=> (length M1 + 1)"
+    if "t \<le> length es2" for t
+    using that
+  proof (induction t)
+    case 0
+    then show ?case
+      using exec_2 by simp
+  next
+    case (Suc t)
+    then have 2: "fst (execute M2 (0, tps1) t) < length M2"
+      using assms(2) trace_def traces_def by simp
+    then have 3: "fst (execute M2 (0, tps1) t <+=> (length M1 + 1)) < length M1 + length M2 + 1"
+      by simp
+    have 4: "fst (execute M2 (0, tps1) t <+=> (length M1 + 1)) \<ge> length M1 + 1"
+      by simp
+
+    have "?M = (?C1 @ ?C2) @ (?C3 @ ?C4)"
+      using parts by simp
+    moreover have "length (?C1 @ ?C2) = length M1 + 1"
+      by simp
+    ultimately have "?M ! i = (?C3 @ ?C4) ! (i - (length M1 + 1))"
+        if "i \<ge> length M1 + 1" and "i < length M1 + length M2 + 1" for i
+      using that by (simp add: nth_append)
+    then have "?M ! i = ?C3 ! (i - (length M1 + 1))"
+        if "i \<ge> length M1 + 1" and "i < length M1 + length M2 + 1" for i
+      using that
+      by (smt One_nat_def \<open>length (?C1 @ ?C2) = length M1 + 1\<close>
+        add.right_neutral add_Suc_right append.assoc length_append not_le nth_append plus_nat.simps(2) length_relocate)
+    with 3 4 have "?M ! (fst (execute M2 (0, tps1) t <+=> (length M1 + 1))) =
+        ?C3 ! ((fst (execute M2 (0, tps1) t <+=> (length M1 + 1))) - (length M1 + 1))"
+      by simp
+    then have in_C3: "?M ! (fst (execute M2 (0, tps1) t <+=> (length M1 + 1))) =
+        ?C3 ! ((fst (execute M2 (0, tps1) t)))"
+      by simp
+
+    have "execute ?M (0, tps0) (length es1 + 1 + Suc t) = execute ?M (0, tps0) (Suc (length es1 + 1 + t))"
+      by simp
+    also have "... = exe ?M (execute ?M (0, tps0) (length es1 + 1 + t))"
+      by simp
+    also have "... = exe ?M (execute M2 (0, tps1) t <+=> (length M1 + 1))"
+        (is "_ = exe ?M ?cfg")
+      using Suc by simp
+    also have "... = sem (?M ! (fst ?cfg)) ?cfg"
+      using exe_def "3" len_M by simp
+    also have "... = sem (?C3 ! (fst (execute M2 (0, tps1) t))) (execute M2 (0, tps1) t)"
+      using in_C3 sem by simp
+    also have "... = sem (M2 ! (fst (execute M2 (0, tps1) t))) (execute M2 (0, tps1) t) <+=> (length M1 + 1)"
+      using sem_relocate 2 by simp
+    also have "... = exe M2 (execute M2 (0, tps1) t) <+=> (length M1 + 1)"
+      by (simp add: 2 exe_def)
+    also have "... = (execute M2 (0, tps1) (Suc t)) <+=> (length M1 + 1)"
+      by simp
+    finally show ?case .
+  qed
+  then have exec_3: "execute ?M (0, tps0) t = execute M2 (0, tps1) (t - (length es1 + 1)) <+=> (length M1 + 1)"
+      if "t \<ge> length es1 + 1 " and "t \<le> length es1 + length es2 + 1" for t
+    using that
+    by (smt Nat.add_diff_assoc2 Nat.diff_diff_right add_diff_cancel_left' add_diff_cancel_right' le_Suc_ex le_add2)
+
+  have exec_4: "execute ?M (0, tps0) (length es1 + length es2 + 2) = (0, tps2)"
+  proof -
+    have "execute ?M (0, tps0) (length es1 + length es2 + 2) = execute ?M (0, tps0) (Suc (length es1 + length es2 + 1))"
+      by simp
+    also have "... = exe ?M (execute ?M (0, tps0) (length es1 + length es2 + 1))"
+      by simp
+    also have "... = exe ?M (execute M2 (0, tps1) (length es2) <+=> (length M1 + 1))"
+        (is "_ = exe ?M ?cfg")
+      using exec_3' by simp
+    also have "... = sem (?M ! (fst ?cfg)) ?cfg"
+      using exe_def assms(2) len_M trace_def traces_def by auto
+    also have "... = sem (cmd_jump (\<lambda>_. True) 0 0) ?cfg"
+    proof -
+      have "fst ?cfg = length M1 + length M2 + 1"
+        using assms(2) len_M trace_def traces_def by simp
+      then have "?M ! (fst ?cfg) = cmd_jump (\<lambda>_. True) 0 0"
+        by (metis (no_types, lifting) add.right_neutral add_Suc_right length_Cons
+          list.size(3) nth_append_length nth_append_length_plus parts plus_1_eq_Suc length_relocate)
+      then show ?thesis
+        by simp
+    qed
+    also have "... = (0, tps2)"
+      using assms(2) sem_jump trace_def traces_def by auto
+    finally show ?thesis
+      by simp
+  qed
+
+  show "execute ?M (0, tps0) (length ?es) = (0, tps2)"
+    using exec_4 by auto
+  show " fst (execute ?M (0, tps0) i) < length ?M"
+      if "i < length ?es" for i
+  proof -
+    consider
+       "i < length es1"
+     | "i = length es1"
+     | "i \<ge> length es1 + 1 " and "i \<le> length es1 + length es2 + 1"
+     | "i = length es1 + length es2 + 2"
+     using `i < length ?es` by fastforce
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "fst (execute ?M (0, tps0) i) = fst (execute M1 (0, tps0) i)"
+        using exec_1 by simp
+      moreover have "\<forall>i<length es1. fst (execute M1 (0, tps0) i) < length M1"
+        using assms trace_def traces_def by simp
+      ultimately have "fst (execute ?M (0, tps0) i) < length M1"
+        using 1 by simp
+      then show ?thesis
+        using len_M by simp
+    next
+      case 2
+      then have "fst (execute ?M (0, tps0) i) = fst (execute M1 (0, tps0) i)"
+        using exec_1 by simp
+      moreover have "execute M1 (0, tps0) (length es1) = (length M1, tps1)"
+        using assms trace_def traces_def by simp
+      ultimately show ?thesis
+        using 2 by (simp add: len_M)
+    next
+      case 3
+      then have eq: "execute ?M (0, tps0) i = execute M2 (0, tps1) (i - (length es1 + 1)) <+=> (length M1 + 1)"
+        using exec_3 by simp
+      have a: "\<forall>i<length es2. fst (execute M2 (0, tps1) i) < length M2"
+        using assms(2) trace_def traces_def that by simp
+      have b: "fst (execute M2 (0, tps1) (length es2)) = length M2"
+        using assms(2) trace_def traces_def that by simp
+      have "i - (length es1 + 1) \<le> length es2"
+        using 3 by simp
+      then have "fst (execute M2 (0, tps1) (i - (length es1 + 1))) \<le> length M2"
+        using a b that using le_eq_less_or_eq by auto
+      then have "fst (execute M2 (0, tps1) (i - (length es1 + 1)) <+=> (length M1 + 1)) < length ?M"
+        by (simp add: len_M)
+      then show ?thesis
+        using eq by simp
+    next
+      case 4
+      then show ?thesis
+        using exec_4 using len_es that by linarith
+    qed
+  qed
+  show "execute ?M (0, tps0) (Suc i) <#> 0 = fst (?es ! i) \<and>
+        execute ?M (0, tps0) (Suc i) <#> 1 = snd (?es ! i)"
+    if "i < length ?es" for i
+  proof -
+    consider
+       "i < length es1"
+     | "i = length es1"
+     | "i \<ge> length es1 + 1 " and "i < length es1 + length es2 + 1"
+     | "i = length es1 + length es2 + 1"
+     using `i < length ?es` by fastforce
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "Suc i \<le> length es1"
+        by simp
+      then have "execute ?M (0, tps0) (Suc i) = execute M1 (0, tps0) (Suc i)"
+        using exec_1 by blast
+      then show ?thesis
+        using assms(1) trace_def traces_def by (simp add: "1" nth_append)
+    next
+      case 2
+      then have "execute ?M (0, tps0) (Suc i) = (length M1 + 1, tps1)"
+        using exec_2 by simp
+      then show ?thesis
+        using 2 by simp
+    next
+      case 3
+      then have Suc_i: "Suc i \<ge> length es1 + 1 " "Suc i \<le> length es1 + length es2 + 1"
+        by simp_all
+      then have *: "execute ?M (0, tps0) (Suc i) =
+          execute M2 (0, tps1) (Suc i - (length es1 + 1)) <+=> (length M1 + 1)"
+        using exec_3 by blast
+      from 3 have i: "i - (length es1 + 1) < length es2" (is "?j < length es2")
+        by simp
+      then have **: "execute M2 (0, tps1) (Suc ?j) <#> 0 = fst (es2 ! ?j) \<and>
+                 execute M2 (0, tps1) (Suc ?j) <#> 1 = snd (es2 ! ?j)"
+        using assms(2) trace_def traces_def by simp
+      have "((es1 @ [(tps1 :#: 0, tps1 :#: 1)]) @ es2) ! i = es2 ! ?j"
+        using i 3 by (simp add: nth_append)
+      then have "es2 ! ?j = ?es ! i"
+        by (metis Suc_eq_plus1 append.assoc i length_append_singleton nth_append)
+      then show ?thesis
+        using * ** using "3"(1) Suc_diff_le by fastforce
+    next
+      case 4
+      then have "execute ?M (0, tps0) (Suc i) = (0, tps2)"
+        using exec_4 by simp
+      then show ?thesis
+        by (simp add: "4" nth_append)
+    qed
+  qed
+qed
+
+lemma tm_loop_sem_true_tracesI:
+  assumes "traces M1 tps0 es1 tps1"
+    and "traces M2 tps1 es2 tps2"
+    and "cond (read tps1)"
+    and "es = es1 @ [(tps1 :#: 0, tps1 :#: 1)] @ es2 @ [(tps2 :#: 0, tps2 :#: 1)]"
+  shows "trace (WHILE M1 ; cond DO M2 DONE) (0, tps0) es (0, tps2)"
+  using assms tm_loop_sem_true_traces by blast
+
+text \<open>
+Combining traces for $m$ iterations of a loop. Typically $m$ will be the total
+number of iterations.
+\<close>
+
+lemma tm_loop_trace_simple:
+  fixes m :: nat
+    and M :: machine
+    and tps :: "nat \<Rightarrow> tape list"
+    and es :: "nat \<Rightarrow> (nat \<times> nat) list"
+  assumes "\<And>i. i < m \<Longrightarrow> trace M (0, tps i) (es i) (0, tps (Suc i))"
+  shows "trace M (0, tps 0) (concat (map es [0..<m])) (0, tps m)"
+  using assms trace_Nil trace_additive by (induction m) simp_all
+
+text \<open>
+For simple loops, where we have an upper bound for the length of traces
+independent of the iteration, there is a trivial upper bound for the length of
+the trace of $m$ iterations. This is the only situation we will encounter.
+\<close>
+
+lemma length_concat_le:
+  assumes "\<And>i. i < m \<Longrightarrow> length (es i) \<le> b"
+  shows "length (concat (map es [0..<m])) \<le> m * b"
+  using assms
+proof (induction m)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc m)
+  have "length (concat (map es [0..<Suc m])) = length (concat (map es [0..<m])) + length (es m)"
+    by simp
+  also have "... \<le> m * b + length (es m)"
+    using Suc by simp
+  also have "... \<le> m * b + b"
+    using Suc by simp
+  also have "... = (Suc m) * b"
+    by simp
+  finally show ?case .
+qed
+
+
+subsection \<open>Traces for elementary Turing machines\label{s:oblivious-traces}\<close>
+
+text \<open>
+Just like the not necessarily oblivious Turing machines considered so far, our
+oblivious Turing machines will be built from elementary ones from
+Section~\ref{s:tm-elementary}. In this subsection we show the traces of all the
+elementary machines we will need.
+\<close>
+
+lemma tm_left_0_traces:
+  assumes "length tps > 1"
+  shows "traces
+    (tm_left 0)
+    tps
+    [(tps :#: 0 - 1, tps :#: 1)]
+    (tps[0:=(fst (tps ! 0), snd (tps ! 0) - 1)])"
+proof -
+  from assms have "length tps > 0"
+    by auto
+  with assms show ?thesis
+    using execute_tm_left assms tm_left_def by (intro tracesI) simp_all
+qed
+
+lemma traces_tm_left_0I:
+  assumes "length tps > 1"
+    and "es = [(tps :#: 0 - 1, tps :#: 1)]"
+    and "tps' = (tps[0:=(fst (tps ! 0), snd (tps ! 0) - 1)])"
+  shows "traces (tm_left 0) tps es tps'"
+  using tm_left_0_traces assms by simp
+
+lemma tm_left_1_traces:
+  assumes "length tps > 1"
+  shows "traces
+    (tm_left 1)
+    tps
+    [(tps :#: 0, tps :#: 1 - 1)]
+    (tps[1:=(fst (tps ! 1), snd (tps ! 1) - 1)])"
+proof -
+  from assms have "length tps > 0"
+    by auto
+  with assms show ?thesis
+    using execute_tm_left assms tm_left_def by (intro tracesI) simp_all
+qed
+
+lemma traces_tm_left_1I:
+  assumes "length tps > 1"
+    and "es = [(tps :#: 0, tps :#: 1 - 1)]"
+    and "tps' = (tps[1:=(fst (tps ! 1), snd (tps ! 1) - 1)])"
+  shows "traces (tm_left 1) tps es tps'"
+  using tm_left_1_traces assms by simp
+
+lemma tm_right_0_traces:
+  assumes "length tps > 1"
+  shows "traces
+    (tm_right 0)
+    tps
+    [(tps :#: 0 + 1, tps :#: 1)]
+    (tps[0:=(fst (tps ! 0), snd (tps ! 0) + 1)])"
+proof -
+  from assms have "length tps > 0"
+    by auto
+  with assms show ?thesis
+    using execute_tm_right assms tm_right_def by (intro tracesI) simp_all
+qed
+
+lemma traces_tm_right_0I:
+  assumes "length tps > 1"
+    and "es = [(tps :#: 0 + 1, tps :#: 1)]"
+    and "tps' = (tps[0:=(fst (tps ! 0), snd (tps ! 0) + 1)])"
+  shows "traces (tm_right 0) tps es tps'"
+  using tm_right_0_traces assms by simp
+
+lemma tm_right_1_traces:
+  assumes "length tps > 1"
+  shows "traces
+    (tm_right 1)
+    tps
+    [(tps :#: 0, tps :#: 1 + 1)]
+    (tps[1:=(fst (tps ! 1), snd (tps ! 1) + 1)])"
+proof -
+  from assms have "length tps > 0"
+    by auto
+  with assms show ?thesis
+    using execute_tm_right assms tm_right_def by (intro tracesI) simp_all
+qed
+
+lemma tm_rtrans_1_traces:
+  assumes "1 < length tps"
+  shows "traces
+    (tm_rtrans 1 f)
+    tps
+    [(tps :#: 0, tps :#: 1 + 1)]
+    (tps[1 := tps ! 1 |:=| f (tps :.: 1) |+| 1])"
+  using execute_tm_rtrans assms tm_rtrans_def by (intro tracesI) simp_all
+
+lemma traces_tm_right_1I:
+  assumes "length tps > 1"
+    and "es = [(tps :#: 0, tps :#: 1 + 1)]"
+    and "tps' = (tps[1:=(fst (tps ! 1), snd (tps ! 1) + 1)])"
+  shows "traces (tm_right 1) tps es tps'"
+  using tm_right_1_traces assms by simp
+
+lemma traces_tm_rtrans_1I:
+  assumes "1 < length tps"
+    and "es = [(tps :#: 0, tps :#: 1 + 1)]"
+    and "tps' = (tps[1 := tps ! 1 |:=| f (tps :.: 1) |+| 1])"
+  shows "traces (tm_rtrans 1 f) tps es tps'"
+  using tm_rtrans_1_traces assms by simp
+
+lemma tm_left_until_1_traces:
+  assumes "length tps > 1" and "begin_tape H (tps ! 1)"
+  shows "traces
+    (tm_left_until H 1)
+    tps
+    (map (\<lambda>i. (tps :#: 0, i)) (rev [0..<tps :#: 1]) @ [(tps :#: 0, 0)])
+    (tps[1 := tps ! 1 |#=| 0])"
+proof
+  let ?es = "map (\<lambda>i. (tps :#: 0, i)) (rev [0..<tps :#: 1]) @ [(tps :#: 0, 0)]"
+  show "execute (tm_left_until H 1) (0, tps) (length ?es) = (length (tm_left_until H 1), tps[1 := tps ! 1 |#=| 0])"
+    using execute_tm_left_until assms tm_left_until_def by simp
+  show "\<And>i. i < length ?es \<Longrightarrow> fst (execute (tm_left_until H 1) (0, tps) i) < length (tm_left_until H 1)"
+    using execute_tm_left_until_less assms tm_left_until_def by simp
+  show "execute (tm_left_until H 1) (0, tps) (Suc i) <#> 0 = fst (?es ! i) \<and>
+        execute (tm_left_until H 1) (0, tps) (Suc i) <#> 1 = snd (?es ! i)"
+      if "i < length ?es" for i
+  proof (cases "i < tps :#: 1")
+    case True
+    then have i: "Suc i \<le> tps :#: 1"
+      by simp
+    then have "execute (tm_left_until H 1) (0, tps) (Suc i) = (0, tps[1 := tps ! 1 |-| Suc i])"
+      using execute_tm_left_until_less assms by presburger
+    moreover have "?es ! i = (tps :#: 0, tps :#: 1 - Suc i)"
+    proof -
+      have "?es ! i = (map (\<lambda>i. (tps :#: 0, i)) (rev [0..<tps :#: 1])) ! i"
+        using True by (simp add: nth_append)
+      moreover have "(rev [0..<tps :#: 1]) ! i = tps :#: 1 - Suc i"
+        using True by (simp add: rev_nth)
+      ultimately show ?thesis
+        using True by simp
+    qed
+    ultimately show ?thesis
+      using assms(1) by simp
+  next
+    case False
+    then have i: "i = tps :#: 1"
+      using that by simp
+    then have "execute (tm_left_until H 1) (0, tps) (Suc (tps :#: 1)) = (1, tps[1 := tps ! 1 |#=| 0])"
+      using execute_tm_left_until assms by simp
+    then have "execute (tm_left_until H 1) (0, tps) (Suc i) = (1, tps[1 := tps ! 1 |#=| 0])"
+      using i by simp
+    moreover have "?es ! i = (tps :#: 0, 0)"
+      using i by (metis diff_zero length_map length_rev length_upt nth_append_length)
+    ultimately show ?thesis
+      using assms(1) by simp
+  qed
+qed
+
+lemma traces_tm_left_until_1I:
+  assumes "length tps > 1"
+    and "begin_tape H (tps ! 1)"
+    and "es = map (\<lambda>i. (tps :#: 0, i)) (rev [0..<tps :#: 1]) @ [(tps :#: 0, 0)]"
+    and "tps' = tps[1 := tps ! 1 |#=| 0]"
+  shows "traces (tm_left_until H 1) tps es tps'"
+  using tm_left_until_1_traces assms by simp
+
+lemma tm_left_until_0_traces:
+  assumes "length tps > 1" and "begin_tape H (tps ! 0)"
+  shows "traces
+    (tm_left_until H 0)
+    tps
+    (map (\<lambda>i. (i, tps :#: 1)) (rev [0..<tps :#: 0]) @ [(0, tps :#: 1)])
+    (tps[0 := tps ! 0 |#=| 0])"
+proof
+  have len: "length tps > 0"
+    using assms(1) by auto
+  let ?es = "map (\<lambda>i. (i, tps :#: 1)) (rev [0..<tps :#: 0]) @ [(0, tps :#: 1)]"
+  show "execute (tm_left_until H 0) (0, tps) (length ?es) = (length (tm_left_until H 0), tps[0 := tps ! 0 |#=| 0])"
+    using execute_tm_left_until assms(2) tm_left_until_def len by simp
+  show "\<And>i. i < length ?es \<Longrightarrow> fst (execute (tm_left_until H 0) (0, tps) i) < length (tm_left_until H 0)"
+    using execute_tm_left_until_less len assms(2) tm_left_until_def by simp
+  show "execute (tm_left_until H 0) (0, tps) (Suc i) <#> 0 = fst (?es ! i) \<and>
+        execute (tm_left_until H 0) (0, tps) (Suc i) <#> 1 = snd (?es ! i)"
+      if "i < length ?es" for i
+  proof (cases "i < tps :#: 0")
+    case True
+    then have i: "Suc i \<le> tps :#: 0"
+      by simp
+    then have "execute (tm_left_until H 0) (0, tps) (Suc i) = (0, tps[0 := tps ! 0 |-| Suc i])"
+      using execute_tm_left_until_less assms(2) len by blast
+    moreover have "?es ! i = (tps :#: 0 - Suc i, tps :#: 1)"
+    proof -
+      have "?es ! i = (map (\<lambda>i. (i, tps :#: 1)) (rev [0..<tps :#: 0])) ! i"
+        using True by (simp add: nth_append)
+      moreover have "(rev [0..<tps :#: 0]) ! i = tps :#: 0 - Suc i"
+        using True by (simp add: rev_nth)
+      ultimately show ?thesis
+        using True by simp
+    qed
+    ultimately show ?thesis
+      using len by simp
+  next
+    case False
+    then have i: "i = tps :#: 0"
+      using that by simp
+    then have "execute (tm_left_until H 0) (0, tps) (Suc (tps :#: 0)) = (1, tps[0 := tps ! 0 |#=| 0])"
+      using execute_tm_left_until assms len by simp
+    then have "execute (tm_left_until H 0) (0, tps) (Suc i) = (1, tps[0 := tps ! 0 |#=| 0])"
+      using i by simp
+    moreover have "?es ! i = (0, tps :#: 1)"
+        using i by (metis One_nat_def diff_Suc_1 diff_Suc_Suc length_map length_rev length_upt nth_append_length)
+    ultimately show ?thesis
+      using len by simp
+  qed
+qed
+
+lemma traces_tm_left_until_0I:
+  assumes "length tps > 1"
+    and "begin_tape H (tps ! 0)"
+    and "es = map (\<lambda>i. (i, tps :#: 1)) (rev [0..<tps :#: 0]) @ [(0, tps :#: 1)]"
+    and "tps' = tps[0 := tps ! 0 |#=| 0]"
+  shows "traces (tm_left_until H 0) tps es tps'"
+  using tm_left_until_0_traces assms by simp
+
+lemma tm_start_0_traces:
+  assumes "length tps > 1" and "clean_tape (tps ! 0)"
+  shows "traces
+    (tm_start 0)
+    tps
+    (map (\<lambda>i. (i, tps :#: 1)) (rev [0..<tps :#: 0]) @ [(0, tps :#: 1)])
+    (tps[0 := tps ! 0 |#=| 0])"
+proof -
+  have "begin_tape {1} (tps ! 0)"
+    using clean_tape_def begin_tape_def assms(2) by simp
+  then show ?thesis
+    using tm_left_until_0_traces tm_start_def assms(1) by metis
+qed
+
+lemma tm_start_1_traces:
+  assumes "length tps > 1" and "clean_tape (tps ! 1)"
+  shows "traces
+    (tm_start 1)
+    tps
+    (map (\<lambda>i. (tps :#: 0, i)) (rev [0..<tps :#: 1]) @ [(tps :#: 0, 0)])
+    (tps[1 := tps ! 1 |#=| 0])"
+proof -
+  have "begin_tape {1} (tps ! 1)"
+    using clean_tape_def begin_tape_def assms(2) by simp
+  then show ?thesis
+    using tm_left_until_1_traces tm_start_def assms(1) by metis
+qed
+
+lemma traces_tm_start_1I:
+  assumes "length tps > 1"
+    and "clean_tape (tps ! 1)"
+    and "es = map (\<lambda>i. (tps :#: 0, i)) (rev [0..<tps :#: 1]) @ [(tps :#: 0, 0)]"
+    and "tps' = tps[1 := tps ! 1 |#=| 0]"
+  shows "traces (tm_start 1) tps es tps'"
+  using tm_start_1_traces assms by simp
+
+lemma tm_cr_0_traces:
+  assumes "length tps > 1" and "clean_tape (tps ! 0)"
+  shows "traces
+    (tm_cr 0)
+    tps
+    ((map (\<lambda>i. (i, tps :#: 1)) (rev [0..<tps :#: 0]) @ [(0, tps :#: 1)]) @ [(1, tps :#: 1)])
+    (tps[0 := tps ! 0 |#=| 1])"
+  unfolding tm_cr_def
+proof (rule traces_sequential[where ?tps2.0="tps[0 := tps ! 0 |#=| 0]"])
+  from assms(1) have len: "length tps > 0"
+    by auto
+  show "traces (tm_start 0) tps
+     (map (\<lambda>i. (i, tps :#: 1)) (rev [0..<tps :#: 0]) @ [(0, tps :#: 1)])
+     (tps[0 := tps ! 0 |#=| 0])"
+    using assms tm_start_0_traces by simp
+  show "traces (tm_right 0) (tps[0 := tps ! 0 |#=| 0])
+     [(1, tps :#: 1)] (tps[0 := tps ! 0 |#=| 1])"
+    using assms tm_right_0_traces len
+    by (smt One_nat_def add.commute fst_conv length_list_update list_update_overwrite neq0_conv
+      nth_list_update_eq nth_list_update_neq plus_1_eq_Suc snd_conv zero_less_one)
+qed
+
+lemma traces_tm_cr_0I:
+  assumes "length tps > 1" and "clean_tape (tps ! 0)"
+    and "es = map (\<lambda>i. (i, tps :#: 1)) (rev [0..<tps :#: 0]) @ [(0, tps :#: 1), (1, tps :#: 1)]"
+    and "tps' = tps[0 := tps ! 0 |#=| 1]"
+  shows "traces (tm_cr 0) tps es tps'"
+  using tm_cr_0_traces assms by simp
+
+lemma tm_cr_1_traces:
+  assumes "length tps > 1" and "clean_tape (tps ! 1)"
+  shows "traces
+    (tm_cr 1)
+    tps
+    ((map (\<lambda>i. (tps :#: 0, i)) (rev [0..<tps :#: 1]) @ [(tps :#: 0, 0)]) @ [(tps :#: 0, 1)])
+    (tps[1 := tps ! 1 |#=| 1])"
+  unfolding tm_cr_def
+proof (rule traces_sequential[where ?tps2.0="tps[1 := tps ! 1 |#=| 0]"])
+  show "traces (tm_start 1) tps
+     (map (Pair (tps :#: 0)) (rev [0..<tps :#: 1]) @ [(tps :#: 0, 0)])
+     (tps[1 := tps ! 1 |#=| 0])"
+    using assms tm_start_1_traces by simp
+  show "traces (tm_right 1) (tps[1 := tps ! 1 |#=| 0])
+     [(tps :#: 0, 1)] (tps[1 := tps ! 1 |#=| 1])"
+    using assms tm_right_1_traces
+    by (smt One_nat_def add.commute fst_conv length_list_update list_update_overwrite neq0_conv
+      nth_list_update_eq nth_list_update_neq plus_1_eq_Suc snd_conv zero_less_one)
+qed
+
+lemma traces_tm_cr_1I:
+  assumes "length tps > 1" and "clean_tape (tps ! 1)"
+    and "es = map (\<lambda>i. (tps :#: 0, i)) (rev [0..<tps :#: 1]) @ [(tps :#: 0, 0), (tps :#: 0, 1)]"
+    and "tps' = tps[1 := tps ! 1 |#=| 1]"
+  shows "traces (tm_cr 1) tps es tps'"
+  using tm_cr_1_traces assms by simp
+
+lemma heads_tm_trans_until_less:
+  assumes "j1 < k" "j2 < k" and "length tps = k"
+    and "rneigh (tps ! j1) H n"
+    and "t \<le> n"
+  shows "execute (tm_trans_until j1 j2 H f) (0, tps) t <#> j1 = tps :#: j1 + t"
+    and "execute (tm_trans_until j1 j2 H f) (0, tps) t <#> j2 = tps :#: j2 + t"
+  using assms execute_tm_trans_until_less[OF assms]
+  by ((metis (no_types, lifting) length_list_update nth_list_update_eq nth_list_update_neq sndI transplant_def),
+      (metis (no_types, lifting) length_list_update nth_list_update_eq sndI transplant_def))
+
+lemma heads_tm_ltrans_until_less:
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "lneigh (tps ! j1) H n"
+    and "t \<le> n"
+    and "n \<le> tps :#: j1"
+    and "n \<le> tps :#: j2"
+  shows "execute (tm_ltrans_until j1 j2 H f) (0, tps) t <#> j1 = tps :#: j1 - t"
+    and "execute (tm_ltrans_until j1 j2 H f) (0, tps) t <#> j2 = tps :#: j2 - t"
+  using assms execute_tm_ltrans_until_less[OF assms]
+  by ((metis (no_types, lifting) length_list_update nth_list_update_eq nth_list_update_neq sndI ltransplant_def),
+      (metis (no_types, lifting) length_list_update nth_list_update_eq sndI ltransplant_def))
+
+lemma heads_tm_trans_until_less':
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "rneigh (tps ! j1) H n"
+    and "t \<le> n"
+    and "j \<noteq> j1" and "j \<noteq> j2"
+  shows "execute (tm_trans_until j1 j2 H f) (0, tps) t <#> j = tps :#: j"
+  using assms execute_tm_trans_until_less[OF assms(1-5)] by simp
+
+lemma heads_tm_ltrans_until_less':
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "lneigh (tps ! j1) H n"
+    and "t \<le> n"
+    and "n \<le> tps :#: j1"
+    and "n \<le> tps :#: j2"
+    and "j \<noteq> j1" and "j \<noteq> j2"
+  shows "execute (tm_ltrans_until j1 j2 H f) (0, tps) t <#> j = tps :#: j"
+  using assms execute_tm_ltrans_until_less[OF assms(1-7)] by simp
+
+lemma heads_tm_trans_until:
+  assumes "j1 < k" and "j2 < k" and "length tps = k" and "rneigh (tps ! j1) H n"
+  shows "execute (tm_trans_until j1 j2 H f) (0, tps) (Suc n) <#> j1 = tps :#: j1 + n"
+    and "execute (tm_trans_until j1 j2 H f) (0, tps) (Suc n) <#> j2 = tps :#: j2 + n"
+  using assms execute_tm_trans_until[OF assms]
+    by ((metis (no_types, lifting) length_list_update nth_list_update_eq nth_list_update_neq snd_conv transplant_def),
+        (metis (no_types, lifting) length_list_update nth_list_update_eq snd_conv transplant_def))
+
+lemma heads_tm_ltrans_until:
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "lneigh (tps ! j1) H n"
+    and "n \<le> tps :#: j1"
+    and "n \<le> tps :#: j2"
+  shows "execute (tm_ltrans_until j1 j2 H f) (0, tps) (Suc n) <#> j1 = tps :#: j1 - n"
+    and "execute (tm_ltrans_until j1 j2 H f) (0, tps) (Suc n) <#> j2 = tps :#: j2 - n"
+  using assms execute_tm_ltrans_until[OF assms]
+    by ((metis (no_types, lifting) length_list_update nth_list_update_eq nth_list_update_neq snd_conv ltransplant_def),
+        (metis (no_types, lifting) length_list_update nth_list_update_eq snd_conv ltransplant_def))
+
+lemma heads_tm_trans_until':
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "rneigh (tps ! j1) H n"
+    and "j \<noteq> j1" and "j \<noteq> j2"
+  shows "execute (tm_trans_until j1 j2 H f) (0, tps) (Suc n) <#> j = tps :#: j"
+  using assms execute_tm_trans_until[OF assms(1-4)] by simp
+
+lemma heads_tm_ltrans_until':
+  assumes "j1 < k" and "j2 < k" and "length tps = k"
+    and "lneigh (tps ! j1) H n"
+    and "n \<le> tps :#: j1"
+    and "n \<le> tps :#: j2"
+    and "j \<noteq> j1" and "j \<noteq> j2"
+  shows "execute (tm_ltrans_until j1 j2 H f) (0, tps) (Suc n) <#> j = tps :#: j"
+  using assms execute_tm_ltrans_until[OF assms(1-6)] by simp
+
+lemma traces_tm_trans_until_11:
+  assumes "1 < k" and "length tps = k" and "rneigh (tps ! 1) H n"
+  shows "traces (tm_trans_until 1 1 H f)
+    tps
+    (map (\<lambda>i. (tps :#: 0, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0, tps :#: 1 + n)])
+    (tps[1 := transplant (tps ! 1) (tps ! 1) f n])"
+proof
+  let ?es = "map (\<lambda>i. (tps :#: 0, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0, tps :#: 1 + n)]"
+  let ?tps = "tps [1 := transplant (tps ! 1) (tps ! 1) f n]"
+  let ?M = "tm_trans_until 1 1 H f"
+  have len: "length ?es = Suc n"
+    by simp
+  show "execute ?M (0, tps) (length ?es) = (length ?M, ?tps)"
+    using tm_trans_until_def len execute_tm_trans_until assms by simp
+  show "fst (execute ?M (0, tps) i) < length ?M" if "i < length ?es" for i
+  proof -
+    from that len have "i \<le> n"
+      by simp
+    then have "fst (execute ?M (0, tps) i) = 0"
+      using execute_tm_trans_until_less assms by simp
+    then show ?thesis
+      using tm_trans_until_def by simp
+  qed
+  show "execute ?M (0, tps) (Suc i) <#> 0 = fst (?es ! i) \<and>
+        execute ?M (0, tps) (Suc i) <#> 1 = snd (?es ! i)"
+    if "i < length ?es" for i
+  proof (cases "i < n")
+    case True
+    then have "?es ! i = (tps :#: 0, tps :#: 1 + Suc i)"
+      by (simp add: nth_append)
+    moreover from True have "Suc i \<le> n"
+      by simp
+    ultimately show ?thesis
+      using heads_tm_trans_until_less' heads_tm_trans_until_less assms
+      by (metis One_nat_def Suc_neq_Zero fst_conv snd_conv)
+  next
+    case False
+    then have "i = n"
+      using that by simp
+    then have "?es ! i = (tps :#: 0, tps :#: 1 + n)"
+      by (metis (no_types, lifting) diff_zero length_map length_upt nth_append_length)
+    then show ?thesis
+      using heads_tm_trans_until' heads_tm_trans_until assms `i = n` by simp
+  qed
+qed
+
+lemma traces_tm_ltrans_until_11:
+  assumes "1 < k" and "length tps = k" and "lneigh (tps ! 1) H n" and "n \<le> tps :#: 1"
+  shows "traces (tm_ltrans_until 1 1 H f)
+    tps
+    (map (\<lambda>i. (tps :#: 0, tps :#: 1 - Suc i)) [0..<n] @ [(tps :#: 0, tps :#: 1 - n)])
+    (tps[1 := ltransplant (tps ! 1) (tps ! 1) f n])"
+proof
+  let ?es = "map (\<lambda>i. (tps :#: 0, tps :#: 1 - Suc i)) [0..<n] @ [(tps :#: 0, tps :#: 1 - n)]"
+  let ?tps = "tps [1 := ltransplant (tps ! 1) (tps ! 1) f n]"
+  let ?M = "tm_ltrans_until 1 1 H f"
+  have len: "length ?es = Suc n"
+    by simp
+  show "execute ?M (0, tps) (length ?es) = (length ?M, ?tps)"
+    using tm_ltrans_until_def len execute_tm_ltrans_until assms by simp
+  show "fst (execute ?M (0, tps) i) < length ?M" if "i < length ?es" for i
+  proof -
+    from that len have "i \<le> n"
+      by simp
+    then have "fst (execute ?M (0, tps) i) = 0"
+      using execute_tm_ltrans_until_less assms by simp
+    then show ?thesis
+      using tm_ltrans_until_def by simp
+  qed
+  show "execute ?M (0, tps) (Suc i) <#> 0 = fst (?es ! i) \<and>
+        execute ?M (0, tps) (Suc i) <#> 1 = snd (?es ! i)"
+    if "i < length ?es" for i
+  proof (cases "i < n")
+    case True
+    then have "?es ! i = (tps :#: 0, tps :#: 1 - Suc i)"
+      by (simp add: nth_append)
+    moreover from True have "Suc i \<le> n"
+      by simp
+    ultimately show ?thesis
+      using heads_tm_ltrans_until_less' heads_tm_ltrans_until_less assms
+      by (metis One_nat_def Suc_neq_Zero fst_conv snd_conv)
+  next
+    case False
+    then have "i = n"
+      using that by simp
+    then have "?es ! i = (tps :#: 0, tps :#: 1 - n)"
+      by (metis (no_types, lifting) diff_zero length_map length_upt nth_append_length)
+    then show ?thesis
+      using heads_tm_ltrans_until' heads_tm_ltrans_until assms `i = n` by simp
+  qed
+qed
+
+lemma traces_tm_trans_until_01:
+  assumes "0 < k" and "1 < k" and "length tps = k" and "rneigh (tps ! 0) H n"
+  shows "traces (tm_trans_until 0 1 H f)
+    tps
+    (map (\<lambda>i. (tps :#: 0 + Suc i, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0 + n, tps :#: 1 + n)])
+    (tps[0 := tps ! 0 |+| n, 1 := transplant (tps ! 0) (tps ! 1) f n])"
+proof
+  let ?es = "map (\<lambda>i. (tps :#: 0 + Suc i, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0 + n, tps :#: 1 + n)]"
+  let ?tps = "tps [0 := tps ! 0 |+| n, 1 := transplant (tps ! 0) (tps ! 1) f n]"
+  let ?M = "tm_trans_until 0 1 H f"
+  have len: "length ?es = Suc n"
+    by simp
+  show "execute ?M (0, tps) (length ?es) = (length ?M, ?tps)"
+    using tm_trans_until_def len execute_tm_trans_until[of 0 k 1] assms by simp
+  show "fst (execute ?M (0, tps) i) < length ?M" if "i < length ?es" for i
+  proof -
+    from that len have "i \<le> n"
+      by simp
+    then have "fst (execute ?M (0, tps) i) = 0"
+      using execute_tm_trans_until_less[of 0 k 1] assms by simp
+    then show ?thesis
+      using tm_trans_until_def by simp
+  qed
+  show "execute ?M (0, tps) (Suc i) <#> 0 = fst (?es ! i) \<and>
+        execute ?M (0, tps) (Suc i) <#> 1 = snd (?es ! i)"
+    if "i < length ?es" for i
+  proof (cases "i < n")
+    case True
+    then have "?es ! i = (tps :#: 0 + Suc i, tps :#: 1 + Suc i)"
+      by (simp add: nth_append)
+    moreover from True have "Suc i \<le> n"
+      by simp
+    ultimately show ?thesis
+      using heads_tm_trans_until_less[of 0 k 1 tps H n "Suc i" f] assms by simp
+  next
+    case False
+    then have "i = n"
+      using that by simp
+    then have "?es ! i = (tps :#: 0 + n, tps :#: 1 + n)"
+      by (metis (no_types, lifting) diff_zero length_map length_upt nth_append_length)
+    then show ?thesis
+      using heads_tm_trans_until[of 0 k 1 tps H n f] assms `i = n` by simp
+  qed
+qed
+
+lemma traces_tm_trans_until_01I:
+  assumes "1 < length tps"
+    and "rneigh (tps ! 0) H n"
+    and "es = map (\<lambda>i. (tps :#: 0 + Suc i, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0 + n, tps :#: 1 + n)]"
+    and "tps' = tps[0 := tps ! 0 |+| n, 1 := transplant (tps ! 0) (tps ! 1) f n]"
+  shows "traces (tm_trans_until 0 1 H f) tps es tps'"
+  using assms traces_tm_trans_until_01 by simp
+
+lemma traces_tm_trans_until_11I:
+  assumes "1 < length tps"
+    and "rneigh (tps ! 1) H n"
+    and "es = map (\<lambda>i. (tps :#: 0, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0, tps :#: 1 + n)]"
+    and "tps' = tps[1 := transplant (tps ! 1) (tps ! 1) f n]"
+  shows "traces (tm_trans_until 1 1 H f) tps es tps'"
+  using assms traces_tm_trans_until_11 by simp
+
+lemma traces_tm_ltrans_until_11I:
+  assumes "1 < length tps" and "\<forall>h<G. f h < G"
+    and "lneigh (tps ! 1) H n"
+    and "n \<le> tps :#: 1"
+    and "es = map (\<lambda>i. (tps :#: 0, tps :#: 1 - Suc i)) [0..<n] @ [(tps :#: 0, tps :#: 1 - n)]"
+    and "tps' = tps[1 := ltransplant (tps ! 1) (tps ! 1) f n]"
+  shows "traces (tm_ltrans_until 1 1 H f) tps es tps'"
+  using assms traces_tm_ltrans_until_11 by simp
+
+lemma traces_tm_const_until_01I:
+  assumes "1 < length tps"
+    and "rneigh (tps ! 0) H n"
+    and "es = map (\<lambda>i. (tps :#: 0 + Suc i, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0 + n, tps :#: 1 + n)]"
+    and "tps' = tps[0 := tps ! 0 |+| n, 1 := constplant (tps ! 1) h n]"
+  shows "traces (tm_const_until 0 1 H h) tps es tps'"
+  using assms traces_tm_trans_until_01 tm_const_until_def constplant_transplant[of _ _ _ "tps ! 0"] by simp
+
+lemma traces_tm_const_until_11I:
+  assumes "1 < length tps" and "h < G"
+    and "rneigh (tps ! 1) H n"
+    and "es = map (\<lambda>i. (tps :#: 0, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0, tps :#: 1 + n)]"
+    and "tps' = tps[1 := constplant (tps ! 1) h n]"
+  shows "traces (tm_const_until 1 1 H h) tps es tps'"
+  using assms traces_tm_trans_until_11 tm_const_until_def constplant_transplant[of _ _ _ "tps ! 1"] by simp
+
+lemma traces_tm_cp_until_01I:
+  assumes "1 < length tps"
+    and "rneigh (tps ! 0) H n"
+    and "es = map (\<lambda>i. (tps :#: 0 + Suc i, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0 + n, tps :#: 1 + n)]"
+    and "tps' = tps[0 := tps ! 0 |+| n, 1 := implant (tps ! 0) (tps ! 1) n]"
+  shows "traces (tm_cp_until 0 1 H) tps es tps'"
+  using assms traces_tm_trans_until_01 tm_cp_until_def by simp
+
+lemma traces_tm_cp_until_11I:
+  assumes "1 < length tps"
+    and "rneigh (tps ! 1) H n"
+    and "es = map (\<lambda>i. (tps :#: 0, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0, tps :#: 1 + n)]"
+    and "tps' = tps[1 := implant (tps ! 1) (tps ! 1) n]"
+  shows "traces (tm_cp_until 1 1 H) tps es tps'"
+  using assms traces_tm_trans_until_11 tm_cp_until_def by simp
+
+lemma traces_tm_right_until_1I:
+  assumes "1 < length tps"
+    and "rneigh (tps ! 1) H n"
+    and "es = map (\<lambda>i. (tps :#: 0, tps :#: 1 + Suc i)) [0..<n] @ [(tps :#: 0, tps :#: 1 + n)]"
+    and "tps' = tps[1 := (tps ! 1) |+| n]"
+  shows "traces (tm_right_until 1 H) tps es tps'"
+  using assms traces_tm_cp_until_11I tm_right_until_def implant_self by simp
+
+lemma execute_tm_write:
+  shows "execute (tm_write j h) (0, tps) 1 = (1, tps[j := tps ! j |:=| h])"
+  using sem_cmd_write exe_lt_length tm_write_def by simp
+
+lemma traces_tm_writeI:
+  assumes "j > 0" and "j < length tps"
+    and "es = [(tps :#: 0, tps :#: 1)]"
+    and "tps' = tps[j := tps ! j |:=| h]"
+  shows "traces (tm_write j h) tps es tps'"
+  using assms execute_tm_write tm_write_def by (intro tracesI) (auto simp add: nth_list_update)
+
+corollary traces_tm_write_1I:
+  assumes "1 < length tps"
+    and "es = [(tps :#: 0, tps :#: 1)]"
+    and "tps' = tps[1 := tps ! 1 |:=| h]"
+  shows "traces (tm_write 1 h) tps es tps'"
+  using assms traces_tm_writeI by simp
+
+corollary traces_tm_write_ge2I:
+  assumes "j \<ge> 2"
+    and "j < length tps"
+    and "es = [(tps :#: 0, tps :#: 1)]"
+    and "tps' = tps[j := tps ! j |:=| h]"
+  shows "traces (tm_write j h) tps es tps'"
+  using assms traces_tm_writeI by simp
+
+lemma execute_tm_write_manyI:
+  assumes "0 \<notin> J" and "\<forall>j\<in>J. j < k" and "k \<ge> 2" and "length tps = k"
+    and "length tps' = k"
+    and "\<And>j. j \<in> J \<Longrightarrow> tps' ! j = tps ! j |:=| h"
+    and "\<And>j. j < k \<Longrightarrow> j \<notin> J \<Longrightarrow> tps' ! j = tps ! j"
+  shows "execute (tm_write_many J h) (0, tps) 1 = (1, tps')"
+proof -
+  have "tps' = map (\<lambda>j. if j \<in> J then tps ! j |:=| h else tps ! j) [0..<length tps]" (is "_ = ?rhs")
+    using assms by (intro nth_equalityI) simp_all
+  then show ?thesis
+    using assms execute_tm_write_many by simp
+qed
+
+lemma traces_tm_write_manyI:
+  assumes "0 \<notin> J" and "\<forall>j\<in>J. j < k" and "k \<ge> 2" and "length tps = k"
+    and "length tps' = k"
+    and "\<And>j. j \<in> J \<Longrightarrow> tps' ! j = tps ! j |:=| h"
+    and "\<And>j. j < k \<Longrightarrow> j \<notin> J \<Longrightarrow> tps' ! j = tps ! j"
+    and "es = [(tps :#: 0, tps :#: 1)]"
+  shows "traces (tm_write_many J h) tps es tps'"
+proof
+  show "execute (tm_write_many J h) (0, tps) (length es) = (length (tm_write_many J h), tps')"
+    using execute_tm_write_manyI[OF assms(1-7)] tm_write_many_def assms(8) by simp
+  show "\<And>i. i < length es \<Longrightarrow>
+          fst (execute (tm_write_many J h) (0, tps) i) < length (tm_write_many J h)"
+    using assms(8) tm_write_many_def by simp
+  show "\<And>i. i < length es \<Longrightarrow>
+        snd (execute (tm_write_many J h) (0, tps) (Suc i)) :#: 0 = fst (es ! i) \<and>
+        snd (execute (tm_write_many J h) (0, tps) (Suc i)) :#: 1 = snd (es ! i)"
+    using execute_tm_write_manyI[OF assms(1-7)] tm_write_many_def assms(3,6,7,8)
+    by (metis One_nat_def Suc_1 Suc_lessD fst_conv length_Cons less_Suc0
+      less_eq_Suc_le list.size(3) nth_Cons_0 snd_conv)
+qed
+
+lemma traces_tm_write_repeat_1I:
+  assumes "1 < length tps"
+    and "es = map (\<lambda>i. (tps :#: 0, tps :#: 1 + Suc i)) [0..<m]"
+    and "tps' = tps[1 := overwrite (tps ! 1) h m]"
+  shows "traces (tm_write_repeat 1 h m) tps es tps'"
+proof
+  let ?M = "tm_write_repeat 1 h m"
+  have "length es = m"
+    using assms(2) by simp
+  moreover have "length ?M = m"
+    using tm_write_repeat_def by simp
+  ultimately show "execute ?M (0, tps) (length es) = (length ?M, tps')"
+    using assms by (simp add: execute_tm_write_repeat)
+  show "\<And>i. i < length es \<Longrightarrow> fst (execute ?M (0, tps) i) < length ?M"
+    using assms execute_tm_write_repeat tm_write_repeat_def by simp
+  show "execute ?M (0, tps) (Suc i) <#> 0 = fst (es ! i) \<and>
+        execute ?M (0, tps) (Suc i) <#> 1 = snd (es ! i)"
+      if "i < length es" for i
+  proof -
+    have "Suc i \<le> m"
+      using assms \<open>length es = m\<close> that by linarith
+    then have "execute ?M (0, tps) (Suc i) = (Suc i, tps[1 := overwrite (tps ! 1) h (Suc i)])"
+      using that execute_tm_write_repeat assms by blast
+    then show ?thesis
+      using overwrite_def assms(1,2) that by simp
+  qed
+qed
+
+
+subsection \<open>Memorizing in states\<close>
+
+text \<open>
+We need some results for the traces of ``cartesian'' machines used for the
+memorizing-in-states technique introduced in Section~\ref{s:tm-memorizing}.
+\<close>
+
+lemma cartesian_trace:
+  assumes "turing_machine (Suc k) G M"
+    and "immobile M k (Suc k)"
+    and "M' = cartesian M G"
+    and "k \<ge> 2"
+    and "\<forall>i<length zs. zs ! i < G"
+    and "trace M (start_config (Suc k) zs) es cfg"
+  shows "trace M' (start_config k zs) es (squish G (length M) cfg)"
+proof (rule traceI')
+  show "execute M' (start_config k zs) (length es) = squish G (length M) cfg"
+    using assms cartesian_execute_start_config trace_def by auto
+  have len: "length M' = G * length M"
+    by (simp add: assms(3) length_cartesian)
+  have "G > 0"
+    using assms(1) turing_machine_sequential_def by (simp add: turing_machine_def)
+  show "fst (execute M' (start_config k zs) i) < length M'"
+      if "i < length es" for i
+  proof (rule ccontr)
+    assume "\<not> fst (execute M' (start_config k zs) i) < length M'"
+    then have "fst (execute M' (start_config k zs) i) \<ge> length M'"
+      by simp
+    then have "fst (execute M' (start_config k zs) i) = length M'"
+      using assms(1,3) cartesian_tm'
+      by (metis (no_types, lifting) Suc_1 Suc_le_D assms(4) start_config_def start_config_length
+        le_add2 le_add_same_cancel2 le_antisym less_Suc_eq_0_disj prod.sel(1) turing_machine_execute_states)
+    then have "fst (squish G (length M) (execute M (start_config (Suc k) zs) i)) = G * length M"
+      using assms cartesian_execute_start_config len by simp
+    moreover have "fst (execute M (start_config (Suc k) zs) i) \<le> length M"
+      using assms(1) assms(6) that trace_def by auto
+    ultimately have "fst (execute M (start_config (Suc k) zs) i) = length M"
+      using squish_halt_state `0 < G` by simp
+    then show False
+      using that assms(6) trace_def by auto
+  qed
+  show "execute M' (start_config k zs) (Suc i) <#> 0 = fst (es ! i) \<and>
+        execute M' (start_config k zs) (Suc i) <#> 1 = snd (es ! i)"
+    if "i < length es" for i
+  proof (rule ccontr)
+    assume a: "\<not> (snd (execute M' (start_config k zs) (Suc i)) :#: 0 = fst (es ! i) \<and>
+       snd (execute M' (start_config k zs) (Suc i)) :#: 1 = snd (es ! i))"
+    have *: "execute M' (start_config k zs) (Suc i) =
+        squish G (length M) (execute M (start_config (Suc k) zs) (Suc i))"
+      using assms cartesian_execute_start_config by blast
+    then have "execute M' (start_config k zs) (Suc i) <#> 0 =
+        squish G (length M) (execute M (start_config (Suc k) zs) (Suc i)) <#> 0"
+      by simp
+    also have "... = execute M (start_config (Suc k) zs) (Suc i) <#> 0"
+      using squish_head_pos assms execute_num_tapes start_config_length le_imp_less_Suc zero_less_Suc
+      by presburger
+    also have "... = fst (es ! i)"
+      using that assms trace_def by simp
+    finally have fst: "execute M' (start_config k zs) (Suc i) <#> 0 = fst (es ! i)" .
+
+    from * have "execute M' (start_config k zs) (Suc i) <#> 1 =
+        squish G (length M) (execute M (start_config (Suc k) zs) (Suc i)) <#> 1"
+      by simp
+    also have "... = execute M (start_config (Suc k) zs) (Suc i) <#> 1"
+      using squish_head_pos assms execute_num_tapes start_config_length le_imp_less_Suc zero_less_Suc
+      by presburger
+    also have "... = snd (es ! i)"
+      using that assms trace_def by simp
+    finally have "execute M' (start_config k zs) (Suc i) <#> 1 = snd (es ! i)" .
+    then show False
+      using fst a by simp
+  qed
+qed
+
+lemma cartesian_traces:
+  assumes "turing_machine (Suc k) G M"
+    and "immobile M k (Suc k)"
+    and "M' = cartesian M G"
+    and "k \<ge> 2"
+    and "\<forall>i<length zs. zs ! i < G"
+    and "traces M (snd (start_config (Suc k) zs)) es tps"
+  shows "traces M' (snd (start_config k zs)) es (butlast tps)"
+proof -
+  have "trace M (start_config (Suc k) zs) es (length M, tps)"
+    using assms(6) traces_def by (simp add: start_config_def)
+  then have "trace M' (start_config k zs) es (squish G (length M) (length M, tps))"
+    using assms cartesian_trace by simp
+  then show ?thesis
+    using squish traces_def by (simp add: assms(3) start_config_def length_cartesian)
+qed
+
+lemma traces_tapes_length:
+  assumes "turing_machine k G M"
+    and "length tps = k"
+    and "traces M tps es tps'"
+  shows "length tps' = k"
+  using assms traces_def execute_num_tapes by (metis snd_conv trace_def)
+
+lemma icartesian:
+  assumes "turing_machine (k + 2) G M"
+    and "\<And>j. j < k \<Longrightarrow> immobile M (j + 2) (k + 2)"
+    and "\<forall>i<length zs. zs ! i < G"
+    and "traces M (snd (start_config (k + 2) zs)) es tps"
+  shows "traces (icartesian k M G) (snd (start_config 2 zs)) es (take 2 tps)"
+  using assms(1,2,4)
+proof (induction k arbitrary: M tps)
+  case 0
+  let ?M = "icartesian 0 M G"
+  have "||start_config (0 + 2) zs|| = 2"
+    using 0 start_config_length by simp
+  then have "length tps = 2"
+    using 0 traces_tapes_length by (metis One_nat_def Suc_1 add_2_eq_Suc')
+  then have "tps = take 2 tps"
+    by simp
+  then have "traces ?M (snd (start_config 2 zs)) es (take 2 tps)"
+   using 0 by (metis icartesian.simps(1) plus_nat.add_0)
+  then show ?case
+    by auto
+next
+  case (Suc k)
+  let ?M = "cartesian M G"
+  have "turing_machine (Suc (k + 2)) G M"
+    using Suc by simp
+  moreover have "immobile M (k + 2) (Suc (k + 2))"
+    using Suc by simp
+  moreover have "k + 2 \<ge> 2"
+    by simp
+  moreover have "traces M (snd (start_config (Suc (k + 2)) zs)) es tps"
+    using Suc by simp
+  ultimately have *: "traces ?M (snd (start_config (k + 2) zs)) es (butlast tps)"
+    using assms(3) cartesian_traces by simp
+
+  have "turing_machine (k + 2) G ?M"
+    using \<open>2 \<le> k + 2\<close> \<open>turing_machine (Suc (k + 2)) G M\<close> cartesian_tm' by blast
+  moreover have "\<And>j. j < k \<Longrightarrow> immobile ?M (j + 2) (k + 2)"
+    using cartesian_immobile Suc by simp
+  ultimately have "traces (icartesian k ?M G) (snd (start_config 2 zs)) es (take 2 (butlast tps))"
+    using * Suc by simp
+  moreover have "take 2 (butlast tps) = take 2 tps"
+  proof -
+    have "length tps = Suc k + 2"
+      using start_config_length traces_tapes_length Suc
+      by (metis (mono_tags, lifting) add_gr_0 zero_less_Suc)
+    then show ?thesis
+      by (simp add: take_butlast)
+  qed
+  ultimately show ?case
+    by simp
+qed
+
+end
\ No newline at end of file
diff --git a/thys/Cook_Levin/Oblivious_2_Tape.thy b/thys/Cook_Levin/Oblivious_2_Tape.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Oblivious_2_Tape.thy
@@ -0,0 +1,8281 @@
+section \<open>Existence of two-tape oblivious Turing machines\label{s:oblivious-two-tape}\<close>
+
+theory Oblivious_2_Tape
+  imports Oblivious_Polynomial NP
+begin
+
+
+text \<open>
+In this section we show that for every polynomial-time multi-tape Turing machine
+there is a polynomial-time two-tape oblivious Turing machine that computes the
+same function and halts with its output tape head in cell number~1.
+
+Consider a $k$-tape Turing machine $M$ with polynomially bounded running time
+$T$. We construct a two-tape oblivious Turing machine $S$ simulating $M$ as
+follows.
+
+Lemma @{thm [source] polystructor} from the previous section provides us with a
+polynomial-time two-tape oblivious TM and a function $f(n) \geq T(n)$ such that
+the TM outputs $\mathbf{1}^{f(n)}$ for all inputs of length $n$.
+
+Executing this TM is the first thing our simulator does. The $f(n)$
+symbols~@{text \<one>} mark the space $S$ is going to use. Every cell $i=0, \dots,
+f(n) - 1$ of this space is to store a symbol that encodes a $(2k + 2)$-tuple
+consisting of:
+
+\begin{itemize}
+\item $k$ symbols from $M$'s alphabet representing the contents of all the
+  $i$-th cells on the $k$ tapes of $M$;
+\item $k$ flags (called ``head flags'') signalling which of the $k$ tape heads
+  of $M$ is in cell $i$;
+\item a flag (called ``counter flag'') initialized with 0;
+\item a flag (called ``start flag'') signalling whether $i = 0$.
+\end{itemize}
+
+Together the counter flags are a unary counter from 0 to $f(n)$. They are
+toggled from left to right. The start flags never change. The symbols and the
+head flags represent the $k$ tapes of $M$ at some step of the execution.  By
+choice of $f$ the TM $M$ cannot use more than $f(n)$ cells on any tape. So the
+space marked with @{text \<one>} symbols on the simulator's output tape suffices.
+
+Next the simulator initializes the space of @{text \<one>} symbols with code symbols
+representing the start configuration of $M$ for the input given to the
+simulator.
+
+Then the main loop of the simulation performs $f(n)$ iterations. In each
+iteration $S$ performs one step of $M$'s computation. In order to do this it
+performs several left-to-right and right-to-left sweeps over all the $f(n)$
+cells in the formatted section of the output tape.  A sweep will move the output
+tape head one cell right (respectively left) in each step.  In this way the
+simulator's head positions at any time will only depend on $f(n)$, and hence
+on $n$. Thus the machine will be oblivious. Moreover $f(n) \ge T(n)$, and so $M$
+will be in the halting state after $f(n)$ iterations of the simulation. Counting
+the iterations to $f(n)$ is achieved via the counter flags. 
+
+Finally the simulator extracts from each code symbol the symbol corresponding to
+$M$'s output tape, thus reconstructing the output of $M$ on the simulator's
+output tape. Thanks to the start flags, the simulator can easily locate the
+leftmost cell and put the output tape head one to the right of it, as required.
+
+The construction heavily uses the memorization-in-states technique (see
+Chapter~\ref{s:tm-memorizing}). At first the machine features $2k + 1$
+memorization tapes in addition to the input tape and output tape. The purpose of
+those tapes is to store $M$'s state and the symbols under the tape heads of $M$
+in the currently simulated step of $M$'s execution, as well as the $k$ symbols
+to be written write and head movements to be executed by the simulator.
+\<close>
+
+text \<open>
+The next predicate expresses that a Turing machine halts within a time bound
+depending on the length of the input. We did not have a need for this fairly
+basic predicate yet, because so far we were always interested in the halting
+configuration, too, and so the predicate @{const computes_in_time} sufficed.
+
+\null
+\<close>
+
+definition time_bound :: "machine \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> bool" where
+  "time_bound M k T \<equiv>
+    \<forall>zs. bit_symbols zs \<longrightarrow> fst (execute M (start_config k zs) (T (length zs))) = length M"
+
+lemma time_bound_ge:
+  assumes "time_bound M k T" and "\<forall>n. fmt n \<ge> T n"
+  shows "time_bound M k fmt"
+  using time_bound_def assms by (metis execute_after_halting_ge)
+
+text \<open>
+The time bound also bounds the position of all the tape heads.
+\<close>
+
+lemma head_pos_le_time_bound:
+  assumes "turing_machine k G M"
+    and "time_bound M k T"
+    and "bit_symbols zs"
+    and "j < k"
+  shows "execute M (start_config k zs) t <#> j \<le> T (length zs)"
+  using assms time_bound_def[of M k T] execute_after_halting_ge head_pos_le_time[OF assms(1,4)]
+  by (metis (no_types, lifting) nat_le_linear)
+
+text \<open>
+The entire construction will take place in a locale that assumes a
+polynomial-time $k$-tape Turing machine $M$.
+\<close>
+
+locale two_tape =
+  fixes M :: machine and k G :: nat and T :: "nat \<Rightarrow> nat"
+  assumes tm_M: "turing_machine k G M"
+    and poly_T: "big_oh_poly T"
+    and time_bound_T: "time_bound M k T"
+begin
+
+lemma k_ge_2: "k \<ge> 2"
+  using tm_M turing_machine_def by simp
+
+lemma G_ge_4: "G \<ge> 4"
+  using tm_M turing_machine_def by simp
+
+text \<open>
+The construction of the simulator relies on the formatted space on the output
+tape to be large enough to hold the input. The size of the formatted space
+depends on the time bound $T$, which might be less than the length of the input.
+To ensure that the formatted space is large enough we increase the time bound
+while keeping it polynomial. The new bound is $T'$:
+\<close>
+
+definition T' :: "nat \<Rightarrow> nat" where
+  "T' n \<equiv> T n + n"
+
+lemma poly_T': "big_oh_poly T'"
+proof -
+  have "big_oh_poly (\<lambda>n. n)"
+    using big_oh_poly_poly[of 1] by simp
+  then show ?thesis
+    using T'_def big_oh_poly_sum[OF poly_T] by presburger
+qed
+
+lemma time_bound_T': "time_bound M k T'"
+  using T'_def time_bound_ge[OF time_bound_T, of T'] by simp
+
+
+subsection \<open>Encoding multiple tapes into one\<close>
+
+text \<open>
+The symbols on the output tape of the simulator are supposed to encode a $(2k +
+2)$-tuple, where the first $k$ elements assume one of the values in $\{0, \dots,
+G - 1\}$, whereas the other $k + 2$ are flags with two possible values only. For
+uniformity we define an encoding where all elements range over $G$ values and
+that works for tuples of every length.
+\<close>
+
+fun encode :: "nat list \<Rightarrow> nat" where
+  "encode [] = 0" |
+  "encode (x # xs) = x + G * encode xs"
+
+text \<open>
+For every $m \in \nat$, the enocoding is a bijective mapping from $\{0, \dots,
+G - 1\}^m$ to $\{0, \dots, G^m - 1\}$.
+\<close>
+
+lemma encode_surj:
+  assumes "n < G ^ m"
+  shows "\<exists>xs. length xs = m \<and> (\<forall>x\<in>set xs. x < G) \<and> encode xs = n"
+  using assms
+proof (induction m arbitrary: n)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc m)
+  define q where "q = n div G"
+  define r where "r = n mod G"
+  have "q < G ^ m"
+    using Suc q_def
+    by (auto simp add: less_mult_imp_div_less power_commutes)
+  then obtain xs' where xs': "length xs' = m" "\<forall>x\<in>set xs'. x < G" "encode xs' = q"
+    using Suc by auto
+  have "r < G"
+    using r_def G_ge_4 by simp
+  have "encode (r # xs') = n"
+    using xs'(3) q_def r_def G_ge_4 by simp
+  moreover have "\<forall>x\<in>set (r # xs'). x < G"
+    using xs'(2) `r < G` by simp
+  moreover have "length (r # xs') = Suc m"
+    using xs'(1) by simp
+  ultimately show ?case
+    by blast
+qed
+
+lemma encode_inj:
+  assumes "\<forall>x\<in>set xs. x < G"
+    and "length xs = m"
+    and "\<forall>y\<in>set ys. y < G"
+    and "length ys = m"
+    and "encode xs = encode ys"
+  shows "xs = ys"
+  using assms
+proof (induction m arbitrary: xs ys)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc m)
+  obtain x xs' y ys' where xy: "xs = x # xs'" "ys = y # ys'"
+    using Suc by (metis Suc_length_conv)
+  then have len: "length xs' = m" "length ys' = m"
+    using Suc by simp_all
+  have *: "x + G * encode xs' = y + G * encode ys'"
+    using Suc xy by simp
+  moreover have "(x + G * encode xs') mod G = x"
+    by (simp add: Suc.prems(1) xy(1))
+  moreover have "(y + G * encode ys') mod G = y"
+    by (simp add: Suc.prems(3) xy(2))
+  ultimately have "x = y"
+    by simp
+  with * have "G * encode xs' = G * encode ys'"
+    by simp
+  then have "encode xs' = encode ys'"
+    using G_ge_4 by simp
+  with len Suc xy have "xs' = ys'"
+    by simp
+  then show ?case
+    using `x = y` xy by simp
+qed
+
+lemma encode_less:
+  assumes "\<forall>x\<in>set xs. x < G"
+  shows "encode xs < G ^ (length xs)"
+  using assms
+proof (induction xs)
+  case Nil
+  then show ?case
+    by simp
+next
+  case (Cons x xs)
+  then have "x < G"
+    by simp
+  have "encode (x # xs) = x + G * encode xs"
+    by simp
+  also have "... \<le> x + G * (G ^ (length xs) - 1)"
+    using Cons by simp
+  also have "... = x + G * G ^ (length xs) - G"
+    by (simp add: right_diff_distrib')
+  also have "... < G * G ^ (length xs)"
+    using `x < G` less_imp_Suc_add by fastforce
+  also have "... = G ^ (Suc (length xs))"
+    by simp
+  finally have "encode (x # xs) < G ^ (length (x # xs))"
+    by simp
+  then show ?case .
+qed
+
+text \<open>
+Decoding a number into an $m$-tuple of numbers is then a well-defined operation.
+\<close>
+
+definition decode :: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
+  "decode m n \<equiv> THE xs. encode xs = n \<and> length xs = m \<and> (\<forall>x\<in>set xs. x < G)"
+
+lemma decode:
+  assumes "n < G ^ m"
+  shows encode_decode: "encode (decode m n) = n"
+    and length_decode: "length (decode m n) = m"
+    and decode_less_G: "\<forall>x\<in>set (decode m n). x < G"
+proof -
+  have "\<exists>xs. length xs = m \<and> (\<forall>x\<in>set xs. x < G) \<and> encode xs = n"
+    using assms encode_surj by simp
+  then have *: "\<exists>!xs. encode xs = n \<and> length xs = m \<and> (\<forall>x\<in>set xs. x < G)"
+    using encode_inj by auto
+  let ?xs = "decode m n"
+  let ?P = "\<lambda>xs. encode xs = n \<and> length xs = m \<and> (\<forall>x\<in>set xs. x < G)"
+  have "encode ?xs = n \<and> length ?xs = m \<and> (\<forall>x\<in>set ?xs. x < G)"
+    using * theI'[of ?P] decode_def by simp
+  then show "encode (decode m n) = n" and "length (decode m n) = m" and "\<forall>x\<in>set (decode m n). x < G"
+    by simp_all
+qed
+
+lemma decode_encode: "\<forall>x\<in>set xs. x < G \<Longrightarrow> decode (length xs) (encode xs) = xs"
+proof -
+  fix xs :: "nat list"
+  assume a: "\<forall>x\<in>set xs. x < G"
+  then have "encode xs < G ^ (length xs)"
+    using encode_less by simp
+  show "decode (length xs) (encode xs) = xs"
+    unfolding decode_def
+  proof (rule the_equality)
+   show "encode xs = encode xs \<and> length xs = length xs \<and> (\<forall>x\<in>set xs. x < G)"
+     using a by simp
+   show "\<And>ys. encode ys = encode xs \<and> length ys = length xs \<and> (\<forall>x\<in>set ys. x < G) \<Longrightarrow> ys = xs"
+     using a encode_inj by simp
+  qed
+qed
+
+text \<open>
+The simulator will access and update components of the encoded symbol.
+\<close>
+
+definition encode_nth :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
+  "encode_nth m n j \<equiv> decode m n ! j"
+
+definition encode_upd :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
+  "encode_upd m n j x \<equiv> encode ((decode m n) [j:=x])"
+
+lemma encode_nth_less:
+  assumes "n < G ^ m" and "j < m"
+  shows "encode_nth m n j < G"
+  using assms encode_nth_def decode_less_G length_decode by simp
+
+text \<open>
+For the symbols the simulator actually uses, we fix $m = 2k + 2$ and reserve the
+symbols $\triangleright$ and $\Box$, effectively shifting the symbols by two. We
+call the symbols $\{2, \dots, G^{2k+2} + 2\}$ ``code symbols''.
+\<close>
+
+definition enc :: "symbol list \<Rightarrow> symbol" where
+  "enc xs \<equiv> encode xs + 2"
+
+definition dec :: "symbol \<Rightarrow> symbol list" where
+  "dec n \<equiv> decode (2 * k + 2) (n - 2)"
+
+lemma dec:
+  assumes "n > 1" and "n < G ^ (2 * k + 2) + 2"
+  shows enc_dec: "enc (dec n) = n"
+    and length_dec: "length (dec n) = 2 * k + 2"
+    and dec_less_G: "\<forall>x\<in>set (dec n). x < G"
+proof -
+  show "enc (dec n) = n"
+    using enc_def dec_def encode_decode assms by simp
+  show "length (dec n) = 2 * k + 2"
+    using enc_def dec_def length_decode assms by simp
+  show "\<forall>x\<in>set (dec n). x < G"
+    using enc_def dec_def decode_less_G assms
+    by (metis Suc_leI less_diff_conv2 one_add_one plus_1_eq_Suc)
+qed
+
+lemma dec_enc: "\<forall>x\<in>set xs. x < G \<Longrightarrow> length xs = 2 * k + 2 \<Longrightarrow> dec (enc xs) = xs"
+  unfolding enc_def dec_def using decode_encode by fastforce
+
+definition enc_nth :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
+  "enc_nth n j \<equiv> dec n ! j"
+
+lemma enc_nth: "\<forall>x\<in>set xs. x < G \<Longrightarrow> length xs = 2 * k + 2 \<Longrightarrow> enc_nth (enc xs) j = xs ! j"
+  unfolding enc_nth_def by (simp add: dec_enc)
+
+lemma enc_nth_dec:
+  assumes "n > 1" and "n < G ^ (2 * k + 2) + 2"
+  shows "enc_nth n j = (dec n) ! j"
+  using assms enc_nth dec by metis
+
+abbreviation is_code :: "nat \<Rightarrow> bool" where
+  "is_code n \<equiv> n < G ^ (2 * k + 2) + 2 \<and> 1 < n"
+
+lemma enc_nth_less:
+  assumes "is_code n" and "j < 2 * k + 2"
+  shows "enc_nth n j < G"
+  using assms enc_nth_def by (metis dec_less_G in_set_conv_nth length_dec)
+
+lemma enc_less: "\<forall>x\<in>set xs. x < G \<Longrightarrow> length xs = 2 * k + 2 \<Longrightarrow> enc xs < G ^ (2 * k + 2) + 2"
+  using encode_less enc_def by fastforce
+
+definition enc_upd :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
+  "enc_upd n j x \<equiv> enc ((dec n) [j:=x])"
+
+lemma enc_upd_is_code:
+  assumes "is_code n" and "j < 2 * k + 2" and "x < G"
+  shows "is_code (enc_upd n j x)"
+proof -
+  let ?ys = "(dec n) [j:=x]"
+  have "\<forall>h\<in>set (dec n). h < G"
+    using assms(1,2) dec_less_G by auto
+  then have "\<forall>h\<in>set ?ys. h < G"
+    using assms(3)
+    by (metis in_set_conv_nth length_list_update nth_list_update_eq nth_list_update_neq)
+  moreover have "length ?ys = 2 * k + 2"
+    using assms length_dec by simp
+  ultimately have "enc ?ys < G ^ (2 * k + 2) + 2"
+    using enc_less by simp
+  then show ?thesis
+    using enc_upd_def enc_def by simp
+qed
+
+text \<open>
+The code symbols require the simulator to have an alphabet of at least size
+$G^{2k + 2} + 2$. On top of that we want to store on a memorization tape the
+state that $M$ is in. So the alphabet must have at least @{term "length M + 1"}
+symbols. Both conditions are met by the simulator having an alphabet of size
+$G'$:
+\<close>
+
+definition G' :: nat where
+  "G' \<equiv> G ^ (2 * k + 2) + 2 + length M"
+
+lemma G'_ge_6: "G' \<ge> 6"
+proof -
+  have "4 ^ 2 > (5::nat)"
+    by simp
+  then have "G ^ 2 > (5::nat)"
+    using G_ge_4 less_le_trans power2_nat_le_eq_le by blast
+  then have "G ^ (2 * k + 2) > (5::nat)"
+    using k_ge_2 G_ge_4
+    by (metis (no_types, opaque_lifting) dec_induct le_add2 order_less_le_subst1 pow_mono zero_less_Suc zero_less_numeral)
+  then show ?thesis
+    using G'_def by simp
+qed
+
+corollary G'_ge: "G' \<ge> 4" "G' \<ge> 5"
+  using G'_ge_6 by simp_all
+
+lemma G'_ge_G: "G' \<ge> G"
+proof -
+  have "G ^ 2 \<ge> G"
+    by (simp add: power2_nat_le_imp_le)
+  then have "G ^ (2 * k + 2) \<ge> G"
+    by simp
+  then show ?thesis using G'_def
+    by linarith
+qed
+
+corollary enc_less_G': "\<forall>x\<in>set xs. x < G \<Longrightarrow> length xs = 2 * k + 2 \<Longrightarrow> enc xs < G'"
+  using enc_less G'_def by fastforce
+
+lemma enc_greater: "enc xs > 1"
+  using enc_def by simp
+
+
+subsection \<open>Construction of the simulator Turing machine\<close>
+
+text \<open>
+The simulator is a sequence of three Turing machines: The ``formatter'', which
+initializes the output tape; the loop, which simulates the TM $M$ for
+polynomially many steps; and a cleanup TM, which makes the output tape look like
+the output tape of $M$. All these machines are discussed in order in the
+following subsections.
+
+The simulator will start with $2k + 1$ memorization tapes for a total of $2k +
+3$ tapes. The simulation action will take place on the output tape.
+\<close>
+
+
+subsubsection \<open>Initializing the simulator's tapes\<close>
+
+text \<open>
+The function @{const T'} is polynomially bounded and therefore there is a
+polynomial-time two-tape oblivious Turing machine that outputs at least $T'(n)$
+symbols~@{text \<one>} on an input of length $n$, as we have proven in the previous
+section (lemma~@{thm [source] polystructor}). We now obtain such a Turing
+machine together with its running time bound and trace. This TM will be one of
+our blocks for building the simulator TM. We will call it the ``formatter''.
+
+\null
+\<close>
+
+definition fmt_es_pM :: "(nat \<Rightarrow> nat) \<times> (nat \<Rightarrow> (nat \<times> nat) list) \<times> machine" where
+  "fmt_es_pM \<equiv> SOME tec.
+    turing_machine 2 G' (snd (snd tec)) \<and>
+    big_oh_poly (\<lambda>n. length ((fst (snd tec)) n)) \<and>
+    big_oh_poly (fst tec) \<and>
+    (\<forall>n. T' n \<le> (fst tec) n) \<and>
+    (\<forall>zs. proper_symbols zs \<longrightarrow> traces (snd (snd tec)) (start_tapes_2 zs) ((fst (snd tec)) (length zs)) (one_tapes_2 zs ((fst tec) (length zs))))"
+
+lemma polystructor':
+  fixes GG :: nat and g :: "nat \<Rightarrow> nat"
+  assumes "big_oh_poly g" and "GG \<ge> 5"
+  shows "\<exists>f_es_M.
+    turing_machine 2 GG (snd (snd f_es_M)) \<and>
+    big_oh_poly (\<lambda>n. length ((fst (snd f_es_M)) n)) \<and>
+    big_oh_poly (fst f_es_M) \<and>
+    (\<forall>n. g n \<le> (fst f_es_M) n) \<and>
+    (\<forall>zs. proper_symbols zs \<longrightarrow> traces (snd (snd f_es_M)) (start_tapes_2 zs) ((fst (snd f_es_M)) (length zs)) (one_tapes_2 zs ((fst f_es_M) (length zs))))"
+  using polystructor[OF assms] by auto
+
+lemma fmt_es_pM: "turing_machine 2 G' (snd (snd fmt_es_pM)) \<and>
+    big_oh_poly (\<lambda>n. length ((fst (snd fmt_es_pM)) n)) \<and>
+    big_oh_poly (fst fmt_es_pM) \<and>
+    (\<forall>n. T' n \<le> (fst fmt_es_pM) n) \<and>
+    (\<forall>zs. proper_symbols zs \<longrightarrow> traces (snd (snd fmt_es_pM)) (start_tapes_2 zs) ((fst (snd fmt_es_pM)) (length zs)) (one_tapes_2 zs ((fst fmt_es_pM) (length zs))))"
+  using fmt_es_pM_def polystructor'[OF poly_T' G'_ge(2)]
+    someI_ex[of "\<lambda>tec.
+      turing_machine 2 G' (snd (snd tec)) \<and>
+      big_oh_poly (\<lambda>n. length ((fst (snd tec)) n)) \<and>
+      big_oh_poly (fst tec) \<and>
+      (\<forall>n. T' n \<le> (fst tec) n) \<and>
+      (\<forall>zs. proper_symbols zs \<longrightarrow> traces (snd (snd tec)) (start_tapes_2 zs) ((fst (snd tec)) (length zs)) (one_tapes_2 zs ((fst tec) (length zs))))"]
+  by simp
+
+definition fmt :: "nat \<Rightarrow> nat" where
+  "fmt \<equiv> fst fmt_es_pM"
+
+definition es_fmt :: "nat \<Rightarrow> (nat \<times> nat) list" where
+  "es_fmt \<equiv> fst (snd fmt_es_pM)"
+
+definition tm_fmt :: "machine" where
+  "tm_fmt \<equiv> snd (snd fmt_es_pM)"
+
+text \<open>
+The formatter TM is @{const tm_fmt}, the number of @{text \<one>} symbols written to
+the output tape on input of length $n$ is @{term "fmt n"}, and the trace on
+inputs of length $n$ is @{term "es_fmt n"}.
+\<close>
+
+lemma fmt:
+  "turing_machine 2 G' tm_fmt"
+  "big_oh_poly (\<lambda>n. length (es_fmt n))"
+  "big_oh_poly fmt"
+  "\<And>n. T' n \<le> fmt n"
+  "\<And>zs. proper_symbols zs \<Longrightarrow>
+    traces tm_fmt (start_tapes_2 zs) (es_fmt (length zs)) (one_tapes_2 zs (fmt (length zs)))"
+  unfolding fmt_def es_fmt_def tm_fmt_def using fmt_es_pM by simp_all
+
+lemma fmt_ge_n: "fmt n \<ge> n"
+  using fmt(4) T'_def by (metis dual_order.strict_trans2 le_less_linear not_add_less2)
+
+text \<open>
+The formatter is a two-tape TM. The first incarnation of the simulator will have
+two tapes and $2k + 1$ memorization tapes.  So for now we formally need to
+extend the formatter to $2k + 3$ tapes:
+\<close>
+
+definition "tm1 \<equiv> append_tapes 2 (2 * k + 3) tm_fmt"
+
+lemma tm1_tm: "turing_machine (2 * k + 3) G' tm1"
+  unfolding tm1_def using append_tapes_tm by (simp add: fmt(1))
+
+text \<open>
+Next we replace all non-blank symbols on the output tape by code symbols
+representing the tuple of $2k + 2$ zeros.
+\<close>
+
+definition "tm1_2 \<equiv> tm_const_until 1 1 {\<box>} (enc (replicate k 0 @ replicate k 0 @ [0, 0]))"
+
+lemma tm1_2_tm: "turing_machine (2 * k + 3) G' tm1_2"
+  unfolding tm1_2_def
+  using G'_ge
+proof (intro tm_const_until_tm, auto)
+  show "enc (replicate k 0 @ replicate k 0 @ [0, 0]) < G'"
+    using G_ge_4 by (intro enc_less_G', auto)
+qed
+
+definition "tm2 \<equiv> tm1 ;; tm1_2"
+
+lemma tm2_tm: "turing_machine (2 * k + 3) G' tm2"
+  unfolding tm2_def using tm1_tm tm1_2_tm by simp
+
+definition "tm3 \<equiv> tm2 ;; tm_start 1"
+
+lemma tm3_tm: "turing_machine (2 * k + 3) G' tm3"
+  unfolding tm3_def using tm2_tm tm_start_tm G'_ge by simp
+
+text \<open>
+Back at the start symbol of the output tape, we replace it by the code symbol
+for the tuple $1^k1^k01$. The first $k$ ones represent that initially the $k$
+tapes of $M$ have the start symbol (numerically 1) in the leftmost cell.  The
+second run of $k$ ones represent that initially all $k$ tapes have their tape
+heads in the leftmost cell. The following 0 is the first bit of the unary
+counter, currently set to zero. The final flag~1  signals that this is the
+leftmost cell. Unlike the start symbols this signal flag cannot be overwritten
+by $M$.
+\<close>
+
+definition "tm4 \<equiv> tm3 ;; tm_write 1 (enc (replicate k 1 @ replicate k 1 @ [0, 1]))"
+
+lemma tm3_4_tm: "turing_machine (2 * k + 3) G' (tm_write 1 (enc (replicate k 1 @ replicate k 1 @ [0, 1])))"
+  using G'_ge enc_less_G' G_ge_4 tm_write_tm by simp
+
+lemma tm4_tm: "turing_machine (2 * k + 3) G' tm4"
+  unfolding tm4_def using tm3_tm tm3_4_tm by simp
+
+definition "tm5 \<equiv> tm4 ;; tm_right 1"
+
+lemma tm5_tm: "turing_machine (2 * k + 3) G' tm5"
+  unfolding tm5_def using tm4_tm by (simp add: G'_ge(1) tm_right_tm)
+
+text \<open>
+So far the simulator's output tape encodes $k$ tapes that are empty but for the
+start symbols. To represent the start configuration of $M$, we need to copy the
+contents of the input tape to the output tape. The following TM moves the work
+head to the first blank while copying the input tape content. Here we exploit
+$T'(n) \geq n$, which implies that the formatted section is long enough to hold
+the input.
+\<close>
+
+definition "tm5_6 \<equiv> tm_trans_until 0 1 {0} (\<lambda>h. enc (h mod G # replicate (k - 1) 0 @ replicate k 0 @ [0, 0]))"
+
+definition "tm6 \<equiv> tm5 ;; tm5_6"
+
+lemma tm5_6_tm: "turing_machine (2 * k + 3) G' tm5_6"
+  unfolding tm5_6_def
+proof (rule tm_trans_until_tm, auto simp add: G'_ge(1) G_ge_4 k_ge_2 enc_less_G')
+  show "\<And>h. h < G' \<Longrightarrow> enc (h mod G # replicate (k - Suc 0) 0 @ replicate k 0 @ [0, 0]) < G'"
+    using G_ge_4 k_ge_2 enc_less_G' by simp
+qed
+
+lemma tm6_tm: "turing_machine (2 * k + 3) G' tm6"
+  unfolding tm6_def using tm5_tm tm5_6_tm by simp
+
+text \<open>
+Since we have overwritten the leftmost cell of the output tape with some code
+symbol, we cannot return to it using @{const tm_start}. But we can use @{const
+tm_left_until} with a special set of symbols:
+\<close>
+
+abbreviation StartSym :: "symbol set" where
+  "StartSym \<equiv> {y. y < G ^ (2 * k + 2) + 2 \<and> y > 1 \<and> dec y ! (2 * k + 1) = 1}"
+
+abbreviation "tm_left_until1 \<equiv> tm_left_until StartSym 1"
+
+lemma tm_left_until1_tm: "turing_machine (2 * k + 3) G' tm_left_until1"
+  using tm_left_until_tm G'_ge(1) k_ge_2 by simp
+
+definition "tm7 \<equiv> tm6 ;; tm_left_until1"
+
+lemma tm7_tm: "turing_machine (2 * k + 3) G' tm7"
+  unfolding tm7_def using tm6_tm tm_left_until1_tm by simp
+
+text \<open>
+Tape number $2$ is meant to memorize $M$'s state during the simulation.
+Initially the state is the start state, that is, zero.
+\<close>
+
+definition "tm8 \<equiv> tm7 ;; tm_write 2 0"
+
+lemma tm8_tm: "turing_machine (2 * k + 3) G' tm8"
+  unfolding tm8_def using tm7_tm tm_write_tm k_ge_2 G'_ge(1) by simp
+
+text \<open>
+We also initialize memorization tapes $3, \dots, 2k + 2$ to zero. This concludes
+the initialization of the simulator's tapes.
+\<close>
+
+definition "tm9 \<equiv> tm8 ;; tm_write_many {3..<2 * k + 3} 0"
+
+lemma tm9_tm: "turing_machine (2 * k + 3) G' tm9"
+  unfolding tm9_def using tm8_tm tm_write_many_tm k_ge_2 G'_ge(1) by simp
+
+
+subsubsection \<open>The loop\<close>
+
+text \<open>
+The core of the simulator is a loop whose body is executed @{term "fmt n"} many
+times. Each iteration simulates one step of the Turing machine $M$.  For the
+analysis of the loop we describe the $2k + 3$ tapes in the form @{term "[a, b,
+c] @ map f1 [0..<k] @ map f2 [0..<k]"}.
+\<close>
+
+lemma threeplus2k_2:
+  assumes "3 \<le> j \<and> j < k + 3"
+  shows "([a, b, c] @ map f1 [0..<k] @ map f2 [0..<k]) ! j = f1 (j - 3)"
+  using assms by (simp add: nth_append less_diff_conv2 numeral_3_eq_3)
+
+lemma threeplus2k_3:
+  assumes "k + 3 \<le> j \<and> j < 2 * k + 3"
+  shows "([a, b, c] @ map f1 [0..<k] @ map f2 [0..<k]) ! j = f2 (j - k - 3)"
+  using assms by (simp add: nth_append less_diff_conv2 numeral_3_eq_3)
+
+text \<open>
+To ensure the loop runs for @{term "fmt n"} iterations we increment the unary
+counter in the code symbols in each iteration. The loop terminates when there
+are no more code symbols with an unset counter flag. The TM that prepares the
+loop condition sweeps the output tape left-to-right searching for the first symbol
+that is either blank or has an unset counter flag. The condition then checks for
+which of the two cases occurred. This is the condition TM: \<close>
+
+definition "tmC \<equiv> tm_right_until 1 {y. y < G ^ (2 * k + 2) + 2 \<and> (y = 0 \<or> dec y ! (2 * k) = 0)}"
+
+lemma tmC_tm: "turing_machine (2 * k + 3) G' tmC"
+  using tmC_def tm_right_until_tm using G'_ge(1) by simp
+
+text \<open>
+At the start of the iteration, the memorization tape~2 has the state of $M$, and
+all other memorization tapes contain $0$. The output tape head is at the leftmost
+code symbol with unset counter flag. The first order of business is to move back
+to the beginning of the output tape.
+\<close>
+
+definition "tmL1 \<equiv> tm_left_until1"
+
+lemma tmL1_tm: "turing_machine (2 * k + 3) G' tmL1"
+  unfolding tmL1_def using tm6_tm tm_left_until1_tm by simp
+
+text \<open>
+Then the output tape head sweeps right until it encounters a blank. During the
+sweep the Turing machine checks for any set head flags, and if it finds the one
+for tape $j$ set, it memorizes the symbol for tape $j$ on tape $3 + k + j$.  The
+next command performs this operation:
+\<close>
+
+definition cmdL2 :: command where
+  "cmdL2 rs \<equiv>
+    (if rs ! 1 = \<box>
+     then (1, zip rs (replicate (2*k+3) Stay))
+     else
+      (0,
+       [(rs!0, Stay), (rs!1, Right), (rs!2, Stay)] @
+       (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+       (map (\<lambda>j. (if 1 < rs ! 1 \<and> rs ! 1 < G^(2*k+2)+2 \<and> enc_nth (rs!1) (k+j) = 1 then enc_nth (rs!1) j else rs!(3+k+j), Stay)) [0..<k])))"
+
+lemma cmdL2_at_eq_0:
+  assumes "rs ! 1 = 0" and "j < 2 * k + 3" and "length rs = 2 * k + 3"
+  shows "snd (cmdL2 rs) ! j = (rs ! j, Stay)"
+  using assms by (simp add: cmdL2_def)
+
+lemma cmdL2_at_3:
+  assumes "rs ! 1 \<noteq> \<box>" and "3 \<le> j \<and> j < k + 3"
+  shows "cmdL2 rs [!] j = (rs ! j, Stay)"
+  using cmdL2_def assms threeplus2k_2
+  by (metis (no_types, lifting) le_add_diff_inverse2 snd_conv)
+
+lemma cmdL2_at_4:
+  assumes "rs ! 1 \<noteq> \<box>" and "k + 3 \<le> j \<and> j < 2 * k + 3"
+  shows "cmdL2 rs [!] j =
+     (if 1 < rs ! 1 \<and> rs ! 1 < G^(2*k+2)+2 \<and> enc_nth (rs ! 1) (j-3) = 1
+      then enc_nth (rs ! 1) (j-k-3)
+      else rs ! j, Stay)"
+  unfolding cmdL2_def using assms threeplus2k_3[OF assms(2), of "(rs ! 0, Stay)"] by simp
+
+lemma cmdL2_at_4'':
+  assumes "rs ! 1 \<noteq> \<box>"
+    and "k + 3 \<le> j \<and> j < 2 * k + 3"
+    and "\<not> (1 < rs ! 1 \<and> rs ! 1 < G^(2*k+2)+2)"
+  shows "cmdL2 rs [!] j = (rs ! j, Stay)"
+proof -
+  have "cmdL2 rs [!] j =
+      (if 1 < rs ! 1 \<and> rs ! 1 < G^(2*k+2)+2 \<and> enc_nth (rs!1) (j-3) = 1 then enc_nth (rs!1) (j-k-3) else rs!j, Stay)"
+    using assms cmdL2_at_4 by blast
+  then show ?thesis
+    using assms(3) by auto
+qed
+
+lemma turing_command_cmdL2: "turing_command (2 * k + 3) 1 G' cmdL2"
+proof
+  show "\<And>gs. length gs = 2 * k + 3 \<Longrightarrow> length ([!!] cmdL2 gs) = length gs"
+    unfolding cmdL2_def by simp
+  show "\<And>gs. length gs = 2 * k + 3 \<Longrightarrow> 0 < 2 * k + 3 \<Longrightarrow> cmdL2 gs [.] 0 = gs ! 0"
+    unfolding cmdL2_def by simp
+  show "cmdL2 gs [.] j < G'"
+      if "length gs = 2 * k + 3" "\<And>i. i < length gs \<Longrightarrow> gs ! i < G'" "j < length gs"
+      for gs j
+  proof (cases "gs ! 1 = 0")
+    case True
+    then have "cmdL2 gs = (1, zip gs (replicate (2*k+3) Stay))"
+      unfolding cmdL2_def by simp
+    have "cmdL2 gs [.] j = gs ! j"
+      using that(1,3) by (simp add: \<open>cmdL2 gs = (1, zip gs (replicate (2 * k + 3) Stay))\<close>)
+    then show ?thesis
+      using that(2,3) by simp
+  next
+    case False
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using \<open>j < length gs\<close> \<open>length gs = 2 * k + 3\<close> by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        by (simp add: cmdL2_def that(1) that(2))
+    next
+      case 2
+      then show ?thesis
+        unfolding cmdL2_def using False that by auto
+    next
+      case 3
+      then show ?thesis
+        unfolding cmdL2_def using False that by auto
+    next
+      case 4
+      then have "snd (cmdL2 gs) ! j = (gs ! j, Stay)"
+        unfolding cmdL2_def using False that threeplus2k_2[OF 4, of "(gs ! 0, Stay)"] by simp
+      then show ?thesis
+        using that by (simp add: \<open>snd (cmdL2 gs) ! j = (gs ! j, Stay)\<close>)
+    next
+      case 5
+      show ?thesis
+      proof (cases "1 < gs ! 1 \<and> gs ! 1 < G ^ (2*k+2) + 2")
+        case True
+        then have *: "cmdL2 gs [.] j = (if enc_nth (gs ! 1) (j-3) = 1 then enc_nth (gs ! 1) (j-k-3) else gs ! j)"
+          using 5 False by (simp add: cmdL2_at_4)
+        let ?n = "gs ! 1"
+        have len: "length (dec ?n) = 2 * k + 2" and less_G: "\<forall>x\<in>set (dec ?n). x < G"
+          using True length_dec dec_less_G by (simp, blast)
+        have **: "enc_nth ?n (j-k-3) = dec ?n ! (j-k-3)"
+          using enc_nth_dec True by simp
+        then have "dec ?n ! (j-k-3) < G"
+          using less_G 5 len by auto
+        then have "dec ?n ! (j-k-3) < G'"
+          using G'_ge_G by simp
+        moreover have "gs ! j < G'"
+          using that by simp
+        ultimately show ?thesis
+          using * ** by simp
+      next
+        case 6: False
+        have "cmdL2 gs [!] j = (gs ! j, Stay)"
+          using cmdL2_at_4''[OF False 5 6] by simp
+        then show ?thesis
+          using that by (simp add: \<open>snd (cmdL2 gs) ! j = (gs ! j, Stay)\<close>)
+      qed
+    qed
+  qed
+  show "\<And>gs. length gs = 2 * k + 3 \<Longrightarrow> [*] (cmdL2 gs) \<le> 1"
+    using cmdL2_def by simp
+qed
+
+definition "tmL1_2 \<equiv> [cmdL2]"
+
+lemma tmL1_2_tm: "turing_machine (2 * k + 3) G' tmL1_2"
+  using tmL1_2_def using turing_command_cmdL2 G'_ge by auto
+
+definition "tmL2 \<equiv> tmL1 ;; tmL1_2"
+
+lemma tmL2_tm: "turing_machine (2 * k + 3) G' tmL2"
+  by (simp add: tmL1_2_tm tmL1_tm tmL2_def)
+
+text \<open>
+The memorization tapes $3, \dots, 2 + k$ will store the head movements for
+tapes $0, \dots, k - 1$ of $M$. The directions are encoded as symbols thus:
+\<close>
+
+definition direction_to_symbol :: "direction \<Rightarrow> symbol" where
+  "direction_to_symbol m \<equiv> (case m of Left \<Rightarrow> \<box> | Stay \<Rightarrow> \<triangleright> | Right \<Rightarrow> \<zero>)"
+
+lemma direction_to_symbol_less: "direction_to_symbol m < 3"
+  using direction_to_symbol_def by (cases m) simp_all
+
+text \<open>
+At this point in the iteration the memorization tapes $k + 3, \dots, 2k+2$
+contain the symbols under the $k$ tape heads of $M$, and tape $2$ contains the
+state $M$ is in. Therefore all information is available to determine the actions
+$M$ is taking in the step currently simulated.  The next command has the entire
+behavior of $M$ ``hard-coded'' and causes the actions to be stored on
+memorization tapes $3, \dots, 2k+2$: the output symbols on the tapes $k + 3,
+\dots, 2k + 2$, and the $k$ head movements on the tapes $3, \dots, k + 2$. The
+follow-up state will again be memorized on tape $2$. All this happens in one
+step of the simulator machine.
+\<close>
+
+definition cmdL3 :: command where
+  "cmdL3 rs \<equiv>
+   (1,
+    [(rs ! 0, Stay),
+     (rs ! 1, Stay),
+     (if rs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) rs). h < G)
+      then fst ((M ! (rs ! 2)) (drop (k + 3) rs))
+      else rs ! 2, Stay)] @
+    map
+      (\<lambda>j. (if rs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) rs). h < G) then direction_to_symbol ((M ! (rs ! 2)) (drop (k + 3) rs) [~] j) else 1, Stay))
+      [0..<k] @
+    map (\<lambda>j. (if rs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) rs). h < G) then ((M ! (rs ! 2)) (drop (k + 3) rs) [.] j) else rs ! (k + 3 + j), Stay)) [0..<k])"
+
+lemma cmdL3_at_2a:
+  assumes "gs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) gs). h < G)"
+  shows "cmdL3 gs [!] 2 = (fst ((M ! (gs ! 2)) (drop (k + 3) gs)), Stay)"
+  using cmdL3_def assms by simp
+
+lemma cmdL3_at_2b:
+  assumes "\<not> (gs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) gs). h < G))"
+  shows "cmdL3 gs [!] 2 = (gs ! 2, Stay)"
+  using cmdL3_def assms by auto
+
+lemma cmdL3_at_3a:
+  assumes "3 \<le> j \<and> j < k + 3"
+    and "gs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) gs). h < G)"
+  shows "cmdL3 gs [!] j = (direction_to_symbol ((M ! (gs ! 2)) (drop (k + 3) gs) [~] (j - 3)), Stay)"
+  using cmdL3_def assms(2) threeplus2k_2[OF assms(1), of "(gs ! 0, Stay)"] by simp
+
+lemma cmdL3_at_3b:
+  assumes "3 \<le> j \<and> j < k + 3"
+    and "\<not> (gs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) gs). h < G))"
+  shows "cmdL3 gs [!] j = (1, Stay)"
+  using cmdL3_def assms(2) threeplus2k_2[OF assms(1), of "(gs ! 0, Stay)"] by auto
+
+lemma cmdL3_at_4a:
+  assumes "k + 3 \<le> j \<and> j < 2 * k + 3"
+    and "gs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) gs). h < G)"
+  shows "cmdL3 gs [!] j = ((M ! (gs ! 2)) (drop (k + 3) gs) [.] (j - k - 3), Stay)"
+  using cmdL3_def assms(2) threeplus2k_3[OF assms(1), of "(gs ! 0, Stay)"] by simp
+
+lemma cmdL3_at_4b:
+  assumes "k + 3 \<le> j \<and> j < 2 * k + 3"
+    and "\<not> (gs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) gs). h < G))"
+  shows "cmdL3 gs [!] j = (gs ! j, Stay)"
+  using assms cmdL3_def threeplus2k_3[OF assms(1), of "(gs ! 0, Stay)"] by auto
+
+lemma cmdL3_if_comm:
+  assumes "length gs = 2 * k + 3" and "gs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) gs). h < G)"
+  shows "length ([!!] (M ! (gs ! 2)) (drop (k + 3) gs)) = k"
+    and "\<And>j. j < k \<Longrightarrow> (M ! (gs ! 2)) (drop (k + 3) gs) [.] j < G"
+proof -
+  let ?rs = "drop (k + 3) gs"
+  let ?cmd = "M ! (gs ! 2)"
+  have *: "turing_command k (length M) G ?cmd"
+    using assms(2) tm_M turing_machineD(3) by simp
+  then show "length ([!!] ?cmd ?rs) = k"
+    using turing_commandD(1) assms(1) by simp
+  have "\<And>i. i < length ?rs \<Longrightarrow> ?rs ! i < G"
+    using assms(2) nth_mem by blast
+  then show "\<And>j. j < k \<Longrightarrow> (M ! (gs ! 2)) (drop (k + 3) gs) [.] j < G"
+    using * turing_commandD(2) assms by simp
+qed
+
+lemma turing_command_cmdL3: "turing_command (2 * k + 3) 1 G' cmdL3"
+proof
+  show "\<And>gs. length gs = 2 * k + 3 \<Longrightarrow> length ([!!] cmdL3 gs) = length gs"
+    using cmdL3_def by simp
+  show "\<And>gs. length gs = 2 * k + 3 \<Longrightarrow> 0 < 2 * k + 3 \<Longrightarrow> cmdL3 gs [.] 0 = gs ! 0"
+    using cmdL3_def by simp
+  show "cmdL3 gs [.] j < G'"
+    if "length gs = 2 * k + 3" "\<And>i. i < length gs \<Longrightarrow> gs ! i < G'" "j < length gs"
+    for gs j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using \<open>j < length gs\<close> \<open>length gs = 2 * k + 3\<close> by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using that cmdL3_def by simp
+    next
+      case 2
+      then show ?thesis
+        using that cmdL3_def by simp
+    next
+      case 3
+      then show ?thesis
+      proof (cases "gs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) gs). h < G)")
+        case True
+        have "length (drop (k + 3) gs) = k"
+          using that(1) by simp
+        then have "fst ((M ! (gs ! 2)) (drop (k + 3) gs)) \<le> length M"
+          using True turing_commandD(4) tm_M turing_machineD(3) by blast
+        moreover have "cmdL3 gs [.] j = fst ((M ! (gs ! 2)) (drop (k + 3) gs))"
+          using cmdL3_def True 3 by simp
+        ultimately show ?thesis
+          using G'_def by simp
+      next
+        case False
+        then have "cmdL3 gs [.] j = gs ! 2"
+          using cmdL3_def 3 by auto
+        then show ?thesis
+          using 3 that(2,3) by simp
+      qed
+    next
+      case 4
+      then show ?thesis
+      proof (cases "gs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) gs). h < G)")
+        case True
+        then have "cmdL3 gs [.] j = direction_to_symbol ((M ! (gs ! 2)) (drop (k + 3) gs) [~] (j - 3))"
+          using cmdL3_at_3a 4 by simp
+        then have "cmdL3 gs [.] j < 3"
+          using direction_to_symbol_less by simp
+        then show ?thesis
+          using G'_ge by simp
+      next
+        case False
+        then show ?thesis
+          using cmdL3_at_3b[OF 4] G'_ge by simp
+      qed
+    next
+      case 5
+      then show ?thesis
+      proof (cases "gs ! 2 < length M \<and> (\<forall>h\<in>set (drop (k + 3) gs). h < G)")
+        case True
+        then have "cmdL3 gs [.] j = (M ! (gs ! 2)) (drop (k + 3) gs) [.] (j - k - 3)"
+          using cmdL3_at_4a[OF 5] by simp
+        then have "cmdL3 gs [.] j < G"
+          using cmdL3_if_comm True 5 that(1) by auto
+        then show ?thesis
+          using G'_ge_G by simp
+      next
+        case False
+        then have "cmdL3 gs [.] j = gs ! j"
+          using cmdL3_at_4b[OF 5] by simp
+        then show ?thesis
+          using that by simp
+      qed
+    qed
+  qed
+  show "\<And>gs. length gs = 2 * k + 3 \<Longrightarrow> [*] (cmdL3 gs) \<le> 1"
+    using cmdL3_def by simp
+qed
+
+definition "tmL2_3 \<equiv> [cmdL3]"
+
+lemma tmL2_3_tm: "turing_machine (2 * k + 3) G' tmL2_3"
+  unfolding tmL2_3_def using G'_ge(1) turing_command_cmdL3 by auto
+
+definition "tmL3 \<equiv> tmL2 ;; tmL2_3"
+
+lemma tmL3_tm: "turing_machine (2 * k + 3) G' tmL3"
+  by (simp add: tmL2_3_tm tmL2_tm tmL3_def)
+
+text \<open>
+Next the output tape head sweeps left to the beginning of the tape, otherwise
+doing nothing.
+\<close>
+
+definition "tmL4 \<equiv> tmL3 ;; tm_left_until1"
+
+lemma tmL4_tm: "turing_machine (2 * k + 3) G' tmL4"
+  using tmL3_tm tmL4_def tmL1_def tm_left_until1_tm by simp
+
+text \<open>
+The next four commands @{term cmdL4}, @{term cmdL5}, @{term cmdL6}, @{term
+cmdL7} are parameterized by $jj = 0, \dots, k - 1$. Their job is applying the
+write operation and head movement for tape $jj$ of $M$. The entire block of
+commands will then be executed $k$ times, once for each $jj$.
+
+The first of these commands sweeps right again and applies the write operation
+for tape $jj$, which is memorized on tape $3 + k + jj$. To this end it checks for head flags and
+updates the code symbol component $jj$ with the contents of tape $3+k+jj$ when
+the head flag for tape $jj$ is set.
+\<close>
+
+definition "cmdL5 jj rs \<equiv>
+  if rs ! 1 = \<box>
+  then (1, zip rs (replicate (2*k+3) Stay))
+  else
+   (0,
+    [(rs ! 0, Stay),
+     (if is_code (rs ! 1) \<and> rs ! (3+k+jj) < G \<and> enc_nth (rs ! 1) (k+jj) = 1
+      then enc_upd (rs ! 1) jj (rs ! (3+k+jj))
+      else rs ! 1,
+      Right),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k]))"
+
+lemma cmdL5_eq_0:
+  assumes "j < 2 * k + 3" and "length gs = 2 * k + 3" and "gs ! 1 = 0"
+  shows "cmdL5 jj gs [!] j = (gs ! j, Stay)"
+  unfolding cmdL5_def using assms by simp
+
+lemma cmdL5_at_0:
+  assumes "gs ! 1 \<noteq> 0"
+  shows "cmdL5 jj gs [!] 0 = (gs ! 0, Stay)"
+  unfolding cmdL5_def using assms by simp
+
+lemma cmdL5_at_1:
+  assumes "gs ! 1 \<noteq> 0"
+    and "is_code (gs ! 1) \<and> gs ! (3+k+jj) < G \<and> enc_nth (gs!1) (k+jj) = 1"
+  shows "cmdL5 jj gs [!] 1 = (enc_upd (gs!1) jj (gs!(3+k+jj)), Right)"
+  unfolding cmdL5_def using assms by simp
+
+lemma cmdL5_at_1_else:
+  assumes "gs ! 1 \<noteq> 0"
+    and "\<not> (is_code (gs ! 1) \<and> gs ! (3+k+jj) < G \<and> enc_nth (gs!1) (k+jj) = 1)"
+  shows "cmdL5 jj gs [!] 1 = (gs ! 1, Right)"
+  unfolding cmdL5_def using assms by auto
+
+lemma cmdL5_at_2:
+  assumes "gs ! 1 \<noteq> 0"
+  shows "cmdL5 jj gs [!] 2 = (gs ! 2, Stay)"
+  unfolding cmdL5_def using assms by simp
+
+lemma cmdL5_at_3:
+  assumes "gs ! 1 \<noteq> 0" and "3 \<le> j \<and> j < 3 + k"
+  shows "cmdL5 jj gs [!] j = (gs ! j, Stay)"
+  unfolding cmdL5_def using assms threeplus2k_2[where ?a="(gs ! 0, Stay)"] by simp
+
+lemma cmdL5_at_4:
+  assumes "gs ! 1 \<noteq> 0" and "3 + k \<le> j \<and> j < 2 * k + 3"
+  shows "cmdL5 jj gs [!] j = (gs ! j, Stay)"
+  unfolding cmdL5_def using assms threeplus2k_3[where ?a="(gs ! 0, Stay)"] by simp
+
+lemma turing_command_cmdL5:
+  assumes "jj < k"
+  shows "turing_command (2 * k + 3) 1 G' (cmdL5 jj)"
+proof
+  show "length gs = 2 * k + 3 \<Longrightarrow> length ([!!] cmdL5 jj gs) = length gs" for gs
+    unfolding cmdL5_def by (cases "gs!1=0") simp_all
+  show goal2: "length gs = 2 * k + 3 \<Longrightarrow> 0 < 2 * k + 3 \<Longrightarrow> cmdL5 jj gs [.] 0 = gs ! 0" for gs
+    unfolding cmdL5_def by (cases "gs ! 1=0") simp_all
+  show "cmdL5 jj gs [.] j < G'"
+    if "length gs = 2 * k + 3" "\<And>i. i < length gs \<Longrightarrow> gs ! i < G'" "j < length gs"
+    for gs j
+  proof (cases "gs ! 1 = 0")
+    case True
+    then show ?thesis
+      using that cmdL5_eq_0 by simp
+  next
+    case False
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `length gs = 2 * k + 3` `j < length gs` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using that goal2 by simp
+    next
+      case 2
+      show ?thesis
+      proof (cases "1 < gs ! 1 \<and> gs ! 1 < G^(2*k+2)+2 \<and> gs ! (3+k+jj) < G \<and> enc_nth (gs ! 1) (k+jj) = 1")
+        case True
+        then have *: "cmdL5 jj gs [.] j = enc_upd (gs ! 1) jj (gs ! (3+k+jj))"
+          using 2 cmdL5_at_1[OF False] by simp
+        let ?n = "gs ! 1"
+        let ?xs = "dec ?n"
+        let ?ys = "(dec ?n) [jj:=gs!(3+k+jj)]"
+        have "gs ! (3+k+jj) < G"
+          using True by simp
+        moreover have "\<forall>h\<in>set (dec ?n). h < G"
+          using True dec_less_G by auto
+        ultimately have "\<forall>h\<in>set ?ys. h < G"
+          by (metis in_set_conv_nth length_list_update nth_list_update_eq nth_list_update_neq)
+        moreover have "length ?ys = 2 * k + 2"
+          using True length_dec by simp
+        ultimately have "enc ?ys < G ^ (2 * k + 2) + 2"
+          using enc_less by simp
+        then show ?thesis
+          using * by (simp add: enc_upd_def G'_def)
+      next
+        case b: False
+        then show ?thesis
+          using that cmdL5_at_1_else[OF False] 2 by simp
+      qed
+    next
+      case 3
+      then show ?thesis
+        using that cmdL5_at_2[OF False] by simp
+    next
+      case 4
+      then show ?thesis
+        using that cmdL5_at_3[OF False] by simp
+    next
+      case 5
+      then show ?thesis
+        using that cmdL5_at_4[OF False] by simp
+    qed
+  qed
+  show "\<And>gs. length gs = 2 * k + 3 \<Longrightarrow> [*] (cmdL5 jj gs) \<le> 1"
+    using cmdL5_def by (metis (no_types, lifting) One_nat_def fst_conv le_eq_less_or_eq plus_1_eq_Suc trans_le_add2)
+
+qed
+
+definition tmL45 :: "nat \<Rightarrow> machine" where
+  "tmL45 jj \<equiv> [cmdL5 jj]"
+
+lemma tmL45_tm:
+  assumes "jj < k"
+  shows "turing_machine (2 * k + 3) G' (tmL45 jj)"
+  using assms G'_ge turing_command_cmdL5 tmL45_def by auto
+
+text \<open>
+We move the output tape head one cell to the left.
+\<close>
+
+definition "tmL46 jj \<equiv> tmL45 jj ;; tm_left 1"
+
+lemma tmL46_tm:
+  assumes "jj < k"
+  shows "turing_machine (2 * k + 3) G' (tmL46 jj)"
+  using assms G'_ge tm_left_tm tmL45_tm tmL46_def tmL45_def by simp
+
+text \<open>
+The next command sweeps left and applies the head movement for tape $jj$ if this
+is a movement to the left. To this end it checks for a set head flag in
+component $k + jj$ of the code symbol and clears it. It also memorizes that it
+just cleared the head flag by changing the symbol on memorization tape $3 + jj$
+to the number $3$, which is not used to encode any actual head movement. In the
+next step of the sweep it will recognize this $3$ and set the head flag in
+component $k + jj$ of the code symbol. The net result is that the head flag for
+tape $jj$ has moved one cell to the left.
+\<close>
+
+abbreviation is_beginning :: "symbol \<Rightarrow> bool" where
+  "is_beginning y \<equiv> is_code y \<and> dec y ! (2 * k + 1) = 1"
+
+definition cmdL7 :: "nat \<Rightarrow> command" where
+  "cmdL7 jj rs \<equiv>
+ (if is_beginning (rs ! 1) then 1 else 0,
+  if rs ! (3 + jj) = \<box> \<and> enc_nth (rs ! 1) (k + jj) = 1 \<and> is_code (rs ! 1) \<and> \<not> is_beginning (rs ! 1) then
+   [(rs ! 0, Stay),
+    (enc_upd (rs ! 1) (k + jj) 0, Left),
+    (rs ! 2, Stay)] @
+    (map (\<lambda>j. (if j = jj then 3 else rs ! (j + 3), Stay)) [0..<k]) @
+    (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])
+  else if rs ! (3 + jj) = 3 \<and> is_code (rs ! 1) then
+   [(rs ! 0, Stay),
+    (enc_upd (rs ! 1) (k + jj) 1, Left),
+    (rs ! 2, Stay)] @
+    (map (\<lambda>j. (if j = jj then 0 else rs ! (j + 3), Stay)) [0..<k]) @
+    (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])
+  else
+   [(rs ! 0, Stay),
+    (rs ! 1, Left),
+    (rs ! 2, Stay)] @
+    (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+    (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k]))"
+
+abbreviation "condition7a gs jj \<equiv>
+  gs ! (3 + jj) = 0 \<and> enc_nth (gs ! 1) (k + jj) = 1 \<and> is_code (gs ! 1) \<and> \<not> is_beginning (gs ! 1)"
+abbreviation "condition7b gs jj \<equiv>
+  \<not> condition7a gs jj \<and> gs ! (3 + jj) = 3 \<and> is_code (gs ! 1)"
+abbreviation "condition7c gs jj \<equiv>
+  \<not> condition7a gs jj \<and> \<not> condition7b gs jj"
+
+lemma turing_command_cmdL7:
+  assumes "jj < k"
+  shows "turing_command (2 * k + 3) 1 G' (cmdL7 jj)"
+proof
+  show "length ([!!] cmdL7 jj gs) = length gs" if "length gs = 2 * k + 3" for gs
+  proof -
+    consider "condition7a gs jj" | "condition7b gs jj" | "condition7c gs jj"
+      by blast
+    then show ?thesis
+      unfolding cmdL7_def using that by (cases) simp_all
+  qed
+  show goal2: "0 < 2 * k + 3 \<Longrightarrow> cmdL7 jj gs [.] 0 = gs ! 0" if "length gs = 2 * k + 3" for gs
+  proof -
+    consider "condition7a gs jj" | "condition7b gs jj" | "condition7c gs jj"
+      by blast
+    then show ?thesis
+      unfolding cmdL7_def using that by (cases) simp_all
+  qed
+  show "cmdL7 jj gs [.] j < G'"
+    if gs: "j < length gs" "length gs = 2 * k + 3" "\<And>i. i < length gs \<Longrightarrow> gs ! i < G'"
+    for gs j
+  proof -
+    consider "condition7a gs jj" | "condition7b gs jj" | "condition7c gs jj"
+      by blast
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have *: "snd (cmdL7 jj gs) =
+        [(gs ! 0, Stay),
+         (enc_upd (gs ! 1) (k + jj) 0, Left),
+         (gs ! 2, Stay)] @
+         (map (\<lambda>j. (if j = jj then 3 else gs ! (j + 3), Stay)) [0..<k]) @
+         (map (\<lambda>j. (gs ! (3 + k + j), Stay)) [0..<k])"
+        unfolding cmdL7_def by simp
+      consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+        using gs by linarith
+      then show ?thesis
+      proof (cases)
+        case 1
+        then show ?thesis
+          using that by (simp add: goal2)
+      next
+        case 2
+        then have "is_code (gs ! 1)"
+          using 1 by blast
+        moreover have "k + jj < 2 * k + 2"
+          using assms by simp
+        moreover have "0 < G"
+          using G_ge_4 by simp
+        ultimately have "is_code (enc_upd (gs ! 1) (k + jj) 0)"
+          using enc_upd_is_code by simp
+        then have "is_code (cmdL7 jj gs [.] j)"
+          using * 2 by simp
+        then show ?thesis
+          using G'_ge_G G'_def by simp
+      next
+        case 3
+        then show ?thesis
+          using * gs by simp
+      next
+        case 4
+        then show ?thesis
+          using * gs G'_ge threeplus2k_2[where ?a="(gs ! 0, Stay)"] by simp
+      next
+        case 5
+        then show ?thesis
+          using * gs G'_ge threeplus2k_3[where ?a="(gs ! 0, Stay)"] by simp
+      qed
+    next
+      case case2: 2
+      then have *: "snd (cmdL7 jj gs) =
+        [(gs ! 0, Stay),
+         (enc_upd (gs ! 1) (k + jj) 1, Left),
+         (gs ! 2, Stay)] @
+         (map (\<lambda>j. (if j = jj then 0 else gs ! (j + 3), Stay)) [0..<k]) @
+         (map (\<lambda>j. (gs ! (3 + k + j), Stay)) [0..<k])"
+        unfolding cmdL7_def by simp
+      consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+        using gs by linarith
+      then show ?thesis
+      proof (cases)
+        case 1
+        then show ?thesis
+          using that by (simp add: goal2)
+      next
+        case 2
+        then have "is_code (gs ! 1)"
+          using case2 by simp
+        moreover have "k + jj < 2 * k + 2"
+          using assms by simp
+        moreover have "1 < G"
+          using G_ge_4 by simp
+        ultimately have "is_code (enc_upd (gs ! 1) (k + jj) 1)"
+          using enc_upd_is_code by simp
+        then have "is_code (cmdL7 jj gs [.] j)"
+          using * 2 by simp
+        then show ?thesis
+          using G'_ge_G G'_def by simp
+      next
+        case 3
+        then show ?thesis
+          using * gs by simp
+      next
+        case 4
+        then show ?thesis
+          using * gs G'_ge threeplus2k_2[where ?a="(gs ! 0, Stay)"] by simp
+      next
+        case 5
+        then show ?thesis
+          using * gs G'_ge threeplus2k_3[where ?a="(gs ! 0, Stay)"] by simp
+      qed
+    next
+      case case3: 3
+      then have *: "snd (cmdL7 jj gs) =
+        [(gs ! 0, Stay),
+         (gs ! 1, Left),
+         (gs ! 2, Stay)] @
+         (map (\<lambda>j. (gs ! (j + 3), Stay)) [0..<k]) @
+         (map (\<lambda>j. (gs ! (3 + k + j), Stay)) [0..<k])"
+        unfolding cmdL7_def by auto
+      consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+        using gs by linarith
+      then show ?thesis
+        using * gs G'_ge threeplus2k_2[where ?a="(gs ! 0, Stay)"] threeplus2k_3[where ?a="(gs ! 0, Stay)"]
+        by (cases) simp_all
+    qed
+  qed
+  show "\<And>gs. length gs = 2 * k + 3 \<Longrightarrow> [*] (cmdL7 jj gs) \<le> 1"
+    using cmdL7_def by simp
+qed
+
+definition tmL67 :: "nat \<Rightarrow> machine" where
+  "tmL67 jj \<equiv> [cmdL7 jj]"
+
+lemma tmL67_tm:
+  assumes "jj < k"
+  shows "turing_machine (2 * k + 3) G' (tmL67 jj)"
+  using assms G'_ge tmL67_def turing_command_cmdL7 by auto
+
+definition "tmL47 jj \<equiv> tmL46 jj ;; tmL67 jj"
+
+lemma tmL47_tm:
+  assumes "jj < k"
+  shows "turing_machine (2 * k + 3) G' (tmL47 jj)"
+  using assms G'_ge tm_left_tm tmL46_tm tmL47_def tmL67_tm by simp
+
+text \<open>
+Next we are sweeping right again and perform the head movement for tape $jj$
+if this is a movement to the right. This works the same as the left movements
+in @{const cmdL7}.
+\<close>
+
+definition cmdL8 :: "nat \<Rightarrow> command" where
+  "cmdL8 jj rs \<equiv>
+ (if rs ! 1 = \<box> then 1 else 0,
+  if rs ! (3 + jj) = 2 \<and> enc_nth (rs ! 1) (k + jj) = 1 \<and> is_code (rs ! 1) then
+   [(rs ! 0, Stay),
+    (enc_upd (rs ! 1) (k + jj) 0, Right),
+    (rs ! 2, Stay)] @
+    (map (\<lambda>j. (if j = jj then 3 else rs ! (j + 3), Stay)) [0..<k]) @
+    (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])
+  else if rs ! (3 + jj) = 3 \<and> is_code (rs ! 1) then
+   [(rs ! 0, Stay),
+    (enc_upd (rs ! 1) (k + jj) 1, Right),
+    (rs ! 2, Stay)] @
+    (map (\<lambda>j. (if j = jj then 2 else rs ! (j + 3), Stay)) [0..<k]) @
+    (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])
+  else if rs ! 1 = 0 then
+   [(rs ! 0, Stay),
+    (rs ! 1, Stay),
+    (rs ! 2, Stay)] @
+    (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+    (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])
+  else
+   [(rs ! 0, Stay),
+    (rs ! 1, Right),
+    (rs ! 2, Stay)] @
+    (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+    (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k]))"
+
+abbreviation "condition8a gs jj \<equiv>
+  gs ! (3 + jj) = 2 \<and> enc_nth (gs ! 1) (k + jj) = 1 \<and> is_code (gs ! 1)"
+abbreviation "condition8b gs jj \<equiv>
+  \<not> condition8a gs jj \<and> gs ! (3 + jj) = 3 \<and> is_code (gs ! 1)"
+abbreviation "condition8c gs jj \<equiv>
+  \<not> condition8a gs jj \<and> \<not> condition8b gs jj \<and> gs ! 1 = 0"
+abbreviation "condition8d gs jj \<equiv>
+  \<not> condition8a gs jj \<and> \<not> condition8b gs jj \<and> \<not> condition8c gs jj"
+
+lemma turing_command_cmdL8:
+  assumes "jj < k"
+  shows "turing_command (2 * k + 3) 1 G' (cmdL8 jj)"
+proof
+  show "length ([!!] cmdL8 jj gs) = length gs" if "length gs = 2 * k + 3" for gs
+  proof -
+    consider "condition8a gs jj" | "condition8b gs jj" | "condition8c gs jj" | "condition8d gs jj"
+      by blast
+    then show ?thesis
+      unfolding cmdL8_def using that by (cases) simp_all
+  qed
+  show goal2: "0 < 2 * k + 3 \<Longrightarrow> cmdL8 jj gs [.] 0 = gs ! 0" if "length gs = 2 * k + 3" for gs
+  proof -
+    consider "condition8a gs jj" | "condition8b gs jj" | "condition8c gs jj" | "condition8d gs jj"
+      by blast
+    then show ?thesis
+      unfolding cmdL8_def using that by (cases) simp_all
+  qed
+  show "cmdL8 jj gs [.] j < G'"
+    if gs: "j < length gs" "length gs = 2 * k + 3" "\<And>i. i < length gs \<Longrightarrow> gs ! i < G'"
+    for gs j
+  proof -
+    consider "condition8a gs jj" | "condition8b gs jj" | "condition8c gs jj" | "condition8d gs jj"
+      by blast
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have *: "snd (cmdL8 jj gs) =
+        [(gs ! 0, Stay),
+         (enc_upd (gs ! 1) (k + jj) 0, Right),
+         (gs ! 2, Stay)] @
+         (map (\<lambda>j. (if j = jj then 3 else gs ! (j + 3), Stay)) [0..<k]) @
+         (map (\<lambda>j. (gs ! (3 + k + j), Stay)) [0..<k])"
+        unfolding cmdL8_def by simp
+      consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+        using gs by linarith
+      then show ?thesis
+      proof (cases)
+        case 1
+        then show ?thesis
+          using that by (simp add: goal2)
+      next
+        case 2
+        then have "is_code (gs ! 1)"
+          using 1 by blast
+        moreover have "k + jj < 2 * k + 2"
+          using assms by simp
+        moreover have "0 < G"
+          using G_ge_4 by simp
+        ultimately have "is_code (enc_upd (gs ! 1) (k + jj) 0)"
+          using enc_upd_is_code by simp
+        then have "is_code (cmdL8 jj gs [.] j)"
+          using * 2 by simp
+        then show ?thesis
+          using G'_ge_G G'_def by simp
+      next
+        case 3
+        then show ?thesis
+          using * gs by simp
+      next
+        case 4
+        then show ?thesis
+          using * gs G'_ge threeplus2k_2[where ?a="(gs ! 0, Stay)"] by simp
+      next
+        case 5
+        then show ?thesis
+          using * gs G'_ge threeplus2k_3[where ?a="(gs ! 0, Stay)"] by simp
+      qed
+    next
+      case case2: 2
+      then have *: "snd (cmdL8 jj gs) =
+        [(gs ! 0, Stay),
+         (enc_upd (gs ! 1) (k + jj) 1, Right),
+         (gs ! 2, Stay)] @
+         (map (\<lambda>j. (if j = jj then 2 else gs ! (j + 3), Stay)) [0..<k]) @
+         (map (\<lambda>j. (gs ! (3 + k + j), Stay)) [0..<k])"
+        unfolding cmdL8_def by simp
+      consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+        using gs by linarith
+      then show ?thesis
+      proof (cases)
+        case 1
+        then show ?thesis
+          using that by (simp add: goal2)
+      next
+        case 2
+        then have "is_code (gs ! 1)"
+          using case2 by simp
+        moreover have "k + jj < 2 * k + 2"
+          using assms by simp
+        moreover have "1 < G"
+          using G_ge_4 by simp
+        ultimately have "is_code (enc_upd (gs ! 1) (k + jj) 1)"
+          using enc_upd_is_code by simp
+        then have "is_code (cmdL8 jj gs [.] j)"
+          using * 2 by simp
+        then show ?thesis
+          using G'_ge_G G'_def by simp
+      next
+        case 3
+        then show ?thesis
+          using * gs by simp
+      next
+        case 4
+        then show ?thesis
+          using * gs G'_ge threeplus2k_2[where ?a="(gs ! 0, Stay)"] by simp
+      next
+        case 5
+        then show ?thesis
+          using * gs G'_ge threeplus2k_3[where ?a="(gs ! 0, Stay)"] by simp
+      qed
+    next
+      case 3
+      then have *: "snd (cmdL8 jj gs) =
+        [(gs ! 0, Stay),
+         (gs ! 1, Stay),
+         (gs ! 2, Stay)] @
+         (map (\<lambda>j. (gs ! (j + 3), Stay)) [0..<k]) @
+         (map (\<lambda>j. (gs ! (3 + k + j), Stay)) [0..<k])"
+        unfolding cmdL8_def by auto
+      consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+        using gs by linarith
+      then show ?thesis
+        using * gs G'_ge threeplus2k_2[where ?a="(gs ! 0, Stay)"] threeplus2k_3[where ?a="(gs ! 0, Stay)"]
+        by (cases) simp_all
+    next
+      case 4
+      then have *: "snd (cmdL8 jj gs) =
+        [(gs ! 0, Stay),
+         (gs ! 1, Right),
+         (gs ! 2, Stay)] @
+         (map (\<lambda>j. (gs ! (j + 3), Stay)) [0..<k]) @
+         (map (\<lambda>j. (gs ! (3 + k + j), Stay)) [0..<k])"
+        unfolding cmdL8_def by auto
+      consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+        using gs by linarith
+      then show ?thesis
+        using * gs G'_ge threeplus2k_2[where ?a="(gs ! 0, Stay)"] threeplus2k_3[where ?a="(gs ! 0, Stay)"]
+        by (cases) simp_all
+    qed
+  qed
+  show "\<And>gs. length gs = 2 * k + 3 \<Longrightarrow> [*] (cmdL8 jj gs) \<le> 1"
+    using cmdL8_def by simp
+qed
+
+definition tmL78 :: "nat \<Rightarrow> machine" where
+  "tmL78 jj \<equiv> [cmdL8 jj]"
+
+lemma tmL78_tm:
+  assumes "jj < k"
+  shows "turing_machine (2 * k + 3) G' (tmL78 jj)"
+  using assms G'_ge tmL78_def turing_command_cmdL8 by auto
+
+definition "tmL48 jj \<equiv> tmL47 jj ;; tmL78 jj"
+
+lemma tmL48_tm:
+  assumes "jj < k"
+  shows "turing_machine (2 * k + 3) G' (tmL48 jj)"
+  using assms G'_ge tm_left_tm tmL47_tm tmL48_def tmL78_tm by simp
+
+text \<open>
+The last command in the command sequence is moving back to the beginning of the
+output tape.
+\<close>
+
+definition "tmL49 jj \<equiv> tmL48 jj ;; tm_left_until1"
+
+text \<open>
+The Turing machine @{term "tmL49 jj"} is then repeated for the parameters $jj =
+0, \dots, k - 1$ in order to simulate the actions of $M$ on all tapes.
+\<close>
+
+lemma tmL49_tm: "jj < k \<Longrightarrow> turing_machine (2 * k + 3) G' (tmL49 jj)"
+  using tmL48_tm tmL49_def tmL1_def tm_left_until1_tm by simp
+
+fun tmL49_upt :: "nat \<Rightarrow> machine" where
+  "tmL49_upt 0 = []" |
+  "tmL49_upt (Suc j) = tmL49_upt j ;; tmL49 j"
+
+lemma tmL49_upt_tm:
+  assumes "j \<le> k"
+  shows "turing_machine (2 * k + 3) G' (tmL49_upt j)"
+  using assms
+proof (induction j)
+  case 0
+  then show ?case
+    using G'_ge(1) turing_machine_def by simp
+next
+  case (Suc j)
+  then show ?case
+    using assms tmL49_tm by simp
+qed
+
+definition "tmL9 \<equiv> tmL4 ;; tmL49_upt k"
+
+lemma tmL9_tm: "turing_machine (2 * k + 3) G' tmL9"
+  unfolding tmL9_def using tmL49_upt_tm tmL4_tm by simp
+
+text \<open>
+At this point in the iteration we have completed one more step in the execution
+of $M$. We mark this be setting one more counter flag, namely the one in the
+leftmost code symbol where the flag is still unset. To find the first unset
+counter flag, we reuse @{term tmC}.
+\<close>
+
+definition "tmL10 \<equiv> tmL9 ;; tmC"
+
+lemma tmL10_tm: "turing_machine (2 * k + 3) G' tmL10"
+  unfolding tmL10_def using tmL9_tm tmC_tm by simp
+
+text \<open>
+Then we set the counter flag, unless we have reached a blank symbol.
+\<close>
+
+definition cmdL11 :: command where
+  "cmdL11 rs \<equiv>
+   (1,
+    [(rs ! 0, Stay),
+     if is_code (rs ! 1) then (enc_upd (rs ! 1) (2 * k) 1, Stay) else (rs ! 1, Stay),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k]))"
+
+lemma turing_command_cmdL11: "turing_command (2 * k + 3) 1 G' cmdL11"
+proof
+  show "length gs = 2 * k + 3 \<Longrightarrow> length ([!!] cmdL11 gs) = length gs" for gs
+    unfolding cmdL11_def by (cases "gs ! 1 = 0") simp_all
+  show goal2: "length gs = 2 * k + 3 \<Longrightarrow> 0 < 2 * k + 3 \<Longrightarrow> cmdL11 gs [.] 0 = gs ! 0" for gs
+    unfolding cmdL11_def by (cases "gs ! 1 = 0") simp_all
+  show "cmdL11 gs [.] j < G'"
+    if "length gs = 2 * k + 3" "\<And>i. i < length gs \<Longrightarrow> gs ! i < G'" "j < length gs"
+    for gs j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `length gs = 2 * k + 3` `j < length gs` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using that goal2 by simp
+    next
+      case 2
+      show ?thesis
+      proof (cases "is_code (gs ! 1)")
+        case True
+        then have *: "cmdL11 gs [.] j = enc_upd (gs ! 1) (2 * k) 1"
+          using 2 cmdL11_def by simp
+        then have "is_code (cmdL11 gs [.] j)"
+          using enc_upd_is_code[OF True] G_ge_4 by simp
+        then show ?thesis
+          using G'_def by simp
+      next
+        case False
+        then show ?thesis
+          using that cmdL11_def 2 by auto
+      qed
+    next
+      case 3
+      then show ?thesis
+        using that cmdL11_def by simp
+    next
+      case 4
+      then show ?thesis
+        using that cmdL11_def threeplus2k_2[OF 4, of "(gs ! 0, Stay)"] by simp
+    next
+      case 5
+      then show ?thesis
+        using that cmdL11_def threeplus2k_3[OF 5, of "(gs ! 0, Stay)"] by simp
+    qed
+  qed
+  show "\<And>gs. length gs = 2 * k + 3 \<Longrightarrow> [*] (cmdL11 gs) \<le> 1"
+    using cmdL11_def by simp
+qed
+
+definition "tmL11 \<equiv> tmL10 ;; [cmdL11] "
+
+lemma tmL1011_tm: "turing_machine (2 * k + 3) G' [cmdL11]"
+  using cmdL11_def turing_command_cmdL11 G'_ge by auto
+
+lemma tmL11_tm: "turing_machine (2 * k + 3) G' tmL11"
+  using tmL11_def tmL1011_tm G'_ge tmL10_tm by simp
+
+text \<open>
+And we move back to the beginning of the output tape again.
+\<close>
+
+definition "tmL12 \<equiv> tmL11 ;; tm_left_until1"
+
+lemma tmL12_tm: "turing_machine (2 * k + 3) G' tmL12"
+  using tmL11_tm tmL12_def tm_left_until1_tm by simp
+
+text \<open>
+Now, at the end of the iteration we set the memorization tapes $3, \dots, 2k+2$,
+that is, all but the one memorizing the state of $M$, to $0$. This makes for a
+simpler loop invariant than having the leftover symbols there.
+\<close>
+
+definition "tmL13 \<equiv> tmL12 ;; tm_write_many {3..<2 * k + 3} 0"
+
+lemma tmL13_tm: "turing_machine (2 * k + 3) G' tmL13"
+  unfolding tmL13_def using tmL12_tm tm_write_many_tm k_ge_2 G'_ge(1) by simp
+
+text \<open>
+This is the entire loop. It terminates once there are no unset counter flags
+anymore.
+\<close>
+
+definition "tmLoop \<equiv> WHILE tmC ; \<lambda>rs. rs ! 1 > \<box> DO tmL13 DONE"
+
+lemma tmLoop_tm: "turing_machine (2 * k + 3) G' tmLoop"
+  using tmLoop_def turing_machine_loop_turing_machine tmC_tm tmL13_tm by simp
+
+definition "tm10 \<equiv> tm9 ;; tmLoop"
+
+lemma tm10_tm: "turing_machine (2 * k + 3) G' tm10"
+  using tm10_def tmLoop_tm tm9_tm by simp
+
+
+subsubsection \<open>Cleaning up the output\<close>
+
+text \<open>
+Now the simulation proper has ended, but the output tape does not yet look quite
+like the output tape of $M$. It remains to extract the component~$1$ from all
+the code symbols on the output tape. The simulator does this while sweeping left.
+Formally, ``extracting component~1'' means this:
+\<close>
+
+abbreviation ec1 :: "symbol \<Rightarrow> symbol" where
+  "ec1 h \<equiv> if is_code h then enc_nth h 1 else \<box>"
+
+lemma ec1: "ec1 h < G'" if "h < G'" for h
+proof (cases "is_code h")
+  case True
+  then show ?thesis
+    using enc_nth_less G'_ge_G by fastforce
+next
+  case False
+  then show ?thesis
+    using that by auto
+qed
+
+definition "tm11 \<equiv> tm10 ;; tm_ltrans_until 1 1 StartSym ec1"
+
+lemma tm11_tm: "turing_machine (2 * k + 3) G' tm11"
+proof -
+  have "turing_machine (2 * k + 3) G' (tm_ltrans_until 1 1 StartSym ec1)"
+    using G'_ge ec1 by (intro tm_ltrans_until_tm) simp_all
+  then show ?thesis
+    using tm10_tm tm11_def by simp
+qed
+
+text \<open>
+The previous TM, @{term "tm_ltrans_until 1 1 StartSym ec1"}, halts as soon as it
+encounters a code symbol with the start flag set, without applying the
+extraction function. Applying the function to this final code symbol, which is
+at the leftmost cell of the tape, is the last step of the simulator machine.
+\<close>
+
+definition "tm12 \<equiv> tm11 ;; tm_rtrans 1 ec1"
+
+lemma tm12_tm: "turing_machine (2 * k + 3) G' tm12"
+  unfolding tm12_def using tm_rtrans_tm tm11_tm ec1 G'_ge by simp
+
+
+subsection \<open>Semantics of the Turing machine\<close>
+
+text \<open>
+This section establishes not only the configurations of the simulator but also
+the traces. For every Turing machine and command defined in the previous
+subsection, there will be a corresponding trace and a tape list representing the
+simulator's configuration after the command or TM has been applied.
+\<close>
+
+text \<open>
+For most of the time, the simulator's output tape will have no start symbol, and
+so the next definition will be more suited to describing it than the customary
+@{const contents}.
+\<close>
+
+definition contents' :: "symbol list \<Rightarrow> (nat \<Rightarrow> symbol)" where
+  "contents' ys x \<equiv> if x < length ys then ys ! x else 0"
+
+lemma contents'_eqI:
+  assumes "\<And>x. x < length ys \<Longrightarrow> zs x = ys ! x"
+    and "\<And>x. x \<ge> length ys \<Longrightarrow> zs x = 0"
+  shows "zs = contents' ys"
+  using contents'_def assms by auto
+
+lemma contents_contents': "\<lfloor>ys\<rfloor> = contents' (1 # ys)"
+  using contents_def contents'_def by auto
+
+lemma contents'_at_ge:
+  assumes "i \<ge> length ys"
+  shows "contents' ys i = 0"
+  using assms contents'_def by simp
+
+text \<open>
+In the following context @{term zs} represents the input for $M$ and hence for
+the simulator.
+\<close>
+
+context
+  fixes zs :: "symbol list"
+  assumes zs: "bit_symbols zs"
+begin
+
+lemma zs_less_G: "\<forall>i<length zs. zs ! i < G"
+  using zs G_ge_4 by auto
+
+lemma zs_proper: "proper_symbols zs"
+  using zs by auto
+
+abbreviation "n \<equiv> length zs"
+
+abbreviation "TT \<equiv> Suc (fmt n)"
+
+
+subsubsection \<open>Initializing the simulator's tapes\<close>
+
+definition tps0 :: "tape list" where
+  "tps0 \<equiv>
+    [(\<lfloor>zs\<rfloor>, 0),
+     (\<lfloor>[]\<rfloor>, 0)] @
+    replicate (2 * k + 1) (\<lceil>\<triangleright>\<rceil>)"
+
+lemma tps0_start_config: "start_config (2 * k + 3) zs = (0, tps0)"
+  unfolding tps0_def contents_def onesie_def start_config_def by auto
+
+definition tps1 :: "tape list" where
+  "tps1 \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lfloor>replicate (fmt n) 3\<rfloor>, 1)] @
+    replicate (2 * k + 1) (\<lceil>\<triangleright>\<rceil>)"
+
+definition "es1 \<equiv> es_fmt n"
+
+lemma tm1: "traces tm1 tps0 es1 tps1"
+proof -
+  let ?tps = "replicate (2 * k + 1) (\<lceil>\<triangleright>\<rceil>)"
+  have 1: "tps0 = start_tapes_2 zs @ ?tps"
+    using contents_def tps0_def start_tapes_2_def by auto
+  have 2: "tps1 = one_tapes_2 zs (fmt n) @ ?tps"
+    using contents_def tps1_def one_tapes_2_def by simp
+  have "length (start_tapes_2 zs) = 2"
+    using start_tapes_2_def by simp
+  moreover have "traces tm_fmt (start_tapes_2 zs) (es_fmt n) (one_tapes_2 zs (fmt n))"
+    using fmt zs by fastforce
+  moreover have "turing_machine 2 G' tm_fmt" using fmt(1) .
+  ultimately have
+    "traces (append_tapes 2 (2 + length ?tps) tm_fmt) (start_tapes_2 zs @ ?tps) (es_fmt n) (one_tapes_2 zs (fmt n) @ ?tps)"
+    using traces_append_tapes by blast
+  then have
+    "traces (append_tapes 2 (2 * k + 3) tm_fmt) (start_tapes_2 zs @ ?tps) (es_fmt n) (one_tapes_2 zs (fmt n) @ ?tps)"
+    by (simp add: numeral_3_eq_3)
+  then have "traces (append_tapes 2 (2 * k + 3) tm_fmt) tps0 (es_fmt n) tps1"
+    using 1 2 by simp
+  then show ?thesis
+    using tm1_def es1_def by simp
+qed
+
+definition "es1_2 \<equiv> map (\<lambda>i. (1, 1 + Suc i)) [0..<fmt n] @ [(1, 1 + fmt n)]"
+
+definition "es2 \<equiv> es1 @ es1_2"
+
+lemma len_es2: "length es2 = length (es_fmt n) + TT"
+  using es2_def es1_def by (simp add: es1_2_def)
+
+definition tps2 :: "tape list" where
+  "tps2 \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lfloor>replicate (fmt n) (enc (replicate k 0 @ replicate k 0 @ [0, 0]))\<rfloor>, TT)] @
+    replicate (2 * k + 1) (\<lceil>\<triangleright>\<rceil>)"
+
+lemma tm2: "traces tm2 tps0 es2 tps2"
+  unfolding tm2_def es2_def
+proof (rule traces_sequential)
+  show "traces tm1 tps0 es1 tps1" using tm1 .
+  show "traces tm1_2 tps1 es1_2 tps2"
+    unfolding tm1_2_def es1_2_def
+  proof (rule traces_tm_const_until_11I[where ?n="fmt n" and ?G=G'])
+    show "1 < length tps1"
+      using tps1_def by simp
+    show "enc (replicate k 0 @ replicate k 0 @ [0, 0]) < G'"
+      using G_ge_4 by (intro enc_less_G') simp_all
+    show "rneigh (tps1 ! 1) {0} (fmt n)"
+      using tps1_def contents_def by (intro rneighI) simp_all
+    show "map (\<lambda>i. (1, 1 + Suc i)) [0..<fmt n] @ [(1, 1 + fmt n)] =
+        map (\<lambda>i. (tps1 :#: 0, tps1 :#: 1 + Suc i)) [0..<fmt n] @ [(tps1 :#: 0, tps1 :#: 1 + fmt n)]"
+      using tps1_def contents_def by simp
+    show "tps2 =
+        tps1 [1 := constplant (tps1 ! 1) (enc (replicate k 0 @ replicate k 0 @ [0, 0])) (fmt n)]"
+      using tps2_def tps1_def contents_def constplant by auto
+  qed
+qed
+
+definition "es3 \<equiv> es2 @ map (\<lambda>i. (1, i)) (rev [0..<TT]) @ [(1, 0)]"
+
+definition tps3 :: "tape list" where
+  "tps3 \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lfloor>replicate (fmt n) (enc (replicate k 0 @ replicate k 0 @ [0, 0]))\<rfloor>, 0)] @
+    replicate (2 * k + 1) (\<lceil>\<triangleright>\<rceil>)"
+
+lemma tm3: "traces tm3 tps0 es3 tps3"
+  unfolding tm3_def es3_def
+proof (rule traces_sequential)
+  show "traces tm2 tps0 es2 tps2" using tm2 .
+  show "traces (tm_start 1) tps2 (map (\<lambda>i. (1, i)) (rev [0..<TT]) @ [(1, 0)]) tps3"
+    using tps3_def tps2_def enc_greater by (intro traces_tm_start_1I) simp_all
+qed
+
+definition "es4 \<equiv> es3 @ [(1, 0)]"
+
+lemma len_es4: "length es4 = length (es_fmt n) + 2 * TT + 2"
+  using es4_def es3_def len_es2 by simp
+
+definition tps4 :: "tape list" where
+  "tps4 \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (contents'
+       ((enc (replicate k 1 @ replicate k 1 @ [0, 1])) #
+        replicate (fmt n) (enc (replicate k 0 @ replicate k 0 @ [0, 0]))), 0)] @
+    replicate (2 * k + 1) (\<lceil>\<triangleright>\<rceil>)"
+
+lemma tm4: "traces tm4 tps0 es4 tps4"
+  unfolding tm4_def es4_def
+proof (rule traces_sequential)
+  show "traces tm3 tps0 es3 tps3" using tm3 .
+  show "traces (tm_write 1 (enc (replicate k 1 @ replicate k 1 @ [0, 1]))) tps3 [(1, 0)] tps4"
+  proof (rule traces_tm_write_1I)
+    show "1 < length tps3"
+      using tps3_def by simp
+    show "[(1, 0)] = [(tps3 :#: 0, tps3 :#: 1)]"
+      using tps3_def by simp
+    show "tps4 = tps3[1 := tps3 ! 1 |:=| enc (replicate k 1 @ replicate k 1 @ [0, 1])]"
+      using tps3_def tps4_def contents'_def contents_contents' by auto
+  qed
+qed
+
+definition "es5 \<equiv> es4 @ [(1, 1)]"
+
+lemma len_es5: "length es5 = length (es_fmt n) + 2 * TT + 3"
+  using es5_def len_es4 by simp
+
+definition tps5 :: "tape list" where
+  "tps5 \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (contents'
+       ((enc (replicate k 1 @ replicate k 1 @ [0, 1])) #
+        replicate (fmt n) (enc (replicate k 0 @ replicate k 0 @ [0, 0]))), 1)] @
+    replicate (2 * k + 1) (\<lceil>\<triangleright>\<rceil>)"
+
+lemma tm5: "traces tm5 tps0 es5 tps5"
+  unfolding tm5_def es5_def
+proof (rule traces_sequential)
+  show "traces tm4 tps0 es4 tps4"
+    using tm4 .
+  show "traces (tm_right 1) tps4 [(1, 1)] tps5"
+    using tps4_def tps5_def by (intro traces_tm_right_1I) simp_all
+qed
+
+text \<open>
+Since the simulator simulates $M$ on @{term zs}, its tape contents are typically
+described in terms of configurations of $M$. So the following definition
+is actually more like an abbreviation.
+\<close>
+
+definition "exec t \<equiv> execute M (start_config k zs) t"
+
+lemma exec_pos_less_TT:
+  assumes "j < k"
+  shows "exec t <#> j < TT"
+proof -
+  have "exec t <#> j \<le> T' n"
+    using head_pos_le_time_bound[OF tm_M time_bound_T' zs assms] exec_def by simp
+  then show ?thesis
+    by (meson fmt(4) le_imp_less_Suc le_trans)
+qed
+
+lemma tps_ge_TT_0:
+  assumes "i \<ge> TT"
+  shows "(exec t <:> 1) i = 0"
+proof (induction t)
+  case 0
+  have "exec 0 = start_config k zs"
+    using exec_def by simp
+  then show ?case
+    using start_config1 assms tm_M turing_machine_def by simp
+next
+  case (Suc t)
+  have *: "exec (Suc t) = exe M (exec t)"
+    using exec_def by simp
+  show ?case
+  proof (cases "fst (exec t) \<ge> length M")
+    case True
+    then have "exec (Suc t) = exec t"
+      using * exe_def by simp
+    then show ?thesis
+      using Suc by simp
+  next
+    case False
+    then have "exec (Suc t) <:> 1 = sem (M ! (fst (exec t))) (exec t) <:> 1"
+        (is "_ = sem ?cmd ?cfg <:> 1")
+      using exe_lt_length * by simp
+    also have "... = fst (map (\<lambda>(a, tp). act a tp) (zip (snd (?cmd (read (snd ?cfg)))) (snd ?cfg)) ! 1)"
+      using sem' by simp
+    also have "... = fst (act (snd (?cmd (read (snd ?cfg))) ! 1) (snd ?cfg ! 1))"
+      (is "_ = fst (act ?h (snd ?cfg ! 1))")
+    proof -
+      have "||?cfg|| = k"
+        using exec_def tm_M execute_num_tapes[OF tm_M] start_config_length turing_machine_def
+        by simp
+      moreover from this have "length (snd (?cmd (read (snd ?cfg)))) = k"
+        by (metis False turing_commandD(1) linorder_not_less read_length tm_M turing_machineD(3))
+      moreover have "k > 1"
+         using k_ge_2 by simp
+      ultimately show ?thesis
+        by simp
+    qed
+    finally have "exec (Suc t) <:> 1 = fst (act ?h (?cfg <!> 1))" .
+    moreover have "i \<noteq> snd (?cfg <!> 1)"
+      using assms by (metis Suc_1 exec_pos_less_TT lessI less_irrefl less_le_trans tm_M turing_machine_def)
+    ultimately have "(exec (Suc t) <:> 1) i = fst (?cfg <!> 1) i"
+      using act_changes_at_most_pos by (metis prod.collapse)
+    then show ?thesis
+      using Suc.IH by simp
+  qed
+qed
+
+text \<open>
+The next definition is central to how we describe the simulator's output tape.
+The basic idea is that it describes the tape during the simulation of the $t$-th
+step of executing $M$ on input @{term zs}. Recall that $TT$ is the length of the
+formatted part on the simulator's output tape. The $i$-th cell of the output
+tape contains: (1) $k$ symbols corresponding to the symbols in the $i$-th cell
+of the $k$ tapes of $M$ after $t$ steps; (2) $k$ flags indicating which of the
+$k$ tape heads is in position $i$; (3) a unary counter representing the number
+$t$; (4) a flag indicating whether $i = 0$. This is the situation at the
+beginning of the $t$-iteration of the simulator's main loop. During this
+iteration the tape changes slightly: some symbols and head positions may already
+represent the situation after $t+1$ steps of $M$, that is, the $t$-th step has
+been partially simulated already.
+
+To account for this, there is the @{term xs} parameter. It is meant to be set to
+a list of $k$ pairs. Let the $j$-th element of this list be $(a, b)$.  on $M$'s
+tape $j$ has already been simulated. In other words, the output tape reflects
+the situation after $t + a$ steps. Likewise $b$ will be either None or 0 or 1.
+If it is 0 or 1, it means the flag represents the head position of tape $j$
+after $t + b$ steps. If it is None, it means that all head flags for tape $k$
+are currently zero, representing a ``tape without head''.  This situation occurs
+every time the simulator has cleared the head flag representing the position
+after $t$ steps, bus has not set the flag for the head position after $t+1$
+steps yet.
+
+Therefore, at the beginning of the $t$-t iteration of the simulator's loop
+@{term xs} consists of $k$ pairs $(0, 0)$. During the iteration every pair will
+eventually become $(0, 0)$.
+\<close>
+
+definition zip_cont :: "nat \<Rightarrow> (nat \<times> nat option) list \<Rightarrow> (nat \<Rightarrow> symbol)" where
+  "zip_cont t xs i \<equiv>
+    if i < TT then enc
+     (map (\<lambda>j. (exec (t + fst (xs ! j)) <:> j) i) [0..<k] @
+      map (\<lambda>j. case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [if i < t then 1 else 0,
+       if i = 0 then 1 else 0])
+    else 0"
+
+text \<open>
+Some auxiliary lemmas for accessing elements of lists of certain shape:
+\<close>
+
+lemma less_k_nth: "j < k \<Longrightarrow> (map f1 [0..<k] @ map f2 [0..<k] @ [a, b]) ! j = f1 j"
+  by (simp add: nth_append)
+
+lemma less_2k_nth: "k \<le> j \<Longrightarrow> j < 2 * k \<Longrightarrow> (map f1 [0..<k] @ map f2 [0..<k] @ [a, b]) ! j = f2 (j - k)"
+proof -
+  assume a: "k \<le> j" "j < 2 * k"
+  have b: "(map f1 [0..<k] @ map f2 [0..<k]) ! (k + l) = f2 l" if "l < k" for l
+    by (simp add: nth_append that)
+  have "(map f1 [0..<k] @ map f2 [0..<k]) ! j = f2 (j - k)"
+  proof -
+    obtain l where l: "l < k" "k + l = j"
+      using a le_Suc_ex by auto
+    then have "(map f1 [0..<k] @ map f2 [0..<k]) ! (k + l) = f2 l"
+      using b by auto
+    with l show ?thesis
+      by auto
+  qed
+  moreover have "(map f1 [0..<k] @ map f2 [0..<k] @ [a, b]) = (map f1 [0..<k] @ map f2 [0..<k]) @ [a, b]"
+    by simp
+  moreover have "length (map f1 [0..<k] @ map f2 [0..<k]) = 2 * k"
+    by simp
+  ultimately show ?thesis
+    using a by (metis nth_append)
+qed
+
+lemma twok_nth: "(map f1 [0..<k] @ map f2 [0..<k] @ [a, b]) ! (2 * k) = a"
+proof -
+  have "map f1 [0..<k] @ map f2 [0..<k] @ [a, b] = (map f1 [0..<k] @ map f2 [0..<k]) @ [a, b]"
+    by simp
+  moreover have "length (map f1 [0..<k] @ map f2 [0..<k]) = 2 * k"
+    by simp
+  ultimately show ?thesis
+    by (metis nth_append_length)
+qed
+
+lemma twok1_nth: "(map f1 [0..<k] @ map f2 [0..<k] @ [a, b]) ! (2 * k + 1) = b"
+proof -
+  have "map f1 [0..<k] @ map f2 [0..<k] @ [a, b] = (map f1 [0..<k] @ map f2 [0..<k]) @ [a, b]"
+    by simp
+  moreover have "length (map f1 [0..<k] @ map f2 [0..<k]) = 2 * k"
+    by simp
+  ultimately show ?thesis
+    by (metis One_nat_def nth_Cons_0 nth_Cons_Suc nth_append_length_plus)
+qed
+
+lemma zip_cont_less_G:
+  assumes "i < TT"
+  shows "\<forall>x\<in>set (map (\<lambda>j. (exec (t + fst (xs ! j)) <:> j) i) [0..<k] @
+      map (\<lambda>j. case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [if i < t then 1 else 0,
+       if i = 0 then 1 else 0]). x < G"
+    (is "\<forall>x\<in>set(?us @ ?vs @ [?a, ?b]). x < G")
+proof -
+  let ?ys = "?us @ ?vs @ [?a, ?b]"
+  let ?f1 = "(\<lambda>j. (exec (t + fst (xs ! j)) <:> j) i)"
+  let ?f2 = "(\<lambda>j. case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0)"
+  have "?ys ! j < G" if "j < 2 * k + 2" for j
+  proof -
+    consider "j < k" | "k \<le> j \<and> j < 2 * k" | "j = 2 * k" | "j = 2 * k + 1"
+      using `j < 2 * k + 2` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "?us ! j = (execute M (start_config k zs) (t + fst (xs ! j)) <:> j) i"
+        using exec_def by simp
+      then show ?thesis
+        using tape_alphabet[OF tm_M] zs_less_G by (simp add: "1" nth_append)
+    next
+      case 2
+      then have "?ys ! j = (case snd (xs ! (j-k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j-k) then 1 else 0)"
+        by (simp add: less_2k_nth)
+      then have "?ys ! j \<le> 1"
+        by (cases "snd (xs ! (j - k))") auto
+      then show ?thesis
+        using G_ge_4 by simp
+    next
+      case 3
+      then have "?ys ! j \<le> 1"
+        by (simp add: twok_nth)
+      then show ?thesis
+        using G_ge_4 by simp
+    next
+      case 4
+      then have "?ys ! j = (if i = 0 then 1 else 0)"
+        using twok1_nth[of ?f1 ?f2 ?a ?b] by simp
+      then show ?thesis
+        using G_ge_4 by simp
+    qed
+  qed
+  moreover have "length ?ys = 2 * k + 2"
+    by simp
+  ultimately show "\<forall>x\<in>set ?ys. x < G"
+    by (metis (no_types, lifting) in_set_conv_nth)
+qed
+
+lemma dec_zip_cont:
+  assumes "i < TT"
+  shows "dec (zip_cont t xs i) =
+     (map (\<lambda>j. (exec (t + fst (xs ! j)) <:> j) i) [0..<k] @
+      map (\<lambda>j. case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [if i < t then 1 else 0,
+       if i = 0 then 1 else 0])"
+    (is "_ = ?ys")
+proof -
+  have "\<forall>x\<in>set ?ys. x < G"
+    using zip_cont_less_G[OF assms] by simp
+  moreover have len: "length ?ys = 2 * k + 2"
+    by simp
+  ultimately have "dec (enc ?ys) = ?ys"
+    using dec_enc by simp
+  then show ?thesis
+    using zip_cont_def assms by simp
+qed
+
+lemma zip_cont_gt_1:
+  assumes "i < TT"
+  shows "zip_cont t xs i > 1"
+  using assms enc_greater zip_cont_def by simp
+
+lemma zip_cont_less:
+  assumes "i < TT"
+  shows "zip_cont t xs i < G ^ (2 * k + 2) + 2"
+  using assms enc_less zip_cont_less_G zip_cont_def by simp
+
+lemma zip_cont_eq_0:
+  assumes "i \<ge> TT"
+  shows "zip_cont t xs i = 0"
+  using assms zip_cont_def by simp
+
+lemma dec_zip_cont_less_k:
+  assumes "i < TT" and "j < k"
+  shows "dec (zip_cont t xs i) ! j = (exec (t + fst (xs ! j)) <:> j) i"
+  using dec_zip_cont[OF assms(1)] using assms(2) less_k_nth by (simp add: less_k_nth)
+
+lemma dec_zip_cont_less_2k:
+  assumes "i < TT" and "j \<ge> k" and "j < 2 * k"
+  shows "dec (zip_cont t xs i) ! j =
+    (case snd (xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+  using dec_zip_cont[OF assms(1)] assms(2,3) by (simp add: less_2k_nth)
+
+lemma dec_zip_cont_2k:
+  assumes "i < TT"
+  shows "dec (zip_cont t xs i) ! (2 * k) = (if i < t then 1 else 0)"
+  using dec_zip_cont[OF assms(1)] by (simp add: twok_nth)
+
+lemma dec_zip_cont_2k1:
+  assumes "i < TT"
+  shows "dec (zip_cont t xs i) ! (2 * k + 1) = (if i = 0 then 1 else 0)"
+  using dec_zip_cont[OF assms(1)] twok1_nth by force
+
+lemma zip_cont_eqI:
+  assumes "i < TT"
+    and "\<And>j. j < k \<Longrightarrow> (exec (t + fst (xs ! j)) <:> j) i = (exec (t + fst (xs' ! j)) <:> j) i"
+    and "\<And>j. j < k \<Longrightarrow>
+      (case snd (xs ! j) of None \<Rightarrow> (0::nat) | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) =
+      (case snd (xs' ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0)"
+  shows "zip_cont t xs i = zip_cont t xs' i"
+proof -
+  have *: "map (\<lambda>j. case snd (xs ! j) of None \<Rightarrow> (0::nat) | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] =
+      map (\<lambda>j. case snd (xs' ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k]"
+    using assms(3) by simp
+  have "zip_cont t xs i = enc
+     (map (\<lambda>j. (exec (t + fst (xs ! j)) <:> j) i) [0..<k] @
+      map (\<lambda>j. case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [if i < t then 1 else 0,
+       if i = 0 then 1 else 0])"
+    using assms zip_cont_def by simp
+  also have "... = enc
+     (map (\<lambda>j. (exec (t + fst (xs' ! j)) <:> j) i) [0..<k] @
+      map (\<lambda>j. case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [if i < t then 1 else 0,
+       if i = 0 then 1 else 0])"
+    using assms(2) by (smt atLeastLessThan_iff map_eq_conv set_upt)
+  also have "... = enc
+     (map (\<lambda>j. (exec (t + fst (xs' ! j)) <:> j) i) [0..<k] @
+      map (\<lambda>j. case snd (xs' ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [if i < t then 1 else 0,
+       if i = 0 then 1 else 0])"
+    using * by metis
+  finally show ?thesis
+    using zip_cont_def by auto
+qed
+
+lemma zip_cont_nth_eqI:
+  assumes "i < TT"
+    and "\<And>j. j < k \<Longrightarrow> (exec (t + fst (xs ! j)) <:> j) i = (exec (t + fst (xs' ! j)) <:> j) i"
+    and "\<And>j. j < k \<Longrightarrow> snd (xs ! j) = snd (xs' ! j)"
+  shows "zip_cont t xs i = zip_cont t xs' i"
+  using assms zip_cont_eqI by presburger
+
+lemma begin_tape_zip_cont:
+  "begin_tape {y. y < G ^ (2 * k + 2) + 2 \<and> 1 < y \<and> dec y ! (2 * k + 1) = 1} (zip_cont t xs, i)"
+    (is "begin_tape ?ys _")
+proof -
+  let ?y = "zip_cont t xs 0"
+  have "?y \<in> ?ys"
+  proof -
+    have *: "?y = enc
+      (map (\<lambda>j. (exec (t + fst (xs ! j)) <:> j) 0) [0..<k] @
+       map (\<lambda>j. case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if 0 = exec (t + d) <#> j then 1 else 0) [0..<k] @
+       [if 0 < t then 1 else 0, 1])"
+      (is "_ = enc ?z")
+      using zip_cont_def by simp
+    then have 1: "?y > 1"
+      using enc_greater by simp
+    have "?z ! (2 * k + 1) = 1"
+      using twok1_nth by fast
+    then have 2: "dec ?y ! (2 * k + 1) = 1"
+      using dec_zip_cont by simp
+    have "?y < G ^ (2 * k + 2) + 2"
+      using enc_less * zip_cont_less_G[of 0] by simp
+    then show ?thesis
+      using 1 2 by simp
+  qed
+  moreover have "zip_cont t xs i \<notin> ?ys" if "i > 0" for i
+  proof (cases "i < TT")
+    case True
+    then have "dec (zip_cont t xs i) =
+      (map (\<lambda>j. (exec (t + fst (xs ! j)) <:> j) i) [0..<k] @
+       map (\<lambda>j. case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+       [if i < t then 1 else 0, 0])"
+      using dec_zip_cont that by simp
+    then have "dec (zip_cont t xs i) ! (2 * k + 1) = 0"
+      using twok1_nth by force
+    then show ?thesis
+      by simp
+  next
+    case False
+    then have "zip_cont t xs i = 0"
+      using zip_cont_def by simp
+    then show ?thesis
+      by simp
+  qed
+  ultimately show ?thesis
+    using begin_tapeI by simp
+qed
+
+definition "es6 \<equiv> es5 @ map (\<lambda>i. (1 + Suc i, 1 + Suc i)) [0..<n] @ [(1 + n, 1 + n)]"
+
+lemma len_es6: "length es6 = length (es_fmt n) + 2 * TT + n + 4"
+  using es6_def len_es5 by simp
+
+definition tps6 :: "tape list" where
+  "tps6 \<equiv>
+    [(\<lfloor>zs\<rfloor>, n + 1),
+     (zip_cont 0 (replicate k (0, Some 0)), n + 1)] @
+    replicate (2 * k + 1) (\<lceil>\<triangleright>\<rceil>)"
+
+lemma tm6: "traces tm6 tps0 es6 tps6"
+  unfolding tm6_def es6_def
+proof (rule traces_sequential)
+  show "traces tm5 tps0 es5 tps5"
+    using tm5 .
+  show "traces
+     tm5_6
+     tps5
+     (map (\<lambda>i. (1 + Suc i, 1 + Suc i)) [0..<n] @ [(1 + n, 1 + n)])
+     tps6"
+     unfolding tm5_6_def
+  proof (rule traces_tm_trans_until_01I[where ?n=n])
+    show "1 < length tps5"
+      using tps5_def by simp
+    show "rneigh (tps5 ! 0) {0} n"
+      using tps5_def contents_def zs_proper by (intro rneighI) auto
+    show "map (\<lambda>i. (1 + Suc i, 1 + Suc i)) [0..<n] @ [(1 + n, 1 + n)] =
+        map (\<lambda>i. (tps5 :#: 0 + Suc i, tps5 :#: 1 + Suc i)) [0..<n] @ [(tps5 :#: 0 + n, tps5 :#: 1 + n)]"
+      using tps5_def by simp
+    show "tps6 = tps5
+        [0 := tps5 ! 0 |+| n,
+         1 := transplant (tps5 ! 0) (tps5 ! 1) (\<lambda>h. enc (h mod G # replicate (k - 1) 0 @ replicate k 0 @ [0, 0])) n]"
+    proof -
+      define f where "f = (\<lambda>h. enc (h mod G # replicate (k - 1) 0 @ replicate k 0 @ [0, 0]))"
+      let ?tp1 = "tps5 ! 0"
+      let ?tp2 = "tps5 ! 1"
+      let ?xs = "replicate k (0::nat, Some 0::nat option)"
+      have rhs_less_TT: "zip_cont 0 ?xs i = enc
+             (map (\<lambda>j. (start_config k zs <:> j) i) [0..<k] @
+              map (\<lambda>j. if i = start_config k zs <#> j then 1 else 0) [0..<k] @
+              [0, if i = 0 then 1 else 0])"
+          if "i < TT" for i
+      proof -
+        have "zip_cont 0 ?xs i = enc
+             (map (\<lambda>j. (exec (0 + fst (?xs ! j)) <:> j) i) [0..<k] @
+              map (\<lambda>j. case snd (?xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (0 + d) <#> j then 1 else 0) [0..<k] @
+              [if i < 0 then 1 else 0,
+               if i = 0 then 1 else 0])"
+          using that zip_cont_def by simp
+        moreover have "map (\<lambda>j. (exec (0 + fst (?xs ! j)) <:> j) i) [0..<k] = map (\<lambda>j. (exec 0 <:> j) i) [0..<k]"
+          by simp
+        ultimately have "zip_cont 0 ?xs i = enc
+             (map (\<lambda>j. (exec 0 <:> j) i) [0..<k] @
+              map (\<lambda>j. case snd (?xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (0 + d) <#> j then 1 else 0) [0..<k] @
+              [if i < 0 then 1 else 0,
+               if i = 0 then 1 else 0])"
+          by metis
+        also have "... = enc
+             (map (\<lambda>j. (exec 0 <:> j) i) [0..<k] @
+              map (\<lambda>j. if i = exec 0 <#> j then 1 else 0) [0..<k] @
+              [if i < 0 then 1 else 0,
+               if i = 0 then 1 else 0])"
+        proof -
+          have 1: "map (\<lambda>j. case snd (?xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (0 + d) <#> j then 1 else 0) [0..<k] =
+              map (\<lambda>j. if i = exec 0 <#> j then 1 else 0) [0..<k]"
+            by simp
+          show ?thesis
+            by (simp add: 1)
+        qed
+        finally show ?thesis
+          using exec_def by simp
+      qed
+
+      have "(if snd ?tp2 \<le> i \<and> i < snd ?tp2 + n then f (fst ?tp1 (snd ?tp1 + i - snd ?tp2)) else fst ?tp2 i) =
+            zip_cont 0 (replicate k (0, Some 0)) i"
+          (is "?lhs = ?rhs")
+          for i
+      proof (cases "1 \<le> i \<and> i < 1 + n")
+        case True
+        then have "snd ?tp2 \<le> i \<and> i < snd ?tp2 + n"
+          using tps5_def by simp
+        then have "?lhs = f (fst ?tp1 (snd ?tp1 + i - snd ?tp2))"
+          by simp
+        then have "?lhs = f (fst ?tp1 i)"
+          using tps5_def by simp
+        then have "?lhs = f (zs ! (i - 1))" (is "_ = f (zs ! ?i)")
+          using tps5_def contents_def True by simp
+        moreover have "zs ! ?i < G"
+          using True zs_less_G by auto
+        ultimately have lhs: "?lhs = enc (zs ! ?i # replicate (k - 1) 0 @ replicate k 0 @ [0, 0])"
+          using f_def by simp
+
+        have "TT > n"
+          using fmt_ge_n by (simp add: le_imp_less_Suc)
+        then have "i < TT"
+          using True by simp
+        then have rhs: "?rhs = enc
+             (map (\<lambda>j. (start_config k zs <:> j) i) [0..<k] @
+              map (\<lambda>j. if i = start_config k zs <#> j then 1 else 0) [0..<k] @
+              [0, 0])"
+          using True rhs_less_TT by simp
+
+        have "map (\<lambda>j. (start_config k zs <:> j) i) [0..<k] = zs ! ?i # replicate (k - 1) 0" (is "?l = ?r")
+        proof (intro nth_equalityI)
+          show "length ?l = length ?r"
+            using k_ge_2 by simp
+          show "?l ! j = ?r ! j" if "j < length ?l" for j
+          proof (cases "j = 0")
+            case c1: True
+            have "(start_config k zs <:> 0) i = zs ! ?i"
+              using start_config_def True by simp
+            then show ?thesis
+              using c1 that by auto
+          next
+            case c2: False
+            then have "(start_config k zs <:> j) i = 0"
+              using start_config_def True that by simp
+            then show ?thesis
+              using c2 that by simp
+          qed
+        qed
+        moreover have "map (\<lambda>j. if i = start_config k zs <#> j then 1 else 0) [0..<k] = replicate k 0"
+        proof -
+          have "start_config k zs <#> j = 0" if "j < k" for j
+            using that start_config_pos by auto
+          then have "map (\<lambda>j. if i = start_config k zs <#> j then 1 else 0) [0..<k] = map (\<lambda>j. 0) [0..<k]"
+            using True by simp
+          then show ?thesis
+            by (simp add: map_replicate_trivial)
+        qed
+        ultimately show "?lhs = ?rhs"
+          using lhs rhs by (metis Cons_eq_appendI)
+      next
+        case outside: False
+        show ?thesis
+        proof (cases "i = 0")
+          case True
+          then have lhs: "?lhs = enc (replicate k 1 @ replicate k 1 @ [0, 1])"
+            using tps5_def contents'_def by simp
+          moreover have "?rhs = enc
+                (map (\<lambda>j. (start_config k zs <:> j) i) [0..<k] @
+                 map (\<lambda>j. if i = start_config k zs <#> j then 1 else 0) [0..<k] @
+                 [0, 1])"
+            using rhs_less_TT True by simp
+          moreover have "map (\<lambda>j. (start_config k zs <:> j) i) [0..<k] = replicate k 1" (is "?l = ?r")
+          proof (rule nth_equalityI)
+            show "length ?l = length ?r"
+              by simp
+            then show "?l ! j = ?r ! j" if "j < length ?l" for j
+              using start_config_def True that start_config2 by simp
+          qed
+          moreover have "map (\<lambda>j. if i = start_config k zs <#> j then 1 else 0) [0..<k] = replicate k 1" (is "?l = ?r")
+          proof (rule nth_equalityI)
+            show "length ?l = length ?r"
+              by simp
+            show "?l ! j = ?r ! j" if "j < length ?l" for j
+              using True start_config_pos that by auto
+          qed
+          ultimately show ?thesis
+            by metis
+        next
+          case False
+          then have "i > n"
+            using outside by simp
+          then have lhs: "?lhs = fst ?tp2 i"
+            using tps5_def by simp
+          then show ?thesis
+          proof (cases "i < TT")
+            case True
+            moreover have "i > 0"
+              using False by simp
+            ultimately have lhs: "?lhs = enc (replicate k 0 @ replicate k 0 @ [0, 0])"
+              using lhs tps5_def contents'_def by simp
+
+            have "?rhs = enc
+                (map (\<lambda>j. (start_config k zs <:> j) i) [0..<k] @
+                 map (\<lambda>j. if i = start_config k zs <#> j then 1 else 0) [0..<k] @
+                 [0, 0])"
+              using True False rhs_less_TT by simp
+            moreover have "map (\<lambda>j. (start_config k zs <:> j) i) [0..<k] = replicate k 0" (is "?l = ?r")
+            proof (rule nth_equalityI)
+              show "length ?l = length ?r"
+                by simp
+              show "?l ! j = ?r ! j" if "j < length ?l" for j
+              proof (cases "j = 0")
+                case True
+                then show ?thesis
+                  using that start_config_def `i > n` by simp
+              next
+                case False
+                then show ?thesis
+                  using that start_config_def `i > 0` by simp
+              qed
+            qed
+            moreover have "map (\<lambda>j. if i = start_config k zs <#> j then 1 else 0) [0..<k] = replicate k 0"
+            proof -
+              have "start_config k zs <#> j = 0" if "j < k" for j
+                using that start_config_pos by auto
+              then have "map (\<lambda>j. if i = start_config k zs <#> j then 1 else 0) [0..<k] = map (\<lambda>j. 0) [0..<k]"
+                by (simp add: False)
+              then show ?thesis
+                by (simp add: map_replicate_trivial)
+            qed
+            ultimately show ?thesis
+              using lhs by metis
+          next
+            case False
+            then have "i \<ge> TT"
+              by simp
+            moreover have "length (enc (replicate k 1 @ replicate k 1 @ [0, 1]) # replicate (fmt n) (enc (replicate k 0 @ replicate k 0 @ [0, 0]))) = TT"
+              by simp
+            ultimately have "?lhs = 0"
+              using lhs contents'_at_ge by (simp add: tps5_def)
+            moreover have "?rhs = 0"
+              using zip_cont_def `i \<ge> TT` by simp
+            ultimately show ?thesis
+              by simp
+          qed
+        qed
+      qed
+      then have "(\<lambda>i. if snd ?tp2 \<le> i \<and> i < snd ?tp2 + n then f (fst ?tp1 (snd ?tp1 + i - snd ?tp2)) else fst ?tp2 i) =
+            zip_cont 0 (replicate k (0, Some 0))"
+        by simp
+      moreover have "transplant (tps5 ! 0) (tps5 ! 1) (\<lambda>h. enc (h mod G # replicate (k - 1) 0 @ replicate k 0 @ [0, 0])) n =
+          (\<lambda>i. if snd ?tp2 \<le> i \<and> i < snd ?tp2 + n then f (fst ?tp1 (snd ?tp1 + i - snd ?tp2)) else fst ?tp2 i,
+            snd ?tp2 + n)"
+        using transplant_def f_def by auto
+      ultimately have "transplant (tps5 ! 0) (tps5 ! 1) (\<lambda>h. enc (h mod G # replicate (k - 1) 0 @ replicate k 0 @ [0, 0])) n =
+          (zip_cont 0 (replicate k (0, Some 0)), n + 1)"
+        using tps5_def by simp
+      then have "tps6 ! 1 = transplant (tps5 ! 0) (tps5 ! 1) (\<lambda>h. enc (h mod G # replicate (k - 1) 0 @ replicate k 0 @ [0, 0])) n"
+        using tps6_def by simp
+      moreover have "tps6 ! 0 = tps5 ! 0 |+| n"
+        using tps6_def tps5_def by simp
+      ultimately show ?thesis
+        using tps5_def tps6_def by simp
+    qed
+  qed
+qed
+
+definition tps7 :: "tape list" where
+  "tps7 \<equiv>
+    [(\<lfloor>zs\<rfloor>, n + 1),
+     (zip_cont 0 (replicate k (0, Some 0)), 0)] @
+    replicate (2 * k + 1) (\<lceil>\<triangleright>\<rceil>)"
+
+definition "es7 \<equiv> es6 @ map (\<lambda>i. (n + 1, i)) (rev [0..<n + 1]) @ [(n + 1, 0)]"
+
+lemma len_es7: "length es7 = length (es_fmt n) + 2 * TT + 2 * n + 6"
+  using es7_def len_es6 by simp
+
+lemma tm7: "traces tm7 tps0 es7 tps7"
+  unfolding tm7_def es7_def
+proof (rule traces_sequential)
+  show "traces tm6 tps0 es6 tps6"
+    using tm6 .
+  show "traces tm_left_until1 tps6 (map (Pair (n + 1)) (rev [0..<n + 1]) @ [(n + 1, 0)]) tps7"
+  proof (rule traces_tm_left_until_1I)
+    show "1 < length tps6"
+      using tps6_def by simp
+    show "map (Pair (n + 1)) (rev [0..<n + 1]) @ [(n + 1, 0)] =
+        map (Pair (tps6 :#: 0)) (rev [0..<tps6 :#: 1]) @ [(tps6 :#: 0, 0)]"
+      using tps6_def by simp
+    show "tps7 = tps6[1 := tps6 ! 1 |#=| 0]"
+      using tps6_def tps7_def by simp
+    show "begin_tape StartSym (tps6 ! 1)"
+      using begin_tape_zip_cont tps6_def by simp
+  qed
+qed
+
+definition tps8 :: "tape list" where
+  "tps8 \<equiv>
+    [(\<lfloor>zs\<rfloor>, n + 1),
+     (zip_cont 0 (replicate k (0, Some 0)), 0),
+     \<lceil>\<box>\<rceil>] @
+    replicate (2 * k) (\<lceil>\<triangleright>\<rceil>)"
+
+definition "es8 \<equiv> es7 @ [(n + 1, 0)]"
+
+lemma len_es8: "length es8 = length (es_fmt n) + 2 * TT + 2 * n + 7"
+  using es8_def len_es7 by simp
+
+lemma tm8: "traces tm8 tps0 es8 tps8"
+  unfolding tm8_def es8_def
+proof (rule traces_sequential)
+  show "traces tm7 tps0 es7 tps7"
+    using tm7 .
+  show "traces (tm_write 2 0) tps7 [(n + 1, 0)] tps8"
+  proof (rule traces_tm_write_ge2I)
+    show "(2::nat) \<le> 2"
+      by simp
+    show "2 < length tps7" "[(n + 1, 0)] = [(tps7 :#: 0, tps7 :#: 1)]"
+      using tps7_def by simp_all
+    show "tps8 = tps7[2 := tps7 ! 2 |:=| 0]"
+    proof (rule nth_equalityI)
+      show "length tps8 = length (tps7[2 := tps7 ! 2 |:=| 0])"
+        using tps7_def tps8_def by simp
+      show "tps8 ! i = tps7[2 := tps7 ! 2 |:=| 0] ! i" if "i < length tps8" for i
+      proof -
+        consider "i = 0" | "i = 1" | "i = 2" | "i > 2"
+          by linarith
+        then show ?thesis
+        proof (cases)
+          case 1
+          then show ?thesis
+            using tps7_def tps8_def by simp
+        next
+          case 2
+          then show ?thesis
+            using tps7_def tps8_def by simp
+        next
+          case 3
+          then have *: "tps8 ! i = \<lceil>\<box>\<rceil>"
+            using tps8_def by simp
+          have "(tps7 ! 2) |:=| \<box> = \<lceil>\<box>\<rceil>"
+            using tps7_def onesie_write by simp
+          then have "(tps7[2 := tps7 ! 2 |:=| \<box>]) ! 2 = \<lceil>\<box>\<rceil>"
+            using tps7_def by simp
+          then show ?thesis
+            using 3 * by simp
+        next
+          case 4
+          then have "tps8 ! i = \<lceil>\<triangleright>\<rceil>"
+            using tps8_def that by simp
+          moreover have "tps7 ! i = \<lceil>\<triangleright>\<rceil>"
+            using tps7_def that "4" tps8_def by auto
+          ultimately show ?thesis
+            by (simp add: "4" less_not_refl3)
+        qed
+      qed
+    qed
+  qed
+qed
+
+definition tps9 :: "tape list" where
+  "tps9 \<equiv>
+    [(\<lfloor>zs\<rfloor>, n + 1),
+     (zip_cont 0 (replicate k (0, Some 0)), 0),
+     \<lceil>\<box>\<rceil>] @
+    replicate (2 * k) (\<lceil>\<box>\<rceil>)"
+
+definition "es9 \<equiv> es8 @ [(n + 1, 0)]"
+
+lemma len_es9: "length es9 = length (es_fmt n) + 2 * TT + 2 * n + 8"
+  using es9_def len_es8 by simp
+
+lemma tm9: "traces tm9 tps0 es9 tps9"
+  unfolding tm9_def es9_def
+proof (rule traces_sequential[OF tm8])
+  show "traces (tm_write_many {3..<2 * k + 3} 0) tps8 [(n + 1, 0)] tps9"
+  proof (rule traces_tm_write_manyI[where ?k="2*k+3"])
+    show "0 \<notin> {3..<2 * k + 3}"
+      by simp
+    show "\<forall>j\<in> {3..<2 * k + 3}. j < 2 * k + 3"
+      by simp
+    show "2 \<le> 2 * k + 3"
+      by simp
+    show "length tps8 = 2 * k + 3" "length tps9 = 2 * k + 3"
+      using tps8_def tps9_def by simp_all
+    show "[(n + 1, 0)] = [(tps8 :#: 0, tps8 :#: 1)]"
+      using tps8_def by simp
+    show "tps9 ! j = tps8 ! j" if "j < 2 * k + 3" "j \<notin> {3..<2 * k + 3}" for j
+    proof -
+      have "j < 3"
+        using that by simp
+      then show ?thesis
+        using tps8_def tps9_def by (metis (no_types, lifting) length_Cons list.size(3) nth_append numeral_3_eq_3)
+    qed
+    show "tps9 ! j = tps8 ! j |:=| 0" if "j \<in> {3..<2 * k + 3}" for j
+    proof -
+      have j: "j \<ge> 3" "j < 2 * k + 3"
+        using that by simp_all
+      then have "tps8 ! j = \<lceil>\<triangleright>\<rceil>"
+        using tps8_def by simp
+      moreover have "tps9 ! j = \<lceil>\<box>\<rceil>"
+        using j tps9_def by simp
+      ultimately show ?thesis
+        by (simp add: onesie_write)
+    qed
+  qed
+qed
+
+subsubsection \<open>The loop\<close>
+
+text \<open>
+Immediately before and during the loop the tapes will have the shape below.  The
+input tape will stay unchanged. The output tape will contain the $k$ encoded
+tapes of $M$. The first memorization tape will contain $M$'s state. The
+following $k$ memorization tapes will store information about head movements.
+The final $k$ memorization tapes will have information about read or
+to-be-written symbols.
+\<close>
+
+definition tpsL :: "nat \<Rightarrow> (nat \<times> nat option) list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> (nat \<Rightarrow> symbol) \<Rightarrow> tape list" where
+  "tpsL t xs i q mvs symbs \<equiv>
+    (\<lfloor>zs\<rfloor>, n + 1) #
+    (zip_cont t xs, i) #
+    \<lceil>fst (exec (t + q))\<rceil> #
+    map (onesie \<circ> mvs) [0..<k] @
+    map (onesie \<circ> symbs) [0..<k]"
+
+lemma length_tpsL [simp]: "length (tpsL t xs i q mvs symbs) = 2 * k + 3"
+  using tpsL_def by simp
+
+lemma tpsL_pos_0: "tpsL t xs i q mvs symbs :#: 0 = n + 1"
+  unfolding tpsL_def by simp
+
+lemma tpsL_pos_1: "tpsL t xs i q mvs symbs :#: 1 = i"
+  unfolding tpsL_def by simp
+
+lemma read_tpsL_0: "read (tpsL t xs i q mvs symbs) ! 0 = \<box>"
+  unfolding tpsL_def using contents_def read_def by simp
+
+lemma read_tpsL_1: "read (tpsL t xs i q mvs symbs) ! 1 =
+  (if i < TT then enc
+    (map (\<lambda>j. (exec (t + fst (xs ! j)) <:> j) i) [0..<k] @
+     map (\<lambda>j. case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+     [if i < t then 1 else 0,
+      if i = 0 then 1 else 0])
+   else 0)"
+  unfolding tpsL_def zip_cont_def using read_def by simp
+
+lemma read_tpsL_1_nth_less_k:
+  assumes "i < TT" and "j < k"
+  shows "enc_nth (read (tpsL t xs i q mvs symbs) ! 1) j = (exec (t + fst (xs ! j)) <:> j) i"
+  using assms read_tpsL_1 dec_zip_cont_less_k enc_nth_def zip_cont_def by auto
+
+lemma read_tpsL_1_nth_less_2k:
+  assumes "i < TT" and "k \<le> j" and "j < 2 * k"
+  shows "enc_nth (read (tpsL t xs i q mvs symbs) ! 1) j =
+    (case snd (xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+  using assms read_tpsL_1 dec_zip_cont_less_2k enc_nth_def zip_cont_def by simp
+
+lemma read_tpsL_1_nth_2k:
+  assumes "i < TT"
+  shows "enc_nth (read (tpsL t xs i q mvs symbs) ! 1) (2 * k) = (if i < t then 1 else 0)"
+  using assms read_tpsL_1 dec_zip_cont_2k enc_nth_def zip_cont_def by simp
+
+lemma read_tpsL_1_nth_2k1:
+  assumes "i < TT"
+  shows "enc_nth (read (tpsL t xs i q mvs symbs) ! 1) (2 * k + 1) = (if i = 0 then 1 else 0)"
+  using assms read_tpsL_1 dec_zip_cont_2k1 enc_nth_def zip_cont_def by simp
+
+lemma read_tpsL_1_bounds:
+  assumes "i < TT"
+  shows "read (tpsL t xs i q mvs symbs) ! 1 > 1"
+    and "read (tpsL t xs i q mvs symbs) ! 1 < G ^ (2 * k + 2) + 2"
+proof -
+  have "read (tpsL t xs i q mvs symbs) ! 1 = zip_cont t xs i"
+    using tpsL_def read_def by simp
+  then show "read (tpsL t xs i q mvs symbs) ! 1 > 1"
+      and "read (tpsL t xs i q mvs symbs) ! 1 < G ^ (2 * k + 2) + 2"
+    using zip_cont_gt_1[OF assms] zip_cont_less[OF assms] by simp_all
+qed
+
+lemma read_tpsL_2: "read (tpsL t xs i q mvs symbs) ! 2 = fst (exec (t + q))"
+  unfolding tpsL_def using contents_def read_def by simp
+
+lemma read_tpsL_3:
+  assumes "3 \<le> j" and "j < k + 3"
+  shows "read (tpsL t xs i q mvs symbs) ! j = mvs (j - 3)"
+proof -
+  define j' where "j' = j - 3"
+  then have "j' < k"
+    using assms by simp
+  have "read (tpsL t xs i q mvs symbs) ! j =
+      (map (tape_read \<circ> (onesie \<circ> mvs)) [0..<k] @
+       map (tape_read \<circ> (onesie \<circ> symbs)) [0..<k]) !
+      (j - Suc (Suc (Suc 0)))"
+    unfolding tpsL_def read_def using assms by simp
+  also have "... =
+    (map (tape_read \<circ> (onesie \<circ> mvs)) [0..<k] @
+     map (tape_read \<circ> (onesie \<circ> symbs)) [0..<k]) ! j'"
+    by (simp add: j'_def numeral_3_eq_3)
+  also have "... = mvs j'"
+    using `j' < k` by (simp add: nth_append)
+  finally have "read (tpsL t xs i q mvs symbs) ! j = mvs j'" .
+  then show ?thesis
+    using j'_def by simp
+qed
+
+lemma read_tpsL_3':
+  assumes "j < k"
+  shows "read (tpsL t xs i q mvs symbs) ! (j + 3) = mvs j"
+  using assms read_tpsL_3 by simp
+
+lemma read_tpsL_4:
+  assumes "k + 3 \<le> j" and "j < 2 * k + 3"
+  shows "read (tpsL t xs i q mvs symbs) ! j = symbs (j - k - 3)"
+proof -
+  define j' where "j' = j - 3"
+  then have j': "k \<le> j'" "j' < k + k"
+    using assms by simp_all
+  have "read (tpsL t xs i q mvs symbs) ! j =
+      (map (tape_read \<circ> (onesie \<circ> mvs)) [0..<k] @
+       map (tape_read \<circ> (onesie \<circ> symbs)) [0..<k]) !
+      (j - Suc (Suc (Suc 0)))"
+    unfolding tpsL_def read_def using assms by simp
+  also have "... =
+    (map (tape_read \<circ> (onesie \<circ> mvs)) [0..<k] @
+     map (tape_read \<circ> (onesie \<circ> symbs)) [0..<k]) ! j'"
+    by (simp add: j'_def numeral_3_eq_3)
+  also have "... = symbs (j' - k)"
+    using j' by (simp add: nth_append)
+  finally have "read (tpsL t xs i q mvs symbs) ! j = symbs (j' - k)" .
+  then show ?thesis
+    using j'_def using diff_commute by auto
+qed
+
+lemma map_const_upt: "map (onesie \<circ> (\<lambda>_. c)) [0..<k] = replicate k \<lceil>c\<rceil>"
+  by (metis List.map.compositionality map_replicate map_replicate_trivial)
+
+text \<open>
+After the initialization, that is, right before the loop, the simulator's tapes
+look like this:
+\<close>
+
+lemma tps9_tpsL: "tps9 = tpsL 0 (replicate k (0, Some 0)) 0 0 (\<lambda>j. 0) (\<lambda>j. 0)"
+proof -
+  have "fst (exec 0) = 0"
+    using exec_def by (simp add: start_config_def)
+  then have "tpsL 0 (replicate k (0, Some 0)) 0 0 (\<lambda>j. 0) (\<lambda>j. 0) =
+    (\<lfloor>zs\<rfloor>, n + 1) #
+    (zip_cont 0 (replicate k (0, Some 0)), 0) #
+    \<lceil>\<box>\<rceil> #
+    replicate k (\<lceil>\<box>\<rceil>) @
+    replicate k (\<lceil>\<box>\<rceil>)"
+    using tpsL_def map_const_upt by simp
+  then show ?thesis
+    using tps9_def by (metis Cons_eq_appendI mult_2 replicate_add self_append_conv2)
+qed
+
+lemma tpsL_0: "tpsL t xs i q mvs symbs ! 0 = (\<lfloor>zs\<rfloor>, n + 1)"
+  using tpsL_def by simp
+
+lemma tpsL_1: "tpsL t xs i q mvs symbs ! 1 = (zip_cont t xs, i)"
+  using tpsL_def by simp
+
+lemma tpsL_2: "tpsL t xs i q mvs symbs ! 2 = \<lceil>fst (exec (t + q))\<rceil>"
+  using tpsL_def by simp
+
+lemma tpsL_mvs: "j < k \<Longrightarrow> tpsL t xs i q mvs symbs ! (3 + j) = \<lceil>mvs j\<rceil>"
+  using tpsL_def by (simp add: nth_append)
+
+lemma tpsL_mvs': "3 \<le> j \<Longrightarrow> j < 3 + k \<Longrightarrow> tpsL t xs i q mvs symbs ! j = \<lceil>mvs (j - 3)\<rceil>"
+  using tpsL_mvs by (metis add.commute le_add_diff_inverse less_diff_conv2)
+
+lemma tpsL_symbs:
+  assumes "j < k"
+  shows "tpsL t xs i q mvs symbs ! (3 + k + j) = \<lceil>symbs j\<rceil>"
+  using tpsL_def assms by (simp add: nth_append)
+
+lemma tpsL_symbs':
+  assumes "3 + k \<le> j" and "j < 2 * k + 3"
+  shows "tpsL t xs i q mvs symbs ! j = \<lceil>symbs (j - k - 3)\<rceil>"
+proof -
+  have "j - (k + 3) < k"
+    using assms(1) assms(2) by linarith
+  then show ?thesis
+    using assms(1) tpsL_symbs by fastforce
+qed
+
+text \<open>The condition: less than $TT$ steps simulated.\<close>
+
+definition tpsC0 :: "nat \<Rightarrow> tape list" where
+  "tpsC0 t \<equiv> tpsL t (replicate k (0, Some 0)) 0 0 (\<lambda>j. 0) (\<lambda>j. 0)"
+
+definition "tpsC1 t \<equiv> tpsL t (replicate k (0, Some 0)) t 0 (\<lambda>j. 0) (\<lambda>j. 0)"
+
+definition "esC t \<equiv> map (\<lambda>i. (n + 1, Suc i)) [0..<t] @ [(n + 1, t)]"
+
+lemma set_filter_upt: "x \<in> set (filter f [0..<N]) \<Longrightarrow> x < N"
+  by simp
+
+lemma set_filter_upt': "x \<in> set (filter f [0..<N]) \<Longrightarrow> f x"
+  by simp
+
+text \<open>
+We will use this TM at the end of the loop again. Therefore we
+prove a more general result than necessary at this point.
+\<close>
+
+lemma tmC_general:
+  assumes "t \<le> TT"
+    and "tps = tpsL t xs 0 i mvs symbs"
+    and "tps' = tpsL t xs t i mvs symbs"
+  shows "traces tmC tps (esC t) tps'"
+  unfolding tmC_def
+proof (rule traces_tm_right_until_1I[where ?n="t"])
+  show "1 < length tps"
+    using assms(2) by simp
+  show "tps' = tps[1 := tps ! 1 |+| t]"
+    using assms(2,3) tpsL_def by simp
+  show "esC t =
+      map (\<lambda>i. (tps :#: 0, tps :#: 1 + Suc i)) [0..<t] @ [(tps :#: 0, tps :#: 1 + t)]"
+    using esC_def assms(2) tpsL_def by simp
+  show "rneigh (tps ! 1) {y. y < G ^ (2 * k + 2) + 2 \<and> (y = 0 \<or> dec y ! (2 * k) = 0)} t"
+    (is "rneigh _ ?s t")
+  proof (rule rneighI)
+    have 1: "tps ! 1 = (zip_cont t xs, 0)"
+      using assms(2) tpsL_def by simp
+    have s: "?s = {y. y = 0 \<or> (dec y ! (2 * k) = 0 \<and> y < G ^ (2 * k + 2) + 2)}" (is "_ = ?r")
+      by auto
+    show "(tps ::: 1) (tps :#: 1 + t) \<in> ?s"
+    proof (cases "t = TT")
+      case True
+      then have "tps :#: 1 + t = TT"
+        using assms(2) tpsL_def by simp
+      moreover have "(tps ::: 1) TT = 0"
+        using assms(2) tpsL_def zip_cont_def by simp
+      ultimately show ?thesis
+        by auto
+    next
+      case False
+      with assms have "t < TT"
+        by simp
+      let ?y = "(tps ::: 1) t"
+      have "dec ?y ! (2 * k) = 0"
+        using assms(2) tpsL_def dec_zip_cont[OF `t < TT`] by (simp add: twok_nth)
+      moreover have "?y < G ^ (2 * k + 2) + 2"
+        using assms(2) tpsL_def `t < TT` zip_cont_less by simp
+      ultimately have "?y \<in> ?s"
+        using s by simp
+      then show ?thesis
+        using 1 by simp
+    qed
+    show "(tps ::: 1) (tps :#: 1 + m) \<notin> ?s" (is "?y \<notin> ?s") if "m < t" for m
+    proof -
+      have "m < TT"
+        using that assms by simp
+      then have "dec ?y ! (2 * k) = 1"
+        using tpsC0_def tpsL_def dec_zip_cont[OF `m < TT`] that
+        by (metis (no_types, lifting) "1" add_cancel_right_left dec_zip_cont_2k prod.sel(1) prod.sel(2))
+      moreover from `m < TT` have "?y > 1"
+        using 1 zip_cont_gt_1 by simp
+      ultimately show ?thesis
+        using s by simp
+    qed
+  qed
+qed
+
+corollary tmC:
+  assumes "t \<le> TT"
+  shows "traces tmC (tpsC0 t) (esC t) (tpsC1 t)"
+  using tmC_general tpsC0_def tpsC1_def assms by simp
+
+lemma tpsC1_at_T: "tpsC1 TT :.: 1 = 0"
+  using tpsC1_def tpsL_def zip_cont_def by simp
+
+lemma tpsC1_at_less_T: "t < TT \<Longrightarrow> tpsC1 t :.: 1 > 0"
+proof -
+  assume "t < TT"
+  then have "tpsC1 t :.: 1 > 1"
+    using tpsC1_def tpsL_def zip_cont_def enc_greater by simp
+  then show ?thesis
+    by simp
+qed
+
+text \<open>The body of the loop: simulating one step\<close>
+
+definition "tpsL0 t \<equiv> tpsL t (replicate k (0, Some 0)) t 0 (\<lambda>j. 0) (\<lambda>j. 0)"
+
+lemma tpsL0_eq_tpsC1: "tpsL0 t = tpsC1 t"
+  using tpsL0_def tpsC1_def by simp
+
+definition "esL1 t \<equiv> map (\<lambda>i. (n + 1, i)) (rev [0..<t]) @ [(n + 1, 0)]"
+
+definition "tpsL1 t \<equiv> tpsL t (replicate k (0, Some 0)) 0 0 (\<lambda>j. 0) (\<lambda>j. 0)"
+
+lemma tmL1: "traces tmL1 (tpsL0 t) (esL1 t) (tpsL1 t)"
+  unfolding tmL1_def esL1_def
+proof (rule traces_tm_left_until_1I)
+  show "1 < length (tpsL0 t)"
+    using tpsL0_def tpsL_def by simp
+  show "map (Pair (n + 1)) (rev [0..<t]) @ [(n + 1, 0)] =
+      map (Pair (tpsL0 t :#: 0)) (rev [0..<tpsL0 t :#: 1]) @ [(tpsL0 t :#: 0, 0)]"
+    using tpsL0_def tpsL_def by simp
+  show "tpsL1 t = (tpsL0 t)[1 := tpsL0 t ! 1 |#=| 0]"
+    using tpsL0_def tpsL1_def tpsL_def by simp
+  show "begin_tape StartSym (tpsL0 t ! 1)"
+    using begin_tape_zip_cont tpsL0_def tpsL_def by simp
+qed
+
+text \<open>Collecting the read symbols of the simulated machines:\<close>
+
+lemma sem_cmdL2_ge_TT:
+  assumes "tps = tpsL t xs i q mvs symbs" and "i \<ge> TT"
+  shows "sem cmdL2 (0, tps) = (1, tps)"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) cmdL2"
+    using cmdL2_def by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(1) by simp
+  show "length tps = 2 * k + 3"
+    using assms(1) by simp
+  let ?rs = "read tps"
+  show "fst (cmdL2 ?rs) = 1"
+  proof -
+    have "?rs ! 1 = \<box>"
+      using assms read_tpsL_1 by auto
+    then show ?thesis
+      by (simp add: cmdL2_def)
+  qed
+  then show "act (cmdL2 ?rs [!] i) (tps ! i) = tps ! i" if "i < 2 * k + 3" for i
+    using assms that
+    by (metis (no_types, lifting) One_nat_def act_Stay cmdL2_at_eq_0 cmdL2_def len less_Suc_eq_0_disj
+      less_numeral_extra(4) prod.sel(1) read_length)
+qed
+
+lemma sem_cmdL2_less_TT:
+  assumes "tps = tpsL t xs i q mvs symbs"
+    and "symbs = (\<lambda>j. if exec t <#> j < i then exec t <.> j else 0) "
+    and "tps' = tpsL t xs (Suc i) q mvs symbs'"
+    and "symbs' = (\<lambda>j. if exec t <#> j < Suc i then exec t <.> j else 0) "
+    and "i < TT"
+    and "xs = replicate k (0, Some 0)"
+  shows "sem cmdL2 (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) cmdL2"
+    using cmdL2_def by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(1) by simp
+  show len': "length tps' = 2 * k + 3"
+    using assms(3) by simp
+  define rs where "rs = read tps"
+  then have rs_at_1: "rs ! 1 \<noteq> \<box>"
+    using assms(1,5) read_tpsL_1 enc_greater by (metis (no_types, lifting) not_one_less_zero)
+  then show "fst (cmdL2 (read tps)) = 0"
+    by (simp add: cmdL2_def rs_def)
+  show "act (cmdL2 (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    have snd: "snd (cmdL2 rs) =
+      [(rs!0, Stay), (rs!1, Right), (rs!2, Stay)] @
+       (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+       (map (\<lambda>j. (if 1 < rs ! 1 \<and> rs ! 1 < G^(2*k+2)+2 \<and> enc_nth (rs!1) (k+j) = 1 then enc_nth (rs!1) j else rs!(3+k+j), Stay)) [0..<k])"
+      using rs_at_1 by (simp add: cmdL2_def)
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using \<open>j < 2 * k + 3\<close> by linarith
+    then show ?thesis
+    proof cases
+      case 1
+      then have "cmdL2 rs [!] j = (rs ! 0, Stay)"
+        by (simp add: snd)
+      then show ?thesis
+        using act_Stay assms(1,3) tpsL_def "1" rs_def read_tpsL_0 by auto
+    next
+      case 2
+      then have "cmdL2 rs [!] j = (rs ! 1, Right)"
+        by (simp add: snd)
+      then show ?thesis
+        using act_Right assms(1,3) "2" rs_def
+        by (metis Suc_eq_plus1 add.commute add_Suc fst_conv len less_add_Suc1 numeral_3_eq_3 sndI tpsL_1)
+    next
+      case 3
+      then have "cmdL2 rs [!] j = (rs ! 2, Stay)"
+        by (simp add: snd)
+      then show ?thesis
+        using act_Stay assms(1,3) "3" rs_def by (metis len that tpsL_2)
+    next
+      case 4
+      then have "cmdL2 rs [!] j = (rs ! j, Stay)"
+        using cmdL2_at_3 rs_at_1 by simp
+      then show ?thesis
+        using act_Stay assms(1,3) "4" rs_def by (metis add.commute len that tpsL_mvs')
+    next
+      case 5
+      then have 1: "cmdL2 rs [!] j =
+          (if 1 < rs ! 1 \<and> rs ! 1 < G^(2*k+2)+2 \<and> enc_nth (rs ! 1) (j - 3) = 1
+           then enc_nth (rs ! 1) (j - k - 3)
+           else rs ! j,
+           Stay)"
+        using cmdL2_at_4 rs_at_1 by simp
+      have enc: "rs ! 1 = enc
+            (map (\<lambda>j. (exec (t + fst (xs ! j)) <:> j) i) [0..<k] @
+             map (\<lambda>j. case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+             [if i < t then 1 else 0,
+              if i = 0 then 1 else 0])"
+        using read_tpsL_1 assms(1,5) rs_def by simp
+      have "rs ! 1 > 1" "rs ! 1 < G ^ (2 * k + 2) + 2"
+        using rs_def assms(1,5) read_tpsL_1_bounds by simp_all
+      then have cmd1: "cmdL2 rs [!] j =
+          (if enc_nth (rs ! 1) (j - 3) = 1 then enc_nth (rs ! 1) (j - k - 3) else rs ! j, Stay)"
+        using 1 by simp
+      have "enc_nth (rs ! 1) (j - 3) =
+          (case snd (xs ! (j - 3 - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - 3 - k) then 1 else 0)"
+        using read_tpsL_1_nth_less_2k[where ?j="j - 3"] 5 assms(1,5) rs_def by auto
+      then have "enc_nth (rs ! 1) (j - 3) = (if i = exec t <#> (j - 3 - k) then 1 else 0)"
+        using 5 assms(6) by auto
+      then have cmd2: "enc_nth (rs ! 1) (j - 3) = (if i = exec t <#> (j - k - 3) then 1 else 0)"
+        by (metis diff_right_commute)
+      let ?j = "j - k - 3"
+      have "enc_nth (rs ! 1) ?j = (exec (t + fst (xs ! ?j)) <:> ?j) i"
+        using read_tpsL_1_nth_less_k[where ?j="j - k - 3"] 5 assms(1,5) rs_def by auto
+      then have "enc_nth (rs ! 1) ?j = (exec t <:> ?j) i"
+        using assms(6) 5 by auto
+      then have "cmdL2 rs [!] j =
+          (if i = exec t <#> ?j then (exec t <:> ?j) i else rs ! j, Stay)"
+        using cmd1 cmd2 by simp
+      then have command: "cmdL2 rs [!] j =
+          (if i = exec t <#> ?j then exec t <.> ?j else rs ! j, Stay)"
+        by simp
+
+      have tps: "tps ! j = \<lceil>if exec t <#> ?j < i then exec t <.> ?j else \<box>\<rceil>"
+        using 5 assms(1,2) tpsL_symbs' by simp
+
+      have tps': "tps' ! j = \<lceil>if exec t <#> ?j < Suc i then exec t <.> ?j else \<box>\<rceil>"
+        using 5 assms(3,4) tpsL_symbs' by simp
+
+      show "act (cmdL2 (read tps) [!] j) (tps ! j) = tps' ! j"
+      proof (cases "exec t <#> ?j = i")
+        case True
+        then have "act (cmdL2 (read tps) [!] j) (tps ! j) = act (exec t <.> ?j, Stay) (tps ! j)"
+          using rs_def command by simp
+        also have "... = act (exec t <.> ?j, Stay) \<lceil>if exec t <#> ?j < i then exec t <.> ?j else \<box>\<rceil>"
+          using tps by simp
+        also have "... = \<lceil>exec t <.> ?j\<rceil>"
+          using act_onesie by simp
+        also have "... = \<lceil>if exec t <#> ?j < Suc i then exec t <.> ?j else \<box>\<rceil>"
+          using True by simp
+        also have "... = tps' ! j"
+          using tps' by simp
+        finally show ?thesis .
+      next
+        case False
+        then have "act (cmdL2 (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+          using rs_def command by simp
+        also have "... = tps ! j"
+          using rs_def act_Stay by (simp add: "5" len)
+        also have "... = \<lceil>if exec t <#> ?j < i then exec t <.> ?j else \<box>\<rceil>"
+          using tps by simp
+        also have "... = \<lceil>if exec t <#> ?j < Suc i then exec t <.> ?j else \<box>\<rceil>"
+          using False by simp
+        also have "... = tps' ! j"
+          using tps' by simp
+        finally show ?thesis .
+      qed
+    qed
+  qed
+qed
+
+corollary sem_cmdL2_less_Tfmt:
+  assumes "xs = replicate k (0, Some 0)" and "i < TT"
+  shows "sem cmdL2
+    (0, tpsL t xs i q mvs (\<lambda>j. if exec t <#> j < i then exec t <.> j else \<box>)) =
+    (0, tpsL t xs (Suc i) q mvs (\<lambda>j. if exec t <#> j < Suc i then exec t <.> j else \<box>))"
+  using sem_cmdL2_less_TT assms by simp
+
+lemma execute_cmdL2_le_TT:
+  assumes "tt \<le> TT" and "xs = replicate k (0, Some 0)" and "tps = tpsL t xs 0 q mvs (\<lambda>_. \<box>)"
+  shows "execute tmL1_2 (0, tps) tt =
+    (0, tpsL t xs tt q mvs (\<lambda>j. if exec t <#> j < tt then exec t <.> j else \<box>))"
+  using assms(1)
+proof (induction tt)
+  case 0
+  then show ?case
+    using assms(3) by simp
+next
+  case (Suc tt)
+  then have "execute tmL1_2 (0, tps) (Suc tt) = exe tmL1_2 (execute tmL1_2 (0, tps) tt)"
+    by simp
+  also have "... = exe tmL1_2 (0, tpsL t xs tt q mvs (\<lambda>j. if exec t <#> j < tt then exec t <.> j else \<box>))"
+    using Suc by simp
+  also have "... = sem cmdL2 (0, tpsL t xs tt q mvs (\<lambda>j. if exec t <#> j < tt then exec t <.> j else \<box>))"
+    unfolding tmL1_2_def using Suc by (simp add: exe_lt_length)
+  also have "... = (0, tpsL t xs (Suc tt) q mvs (\<lambda>j. if exec t <#> j < Suc tt then exec t <.> j else \<box>))"
+    using sem_cmdL2_less_Tfmt[OF assms(2)] Suc by simp
+  finally show ?case .
+qed
+
+lemma tpsL_symbs_eq:
+  assumes "\<And>j. j < k \<Longrightarrow> symbs j = symbs' j"
+  shows "tpsL t xs i q mvs symbs = tpsL t xs i q mvs symbs'"
+  unfolding tpsL_def using assms by simp
+
+lemma execute_cmdL2_Suc_TT:
+  assumes "xs = replicate k (0, Some 0)" and "tps = tpsL t xs 0 q mvs (\<lambda>j. 0)" and "t < TT"
+  shows "execute tmL1_2 (0, tps) (Suc TT) = (1, tpsL t xs TT q mvs (\<lambda>j. exec t <.> j))"
+proof -
+  have "execute tmL1_2 (0, tps) (Suc TT) = exe tmL1_2 (execute tmL1_2 (0, tps) TT)"
+    by simp
+  also have "... = exe tmL1_2 (0, tpsL t xs TT q mvs (\<lambda>j. if exec t <#> j < TT then exec t <.> j else \<box>))"
+    using execute_cmdL2_le_TT[where ?tt=TT] assms(1,2) by simp
+  also have "... = sem cmdL2 (0, tpsL t xs TT q mvs (\<lambda>j. if exec t <#> j < TT then exec t <.> j else \<box>))"
+    unfolding tmL1_2_def by (simp add: exe_lt_length)
+  also have "... = (1, tpsL t xs TT q mvs (\<lambda>j. if exec t <#> j < TT then exec t <.> j else \<box>))"
+    using sem_cmdL2_ge_TT[where ?i=TT] by simp
+  finally have "execute tmL1_2 (0, tps) (Suc TT) =
+    (1, tpsL t xs TT q mvs (\<lambda>j. if exec t <#> j < TT then exec t <.> j else \<box>))" .
+  moreover have "(\<lambda>j. if exec t <#> j < TT then exec t <.> j else \<box>) j = (\<lambda>j. exec t <.> j) j"
+      if "j < k" for j
+    using exec_pos_less_TT assms(3) that by simp
+  ultimately show ?thesis
+    using tpsL_symbs_eq by fastforce
+qed
+
+definition "esL1_2 \<equiv> map (\<lambda>i. (n + 1, Suc i)) [0..<TT] @ [(n + 1, TT)]"
+
+lemma traces_tmL1_2:
+  assumes "xs = replicate k (0, Some 0)" and "t < TT"
+  shows "traces tmL1_2 (tpsL t xs 0 q mvs (\<lambda>_. \<box>)) esL1_2 (tpsL t xs TT q mvs (\<lambda>j. exec t <.> j))"
+proof
+  have len: "length esL1_2 = Suc TT"
+    unfolding esL1_2_def by simp
+  let ?tps = "tpsL t xs 0 q mvs (\<lambda>j. 0)"
+  show "execute tmL1_2 (0, ?tps) (length esL1_2) =
+      (length tmL1_2, tpsL t xs (Suc (fmt n)) q mvs (\<lambda>j. exec t <.> j))"
+    using len execute_cmdL2_Suc_TT[OF assms(1) _ assms(2)] by (simp add: tmL1_2_def)
+  show "\<And>i. i < length esL1_2 \<Longrightarrow>
+        fst (execute tmL1_2 (0, ?tps) i) < length tmL1_2"
+    using len tmL1_2_def execute_cmdL2_le_TT assms(1)
+    by (metis (no_types, lifting) One_nat_def Pair_inject length_Cons less_Suc_eq_le
+     less_one list.size(3) prod.collapse)
+  show "snd (execute tmL1_2 (0, ?tps) (Suc i)) :#: 0 = fst (esL1_2 ! i) \<and>
+        snd (execute tmL1_2 (0, ?tps) (Suc i)) :#: 1 = snd (esL1_2 ! i)"
+    if "i < length esL1_2" for i
+  proof (cases "i < TT")
+    case True
+    then have "execute tmL1_2 (0, ?tps) (Suc i) =
+        (0, tpsL t xs (Suc i) q mvs (\<lambda>j. if exec t <#> j < Suc i then exec t <.> j else \<box>))"
+      using execute_cmdL2_le_TT[of "Suc i" xs] assms by simp
+    then have "snd (execute tmL1_2 (0, ?tps) (Suc i)) =
+        tpsL t xs (Suc i) q mvs (\<lambda>j. if exec t <#> j < Suc i then exec t <.> j else \<box>)"
+      by simp
+    moreover have "esL1_2 ! i = (n + 1, Suc i)"
+      unfolding esL1_2_def
+      using True nth_append
+      by (metis (no_types, lifting) One_nat_def Suc_eq_plus1 add.commute add_Suc diff_zero
+        length_map length_upt nth_map_upt)
+    ultimately show ?thesis
+      using tpsL_pos_0 tpsL_pos_1 by simp
+  next
+    case False
+    then have "i = TT"
+      using len that by simp
+    then have "execute tmL1_2 (0, ?tps) (Suc i) = (1, tpsL t xs TT q mvs (\<lambda>j. exec t <.> j))"
+      using execute_cmdL2_Suc_TT assms by simp
+    moreover have "esL1_2 ! i = (n + 1, TT)"
+      using `i = TT` esL1_2_def by (metis (no_types, lifting) diff_zero length_map length_upt nth_append_length)
+    ultimately show ?thesis
+      using tpsL_pos_0 tpsL_pos_1 by auto
+  qed
+qed
+
+definition "esL2 t \<equiv> esL1 t @ esL1_2"
+
+definition "tpsL2 t \<equiv> tpsL t (replicate k (0, Some 0)) TT 0 (\<lambda>_. \<box>) (\<lambda>j. exec t <.> j)"
+
+lemma tmL2:
+  assumes "t < TT"
+  shows "traces tmL2 (tpsL0 t) (esL2 t) (tpsL2 t)"
+  unfolding tmL2_def esL2_def
+proof (rule traces_sequential[OF tmL1])
+  show "traces tmL1_2 (tpsL1 t) esL1_2 (tpsL2 t)"
+    using traces_tmL1_2[OF _ assms] by (simp add: tpsL1_def tpsL2_def)
+qed
+
+definition "sim_nextstate t \<equiv>
+  (if fst (exec t) < length M
+   then fst ((M ! (fst (exec t))) (config_read (exec t)))
+   else fst (exec t))"
+
+lemma sim_nextstate: "fst (exec (Suc t)) = sim_nextstate t"
+proof (cases "fst (exec t) < length M")
+  case True
+  let ?cfg = "exec t"
+  let ?rs = "config_read ?cfg"
+  let ?cmd = "M ! (fst ?cfg)"
+  have "exec (Suc t) = sem ?cmd ?cfg"
+    using exec_def True by (simp add: exe_lt_length)
+  then have 2: "fst (exec (Suc t)) = fst (sem ?cmd ?cfg)"
+    by simp
+  also have "... = fst (?cmd ?rs)"
+    using sem' by simp
+  also have "... = sim_nextstate t"
+    using sim_nextstate_def True by simp
+  finally show ?thesis .
+next
+  case False
+  then show ?thesis
+    using exec_def exe_def sim_nextstate_def by simp
+qed
+
+definition "sim_write t \<equiv>
+  (if fst (exec t) < length M
+   then map fst (snd ((M ! (fst (exec t))) (config_read (exec t))))
+   else config_read (exec t))"
+
+lemma sim_write_nth:
+  assumes "fst (exec t) < length M" and "j < k"
+  shows "sim_write t ! j = ((M ! (fst (exec t))) (config_read (exec t)) [.] j)"
+proof -
+  have "length (snd ((M ! (fst (exec t))) (config_read (exec t)))) = k"
+    using assms turing_commandD(1) exec_def execute_num_tapes read_length start_config_length tm_M turing_machine_def
+    by (metis add_gr_0 less_imp_add_positive nth_mem)
+  then show ?thesis
+    using sim_write_def assms by simp
+qed
+
+lemma sim_write_nth_else:
+  assumes "\<not> (fst (exec t) < length M)"
+  shows "sim_write t ! j = config_read (exec t) ! j"
+  by (simp add: assms sim_write_def)
+
+lemma sim_write_nth_less_G:
+  assumes "j < k"
+  shows "sim_write t ! j < G"
+proof (cases "fst (exec t) < length M")
+  case True
+  then have *: "sim_write t ! j = (M ! (fst (exec t))) (config_read (exec t)) [.] j"
+    using sim_write_nth assms by simp
+  have "turing_command k (length M) G (M ! (fst (exec t)))"
+    using tm_M True turing_machineD(3) by simp
+  moreover have "\<forall>i<k. (config_read (exec t)) ! i < G"
+    using read_alphabet exec_def tm_M by (simp add: zs_less_G)
+  moreover have "length (config_read (exec t)) = k"
+    by (metis Suc_1 exec_def execute_num_tapes start_config_length less_le_trans read_length
+      turing_machine_def tm_M zero_less_Suc)
+  ultimately have "(M ! (fst (exec t))) (config_read (exec t)) [.] j < G"
+    using assms exec_def turing_commandD(2) by simp
+  then show ?thesis
+    using * by simp
+next
+  case False
+  then show ?thesis
+    using exec_def sim_write_nth_else assms tape_alphabet
+    by (simp add: read_alphabet tm_M zs_less_G)
+qed
+
+lemma sim_write:
+  assumes "j < k"
+  shows "exec (Suc t) <:> j = (exec t <:> j)(exec t <#> j := sim_write t ! j)"
+proof (cases "fst (exec t) < length M")
+  case True
+  let ?cfg = "exec t"
+  let ?rs = "config_read ?cfg"
+  let ?cmd = "M ! (fst ?cfg)"
+  have len_rs: "length ?rs = k"
+    using assms exec_def execute_num_tapes start_config_length read_length tm_M by simp
+  have "turing_command k (length M) G ?cmd"
+    using True tm_M turing_machineD(3) by simp
+  then have len: "length (snd (?cmd ?rs)) = k"
+    using len_rs turing_commandD(1) by simp
+
+  have "sim_write t = map fst (snd (?cmd ?rs))"
+    using sim_write_def True by simp
+  then have 1: "sim_write t ! j = ?cmd ?rs [.] j"
+    by (simp add: assms len)
+
+  have 2: "exec (Suc t) = sem ?cmd ?cfg"
+    using exec_def True by (simp add: exe_lt_length)
+
+  have "snd (sem ?cmd ?cfg) = map (\<lambda>(a, tp). act a tp) (zip (snd (?cmd ?rs)) (snd ?cfg))"
+    using sem' by simp
+  then have "snd (sem ?cmd ?cfg) ! j = (\<lambda>(a, tp). act a tp) ((snd (?cmd ?rs) ! j), (snd ?cfg ! j))"
+    using len assms len_rs read_length by simp
+  then have "sem ?cmd ?cfg <!> j = act (snd (?cmd ?rs) ! j) (?cfg <!> j)"
+    by simp
+  then have "sem ?cmd ?cfg <:> j = fst (act (snd (?cmd ?rs) ! j) (?cfg <!> j))"
+    by simp
+  then have "sem ?cmd ?cfg <:> j = (?cfg <:> j)(?cfg <#> j := fst (snd (?cmd ?rs) ! j))"
+    using act by simp
+  then have "sem ?cmd ?cfg <:> j = (?cfg <:> j)(?cfg <#> j := ?cmd ?rs [.] j)" .
+  then show ?thesis
+    using 1 2 by simp
+next
+  case False
+  let ?cfg = "exec t"
+  let ?rs = "config_read ?cfg"
+  have len_rs: "length ?rs = k"
+    using assms exec_def execute_num_tapes start_config_length read_length tm_M by simp
+  then have 1: "sim_write t ! j = ?rs ! j"
+    using False by (simp add: sim_write_def)
+
+  have 2: "?rs ! j = exec t <.> j"
+    using assms len_rs read_abbrev read_length by auto
+
+  have "exec (Suc t) = exec t"
+    using exec_def exe_def False by simp
+  then have "exec (Suc t) <:> j = exec t <:> j"
+    by simp
+
+  then show ?thesis
+    using 1 2 by simp
+qed
+
+corollary sim_write':
+  assumes "j < k"
+  shows "(exec (Suc t) <:> j) (exec t <#> j) = sim_write t ! j"
+  using assms sim_write by simp
+
+definition "sim_move t \<equiv> map direction_to_symbol
+  (if fst (exec t) < length M
+   then map snd (snd ((M ! (fst (exec t))) (config_read (exec t))))
+   else replicate k Stay)"
+
+lemma sim_move_nth:
+  assumes "fst (exec t) < length M" and "j < k"
+  shows "sim_move t ! j = direction_to_symbol ((M ! (fst (exec t))) (config_read (exec t)) [~] j)"
+proof -
+  have "k = ||execute M (start_config k zs) t||"
+    by (metis (no_types) Suc_1 execute_num_tapes start_config_length less_le_trans tm_M turing_machine_def zero_less_Suc)
+  then show ?thesis
+    by (smt (verit, best) turing_commandD(1) assms(1,2) exec_def length_map nth_map read_length sim_move_def tm_M turing_machineD(3))
+qed
+
+lemma sim_move_nth_else:
+  assumes "\<not> (fst (exec t) < length M)" and "j < k"
+  shows "sim_move t ! j = 1"
+  using assms sim_move_def direction_to_symbol_def by simp
+
+lemma sim_move:
+  assumes "j < k"
+  shows "exec (Suc t) <#> j = exec t <#> j + sim_move t ! j - 1"
+proof (cases "fst (exec t) < length M")
+  case True
+  let ?cfg = "exec t"
+  let ?rs = "config_read ?cfg"
+  let ?cmd = "M ! (fst ?cfg)"
+  have len_rs: "length ?rs = k"
+    using assms exec_def execute_num_tapes start_config_length read_length tm_M by simp
+  have "turing_command k (length M) G ?cmd"
+    using True tm_M turing_machineD(3) by simp
+  then have len: "length (snd (?cmd ?rs)) = k"
+    using len_rs turing_commandD(1) by simp
+
+  have 1: "sim_move t ! j = direction_to_symbol (?cmd ?rs [~] j)"
+    using assms sim_move_nth True by simp
+
+  have "exec (Suc t) = sem ?cmd ?cfg"
+    using exec_def True by (simp add: exe_lt_length)
+  then have 2: "exec (Suc t) <#> j = sem ?cmd ?cfg <#> j"
+    by simp
+
+  have "snd (sem ?cmd ?cfg) = map (\<lambda>(a, tp). act a tp) (zip (snd (?cmd ?rs)) (snd ?cfg))"
+    using sem' by simp
+  then have "snd (sem ?cmd ?cfg) ! j = (\<lambda>(a, tp). act a tp) ((snd (?cmd ?rs) ! j), (snd ?cfg ! j))"
+    using len assms len_rs read_length by simp
+  then have "sem ?cmd ?cfg <!> j = act (snd (?cmd ?rs) ! j) (?cfg <!> j)"
+    by simp
+  then have "sem ?cmd ?cfg <#> j = snd (act (snd (?cmd ?rs) ! j) (?cfg <!> j))"
+    by simp
+  then have "sem ?cmd ?cfg <#> j =
+     (case ?cmd ?rs [~] j of Left \<Rightarrow> ?cfg <#> j - 1 | Stay \<Rightarrow> ?cfg <#> j | Right \<Rightarrow> ?cfg <#> j + 1)"
+    using act by simp
+  then show ?thesis
+    using 1 2 direction_to_symbol_def by (cases "?cmd ?rs [~] j") simp_all
+next
+  case False
+  then have "exec (Suc t) <#> j = exec t <#> j"
+    using exec_def exe_def by simp
+  moreover have "sim_move t ! j = 1"
+    using direction_to_symbol_def sim_move_def assms False by simp
+  ultimately show ?thesis
+    by simp
+qed
+
+definition "tpsL3 t \<equiv> tpsL
+  t
+  (replicate k (0, Some 0))
+  TT
+  1
+  (\<lambda>j. sim_move t ! j)
+  (\<lambda>j. sim_write t ! j)"
+
+lemma read_execute: "config_read (exec t) = map (\<lambda>j. (exec t) <.> j) [0..<k]"
+  (is "?lhs = ?rhs")
+proof (rule nth_equalityI)
+  have len: "length ?lhs = k"
+    by (metis Suc_1 exec_def execute_num_tapes start_config_length less_le_trans read_length
+      tm_M turing_machine_def zero_less_Suc)
+  then show "length ?lhs = length ?rhs"
+    by simp
+  show "?lhs ! i = ?rhs ! i" if "i < length ?lhs" for i
+    using len read_abbrev read_length that by auto
+qed
+
+lemma sem_cmdL3: "sem cmdL3 (0, tpsL2 t) = (1, tpsL3 t)"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) cmdL3"
+    using cmdL3_def by simp
+  show len: "length (tpsL2 t) = 2 * k + 3"
+    using tpsL2_def by simp
+  show "length (tpsL3 t) = 2 * k + 3"
+    using tpsL3_def by simp
+  show "fst (cmdL3 (read (tpsL2 t))) = 1"
+    by (simp add: cmdL3_def)
+  show "act (cmdL3 (read (tpsL2 t)) [!] j) (tpsL2 t ! j) = tpsL3 t ! j" if "j < 2 * k + 3" for j
+  proof -
+    define rs where "rs = read (tpsL2 t)"
+    then have rs2: "rs ! 2 = fst (exec t)"
+      using tpsL2_def read_tpsL_2 by simp
+    have "drop (k + 3) rs = map (\<lambda>j. exec t <.> j) [0..<k]" (is "?lhs = ?rhs")
+    proof (rule nth_equalityI)
+      show "length ?lhs = length ?rhs"
+        using rs_def read_length tpsL2_def by simp
+      then have len_lhs: "length ?lhs = k"
+        by simp
+      show "?lhs ! i = ?rhs ! i" if "i < length ?lhs" for i
+      proof -
+        have "i < k"
+          using that len_lhs by simp
+        have "length rs = 2 * k + 3"
+          using rs_def read_length tpsL2_def by simp
+        then have "?lhs ! i = rs ! (i + k + 3)"
+          by (simp add: add.assoc add.commute)
+        also have "... = exec t <.> i"
+          unfolding rs_def tpsL2_def using read_tpsL_4[of "i + k + 3"] `i < k` by simp
+        finally show ?thesis
+          using `i < k` by simp
+      qed
+    qed
+    then have drop: "drop (k + 3) rs = config_read (exec t)"
+      using read_execute by simp
+    then have drop_less_G: "\<forall>h\<in>set (drop (k + 3) rs). h < G"
+      using exec_def tm_M read_alphabet_set zs_less_G by presburger
+
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using \<open>j < 2 * k + 3\<close> by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "cmdL3 rs [!] j = (rs ! 0, Stay)"
+        using cmdL3_def by simp
+      moreover have "tpsL2 t ! j = (\<lfloor>zs\<rfloor>, n + 1)"
+        using tpsL2_def 1 by (simp add: tpsL_0)
+      moreover have "tpsL3 t ! j = (\<lfloor>zs\<rfloor>, n + 1)"
+        using tpsL3_def 1 by (simp add: tpsL_0)
+      ultimately show ?thesis
+        using act_Stay by (metis 1 len rs_def that)
+    next
+      case 2
+      then have "cmdL3 rs [!] j = (rs ! 1, Stay)"
+        using cmdL3_def by simp
+      moreover have "tpsL2 t ! j = (zip_cont t (replicate k (0, Some 0)), TT)"
+        using tpsL2_def 2 tpsL_1 by simp
+      moreover have "tpsL3 t ! j = (zip_cont t (replicate k (0, Some 0)), TT)"
+        using tpsL3_def 2 tpsL_1 by simp
+      ultimately show ?thesis
+        using act_Stay by (metis 2 len rs_def that)
+    next
+      case 3
+      show ?thesis
+      proof (cases "rs ! 2 < length M")
+        case True
+        then have "cmdL3 rs [!] j = (fst ((M ! (rs ! 2)) (drop (k + 3) rs)), Stay)"
+          using 3 drop_less_G cmdL3_at_2a by simp
+        also have "... = (fst ((M ! (rs ! 2)) (config_read (exec t))), Stay)"
+          using drop by simp
+        also have "... = (fst (exec (Suc t)), Stay)"
+          using True rs2 sim_nextstate sim_nextstate_def by auto
+        finally have "cmdL3 rs [!] j = (fst (exec (Suc t)), Stay)" .
+        then show ?thesis
+          using tpsL2_def tpsL3_def tpsL_def 3 act_onesie rs_def by simp
+      next
+        case False
+        then have "cmdL3 rs [!] j = (rs ! 2, Stay)"
+          using 3 cmdL3_at_2b by simp
+        moreover have "fst (exec (Suc t)) = rs ! 2"
+          using False rs2 sim_nextstate sim_nextstate_def by auto
+        ultimately have "cmdL3 rs [!] j = (fst (exec (Suc t)), Stay)"
+          by simp
+        then show ?thesis
+          using tpsL2_def tpsL3_def tpsL_def 3 act_onesie rs_def by simp
+      qed
+    next
+      case 4
+      then have 1: "j - 3 < k"
+        by auto
+      have 2: "tpsL2 t ! j = \<lceil>\<box>\<rceil>"
+        using tpsL2_def tpsL_mvs' 4 by simp
+      have 3: "tpsL3 t ! j = \<lceil>sim_move t ! (j - 3)\<rceil>"
+        using tpsL3_def tpsL_mvs' 4 by simp
+      show ?thesis
+      proof (cases "rs ! 2 < length M")
+        case True
+        then have "cmdL3 rs [!] j = (direction_to_symbol ((M ! (rs ! 2)) (drop (k + 3) rs) [~] (j - 3)), Stay)"
+          using cmdL3_at_3a 4 drop_less_G by simp
+        also have "... = (direction_to_symbol ((M ! (fst (exec t))) (config_read (exec t)) [~] (j - 3)), Stay)"
+          using drop True rs2 by simp
+        also have "... = (sim_move t ! (j - 3), Stay)"
+          using sim_move_nth True 1 rs2 by simp
+        finally have "cmdL3 rs [!] j = (sim_move t ! (j - 3), Stay)" .
+        then show ?thesis
+          using 2 3 act_onesie by (simp add: rs_def)
+      next
+        case False
+        then have "cmdL3 rs [!] j = (1, Stay)"
+          using cmdL3_at_3b 4 by simp
+        then have "cmdL3 rs [!] j = (sim_move t ! (j - 3), Stay)"
+          using sim_move_nth_else False 1 rs2 by simp
+        then show ?thesis
+          using 2 3 act_onesie by (simp add: rs_def)
+      qed
+    next
+      case 5
+      then have 1: "j - k - 3 < k"
+        by auto
+      have 2: "tpsL2 t ! j = \<lceil>exec t <.> (j - k - 3)\<rceil>"
+        using tpsL2_def tpsL_symbs' 5 by simp
+      have 3: "tpsL3 t ! j = \<lceil>sim_write t ! (j - k - 3)\<rceil>"
+        using tpsL3_def tpsL_symbs' 5 by simp
+      show ?thesis
+      proof (cases "rs ! 2 < length M")
+        case True
+        then have "cmdL3 rs [!] j = ((M ! (rs ! 2)) (drop (k + 3) rs) [.] (j - k - 3), Stay)"
+          using 5 cmdL3_at_4a drop_less_G by simp
+        also have "... = ((M ! (fst (exec t))) (config_read (exec t)) [.] (j - k - 3), Stay)"
+          using drop True rs2 by simp
+        also have "... = (sim_write t ! (j - k - 3), Stay)"
+          using sim_write_nth 5 rs2 True by auto
+        finally have "cmdL3 rs [!] j = (sim_write t ! (j - k - 3), Stay)" .
+        then show ?thesis
+          using 2 3 act_onesie rs_def by simp
+      next
+        case False
+        then have "cmdL3 rs [!] j = (rs ! j, Stay)"
+          using 5 cmdL3_at_4b by simp
+        also have "... = (exec t <.> (j - k - 3), Stay)"
+          using tpsL2_def read_tpsL_4 5 rs_def by simp
+        also have "... = (config_read (exec t) ! (j - k - 3), Stay)"
+        proof -
+          have "length [k..<j] - 3 < k"
+            by (metis "1" length_upt)
+          then show ?thesis
+            using \<open>drop (k + 3) rs = map (\<lambda>j. exec t <.> j) [0..<k]\<close> drop by auto
+        qed
+        also have "... = (sim_write t ! (j - k - 3), Stay)"
+          using sim_write_nth_else False rs2 by simp
+        finally have "cmdL3 rs [!] j = (sim_write t ! (j - k - 3), Stay)" .
+        then show ?thesis
+          using 2 3 act_onesie rs_def by simp
+      qed
+    qed
+  qed
+qed
+
+lemma execute_tmL2_3: "execute tmL2_3 (0, tpsL2 t) 1 = (1, tpsL3 t)"
+proof -
+  have "execute tmL2_3 (0, tpsL2 t) 1 = exe tmL2_3 (execute tmL2_3 (0, tpsL2 t) 0)"
+    by simp
+  also have "... = exe tmL2_3 (0, tpsL2 t)"
+    by simp
+  also have "... = sem cmdL3 (0, tpsL2 t)"
+    using tmL2_3_def by (simp add: exe_lt_length)
+  finally show ?thesis
+    using sem_cmdL3 by simp
+qed
+
+definition "esL3 t \<equiv> esL2 t @ [(n + 1, TT)]"
+
+lemma tmL3:
+  assumes "t < TT"
+  shows "traces tmL3 (tpsL0 t) (esL3 t) (tpsL3 t)"
+  unfolding tmL3_def esL3_def
+proof (rule traces_sequential[OF tmL2[OF assms]])
+  show "traces tmL2_3 (tpsL2 t) [(n + 1, Suc (fmt n))] (tpsL3 t)"
+  proof
+    let ?es = "[(n + 1, TT)]"
+    show "execute tmL2_3 (0, tpsL2 t) (length ?es) = (length tmL2_3, tpsL3 t)"
+      using tmL2_3_def execute_tmL2_3 by simp
+    show "\<And>i. i < length ?es \<Longrightarrow> fst (execute tmL2_3 (0, tpsL2 t) i) < length tmL2_3"
+      using tmL2_3_def execute_tmL2_3 by simp
+    show "(execute tmL2_3 (0, tpsL2 t) (Suc i)) <#> 0 = fst (?es ! i) \<and>
+          (execute tmL2_3 (0, tpsL2 t) (Suc i)) <#> 1 = snd (?es ! i)"
+        if "i < length ?es" for i
+      using execute_tmL2_3 that tpsL3_def tpsL_pos_0 tpsL_pos_1
+      by (metis One_nat_def fst_conv length_Cons less_one list.size(3) nth_Cons_0 snd_conv)
+  qed
+qed
+
+definition "esL4 t \<equiv> esL3 t @ map (\<lambda>i. (n + 1, i)) (rev [0..<TT]) @ [(n + 1, 0)]"
+
+lemma len_esL4: "length (esL4 t) = t + 2 * TT + 4"
+  using esL4_def esL3_def esL2_def esL1_def esL1_2_def by simp
+
+definition "tpsL4 t \<equiv> tpsL
+  t
+  (replicate k (0, Some 0))
+  0
+  1
+  (\<lambda>j. sim_move t ! j)
+  (\<lambda>j. sim_write t ! j)"
+
+lemma tmL4:
+  assumes "t < TT"
+  shows "traces tmL4 (tpsL0 t) (esL4 t) (tpsL4 t)"
+  unfolding tmL4_def esL4_def
+proof (rule traces_sequential[where ?tps2.0="tpsL3 t"])
+  show "traces tmL3 (tpsL0 t) (esL3 t) (tpsL3 t)" using tmL3 assms .
+  show "traces tm_left_until1 (tpsL3 t) (map (Pair (n + 1)) (rev [0..<TT]) @ [(n + 1, 0)]) (tpsL4 t)"
+  proof (rule traces_tm_left_until_1I)
+    show "1 < length (tpsL3 t)"
+      using tpsL3_def by simp
+    show "begin_tape {y. y < G ^ (2 * k + 2) + 2 \<and> 1 < y \<and> dec y ! (2 * k + 1) = 1} (tpsL3 t ! 1)"
+      using begin_tape_zip_cont tpsL3_def tpsL_def by simp
+    show "map (Pair (n + 1)) (rev [0..<TT]) @ [(n + 1, 0)] =
+        map (Pair (tpsL3 t :#: 0)) (rev [0..<tpsL3 t :#: 1]) @ [(tpsL3 t :#: 0, 0)]"
+      using tpsL3_def tpsL_def by simp
+    show "tpsL4 t = (tpsL3 t)[1 := tpsL3 t ! 1 |#=| 0]"
+      using tpsL3_def tpsL4_def tpsL_def by simp
+  qed
+qed
+
+lemma enc_upd_zip_cont_None_Some:
+  assumes "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (1, None)"
+    and "i = (exec (Suc t) <#> jj)"
+  shows "enc_upd (zip_cont t xs i) (k + jj) 1 = zip_cont t (xs[jj:=(1, Some 1)]) i"
+proof -
+  have "i < TT"
+    using assms(1,4) exec_pos_less_TT by metis
+
+  let ?n = "zip_cont t xs i"
+  let ?xs = "xs[jj:=(1, Some 1)]"
+  have "zip_cont t ?xs i = enc
+     (map (\<lambda>j. (exec (t + fst (?xs ! j)) <:> j) i) [0..<k] @
+      map (\<lambda>j. case snd (?xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [if i < t then 1 else 0,
+       if i = 0 then 1 else 0])"
+       (is "_ = enc ?ys")
+    using zip_cont_def `i < TT` by simp
+  moreover have "?ys = (dec ?n) [k+jj:=1]"
+  proof (rule nth_equalityI)
+    show len: "length ?ys = length ((dec ?n) [k+jj:=1])"
+      by (simp add: \<open>i < TT\<close> dec_zip_cont)
+    have lenys: "length ?ys = 2 * k + 2"
+      by simp
+    show "?ys ! j = (dec ?n) [k+jj:=1] ! j" if "j < length ?ys" for j
+    proof -
+      consider "j < k" | "k \<le> j \<and> j < 2 * k" | "j = 2 * k" | "j = 2 * k + 1"
+        using lenys `j < length ?ys` by linarith
+      then show ?thesis
+      proof (cases)
+        case 1
+        then have "?ys ! j = (exec (t + fst (?xs ! j)) <:> j) i"
+          using assms(2) by (simp add: less_k_nth)
+        have "(dec ?n) [k+jj:=1] ! j = dec ?n ! j"
+          using 1 by simp
+        also have "... = (exec (t + fst (xs ! j)) <:> j) i"
+          by (simp add: "1" \<open>i < TT\<close> dec_zip_cont_less_k)
+        also have "... = (exec (t + fst (?xs ! j)) <:> j) i"
+          using assms(1-3) by (metis fst_eqD nth_list_update)
+        also have "... = ?ys ! j"
+          using assms(2) 1 by (simp add: less_k_nth)
+        finally show ?thesis
+          by simp
+      next
+        case 2
+        show ?thesis
+        proof (cases "j = k + jj")
+          case True
+          then have "?ys ! j = (case snd (?xs ! jj) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> jj then 1 else 0)"
+            using assms(2) 2 by (simp add: less_2k_nth)
+          also have "... = (if i = exec (t + 1) <#> jj then 1 else 0)"
+            by (simp add: assms(1) assms(2))
+          also have "... = 1"
+            using assms(1,4) by simp
+          finally have "?ys ! j = 1" .
+          moreover have "(dec ?n) [k+jj:=1] ! j = 1"
+            using True len that by simp
+          ultimately show ?thesis
+            by simp
+        next
+          case False
+          then have *: "?xs ! (j - k) = xs ! (j - k)"
+            by (metis "2" add_diff_inverse_nat le_imp_less_Suc not_less_eq nth_list_update_neq)
+          have "?ys ! j =
+              (case snd (?xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+            using assms(2) 2 by (simp add: less_2k_nth)
+          have "(dec ?n) [k+jj:=1] ! j = (dec ?n) ! j"
+            using 2 False by simp
+          also have "... =
+              (case snd (xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+            using 2 `i < TT` dec_zip_cont_less_2k by simp
+          also have "... = (case snd (?xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+            using * by simp
+          also have "... = ?ys ! j"
+            using assms(2) 2 by (simp add: less_2k_nth)
+          finally show ?thesis
+            by simp
+        qed
+      next
+        case 3
+        then have "?ys ! j = (if i < t then 1 else 0)"
+          by (simp add: twok_nth)
+        moreover have "(dec ?n) [k+jj:=1] ! j = (if i < t then 1 else 0)"
+            using 3 assms(1) dec_zip_cont_2k `i < TT` by simp
+        ultimately show ?thesis
+          by simp
+      next
+        case 4
+        then have "?ys ! j = (if i = 0 then 1 else 0)"
+          using twok1_nth by fast
+        moreover have "(dec ?n) [k+jj:=1] ! j = (if i = 0 then 1 else 0)"
+            using 4 assms(1) dec_zip_cont_2k1 `i < TT` by simp
+        ultimately show ?thesis
+          by simp
+      qed
+    qed
+  qed
+  ultimately show ?thesis
+    using enc_upd_def by simp
+qed
+
+lemma enc_upd_zip_cont_None_Some_Right:
+  assumes "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (1, None)"
+    and "i = Suc (exec t <#> jj)"
+    and "sim_move t ! jj = 2"
+  shows "enc_upd (zip_cont t xs i) (k + jj) 1 = zip_cont t (xs[jj:=(1, Some 1)]) i"
+proof -
+  have "i = (exec (Suc t) <#> jj)"
+    using assms sim_move by simp
+  then show ?thesis
+    using enc_upd_zip_cont_None_Some[OF assms(1-3)] by simp
+qed
+
+lemma enc_upd_zip_cont_None_Some_Left:
+  assumes "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (1, None)"
+    and "Suc i = exec t <#> jj"
+    and "sim_move t ! jj = 0"
+  shows "enc_upd (zip_cont t xs i) (k + jj) 1 = zip_cont t (xs[jj:=(1, Some 1)]) i"
+proof -
+  have "i = (exec (Suc t) <#> jj)"
+    using assms sim_move by simp
+  then show ?thesis
+    using enc_upd_zip_cont_None_Some[OF assms(1-3)] by simp
+qed
+
+lemma enc_upd_zip_cont_Some_None:
+  assumes "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "i = exec t <#> jj"
+  shows "enc_upd (zip_cont t xs i) (k + jj) 0 = zip_cont t (xs[jj:=(1, None)]) i"
+proof -
+  have "i < TT"
+    using assms(1,4) by (simp add: exec_pos_less_TT)
+  let ?n = "zip_cont t xs i"
+  let ?xs = "xs[jj:=(1, None)]"
+  have "zip_cont t ?xs i = enc
+     (map (\<lambda>j. (exec (t + fst (?xs ! j)) <:> j) i) [0..<k] @
+      map (\<lambda>j. case snd (?xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [if i < t then 1 else 0,
+       if i = 0 then 1 else 0])"
+       (is "_ = enc ?ys")
+    using zip_cont_def `i < TT` by simp
+  moreover have "?ys = (dec ?n) [k+jj:=0]"
+  proof (rule nth_equalityI)
+    show len: "length ?ys = length ((dec ?n) [k+jj:=0])"
+      by (simp add: \<open>i < TT\<close> dec_zip_cont)
+    have lenys: "length ?ys = 2 * k + 2"
+      by simp
+    show "?ys ! j = (dec ?n) [k+jj:=0] ! j" if "j < length ?ys" for j
+    proof -
+      consider "j < k" | "k \<le> j \<and> j < 2 * k" | "j = 2 * k" | "j = 2 * k + 1"
+        using lenys `j < length ?ys` by linarith
+      then show ?thesis
+      proof (cases)
+        case 1
+        then have "?ys ! j = (exec (t + fst (?xs ! j)) <:> j) i"
+          using assms(2) by (simp add: less_k_nth)
+        have "(dec ?n) [k+jj:=0] ! j = dec ?n ! j"
+          using 1 by simp
+        also have "... = (exec (t + fst (xs ! j)) <:> j) i"
+          by (simp add: "1" \<open>i < TT\<close> dec_zip_cont_less_k)
+        also have "... = (exec (t + fst (?xs ! j)) <:> j) i"
+          using assms(1-3) by (metis fst_eqD nth_list_update)
+        also have "... = ?ys ! j"
+          using assms(2) 1 by (simp add: less_k_nth)
+        finally show ?thesis
+          by simp
+      next
+        case 2
+        show ?thesis
+        proof (cases "j = k + jj")
+          case True
+          then have "?ys ! j = (case snd (?xs ! jj) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> jj then 1 else 0)"
+            using assms(2) 2 by (simp add: less_2k_nth)
+          then have "?ys ! j = 0"
+            using assms(1,2) by simp
+          moreover have "(dec ?n) [k+jj:=0] ! j = 0"
+            using True len that by simp
+          ultimately show ?thesis
+            by simp
+        next
+          case False
+          then have *: "?xs ! (j - k) = xs ! (j - k)"
+            by (metis "2" add_diff_inverse_nat le_imp_less_Suc not_less_eq nth_list_update_neq)
+          have "?ys ! j =
+              (case snd (?xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+            using assms(2) 2 by (simp add: less_2k_nth)
+          have "(dec ?n) [k+jj:=0] ! j = (dec ?n) ! j"
+            using 2 False by simp
+          also have "... =
+              (case snd (xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+            using 2 `i < TT` dec_zip_cont_less_2k by simp
+          also have "... = (case snd (?xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+            using * by simp
+          also have "... = ?ys ! j"
+            using assms(2) 2 by (simp add: less_2k_nth)
+          finally show ?thesis
+            by simp
+        qed
+      next
+        case 3
+        then have "?ys ! j = (if i < t then 1 else 0)"
+          by (simp add: twok_nth)
+        moreover have "(dec ?n) [k+jj:=0] ! j = (if i < t then 1 else 0)"
+            using 3 assms(1) dec_zip_cont_2k `i < TT` by simp
+        ultimately show ?thesis
+          by simp
+      next
+        case 4
+        then have "?ys ! j = (if i = 0 then 1 else 0)"
+          using twok1_nth by fast
+        moreover have "(dec ?n) [k+jj:=0] ! j = (if i = 0 then 1 else 0)"
+            using 4 assms(1) dec_zip_cont_2k1 `i < TT` by simp
+        ultimately show ?thesis
+          by simp
+      qed
+    qed
+  qed
+  ultimately show ?thesis
+    using enc_upd_def by simp
+qed
+
+lemma zip_cont_nth_eq_updI1:
+  assumes "i < TT"
+    and "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (0, Some 0)"
+    and "(exec (Suc t) <:> jj) i = u"
+  shows "enc_upd (zip_cont t xs i) jj u = zip_cont t (xs[jj:=(1, Some 0)]) i"
+proof -
+  let ?n = "zip_cont t xs i"
+  let ?xs = "xs[jj:=(1, Some 0)]"
+  have "zip_cont t ?xs i = enc
+     (map (\<lambda>j. (exec (t + fst (?xs ! j)) <:> j) i) [0..<k] @
+      map (\<lambda>j. case snd (?xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [if i < t then 1 else 0,
+       if i = 0 then 1 else 0])"
+       (is "_ = enc ?ys")
+    using zip_cont_def assms(1) by simp
+  moreover have "?ys = (dec ?n) [jj:=u]"
+  proof (rule nth_equalityI)
+    show len_eq: "length ?ys = length ((dec ?n) [jj:=u])"
+      using assms(1) dec_zip_cont two_tape_axioms zs_proper zs_less_G by simp
+    have lenys: "length ?ys = 2 * k + 2"
+      by simp
+    show "?ys ! j = (dec ?n) [jj:=u] ! j" if "j < length ?ys" for j
+    proof -
+      consider "j < k" | "k \<le> j \<and> j < 2 * k" | "j = 2 * k" | "j = 2 * k + 1"
+        using lenys `j < length ?ys` by linarith
+      then show ?thesis
+      proof (cases)
+        case 1
+        then have *: "?ys ! j = (exec (t + fst (?xs ! j)) <:> j) i"
+          by (simp add: less_k_nth)
+        show ?thesis
+        proof (cases "j = jj")
+          case True
+          then have "?ys ! j = (exec (Suc t) <:> j) i"
+            using 1 assms(3) * by simp
+          moreover have "(dec ?n) [jj:=u] ! j = u"
+            using True len_eq that by simp
+          ultimately show ?thesis
+            using assms(5) True by simp
+        next
+          case False
+          then have "(dec ?n) [jj:=u] ! j = (exec (t + fst (xs ! j)) <:> j) i"
+            using dec_zip_cont_less_k 1 assms(1) by simp
+          moreover have "?ys ! j = (exec (t + fst (xs ! j)) <:> j) i"
+            using False * by simp
+          ultimately show ?thesis
+            by simp
+        qed
+      next
+        case 2
+        then have *: "?ys ! j =
+            (case snd (?xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+          by (simp add: less_2k_nth)
+        show ?thesis
+        proof (cases "j = k + jj")
+          case True
+          then have "j - k = jj"
+            by simp
+          then have "snd (?xs ! (j - k)) = Some 0"
+            using assms(2,3) by simp
+          then have lhs: "?ys ! j = (if i = exec t <#> jj then 1 else 0)"
+            using * True by simp
+          have "(dec ?n) [jj:=u] ! j = (dec ?n) ! j"
+            using True assms(2) by simp
+          also have "...  =
+              (case snd (xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+            using True 2 assms(1,4) dec_zip_cont_less_2k by simp
+          also have "... = (if i = exec t <#> jj then 1 else 0)"
+            using True assms(4) by simp
+          finally have "(dec ?n) [jj:=u] ! j = (if i = exec t <#> jj then 1 else 0)" .
+          then show ?thesis
+            using lhs True by simp
+        next
+          case False
+          then have "j - k \<noteq> jj"
+            using 2 by auto
+          then have "snd (?xs ! (j - k)) = snd (xs ! (j - k))"
+            by simp
+          then have lhs: "?ys ! j =
+              (case snd (xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+            using * by simp
+          have "(dec ?n) [jj:=u] ! j = (dec ?n) ! j"
+            using 2 assms(2) by simp
+          then have "(dec ?n) [jj:=u] ! j =
+              (case snd (xs ! (j - k)) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> (j - k) then 1 else 0)"
+            using False 2 assms(1) dec_zip_cont_less_2k by simp
+          then show ?thesis
+            using lhs by simp
+        qed
+      next
+        case 3
+        then have "?ys ! j = (if i < t then 1 else 0)"
+          by (simp add: twok_nth)
+        moreover have "(dec ?n) [jj:=u] ! j = (if i < t then 1 else 0)"
+            using 3 assms(1,2) dec_zip_cont_2k by simp
+        ultimately show ?thesis
+          by simp
+      next
+        case 4
+        then have "?ys ! j = (if i = 0 then 1 else 0)"
+          using twok1_nth by fast
+        moreover have "(dec ?n) [jj:=u] ! j = (if i = 0 then 1 else 0)"
+            using 4 assms(1,2) dec_zip_cont_2k1 by simp
+        ultimately show ?thesis
+          by simp
+      qed
+    qed
+  qed
+  ultimately show ?thesis
+    using enc_upd_def by simp
+qed
+
+lemma zip_cont_upd_eq:
+  assumes "jj < k"
+    and "i = exec t <#> jj"
+    and "i < TT"
+    and "xs ! jj = (0, Some 0)"
+    and "length xs = k"
+  shows "(zip_cont t xs)(i:=enc_upd (zip_cont t xs i) jj (sim_write t ! jj)) =
+      zip_cont t (xs[jj:=(1, Some 0)])"
+    (is "?lhs = ?rhs")
+proof
+  fix p
+  consider "p < TT \<and> p \<noteq> i" | "p < TT \<and> p = i" | "p \<ge> TT"
+    by linarith
+  then show "?lhs p = ?rhs p"
+  proof (cases)
+    case 1
+    then have "?lhs p = zip_cont t xs p"
+      by simp
+    moreover have "zip_cont t xs p = zip_cont t (xs[jj:=(1, Some 0)]) p"
+    proof (rule zip_cont_nth_eqI)
+      show "p < TT"
+        using 1 by simp
+      show "(exec (t + fst (xs ! j)) <:> j) p =
+              (exec (t + fst (xs[jj := (1, Some 0)] ! j)) <:> j) p"
+          if "j < k" for j
+      proof (cases "j = jj")
+        case True
+        then have "fst (xs[jj := (1, Some 0)] ! j) = 1"
+          using assms(1,5) by simp
+        then have "(exec (t + fst (xs[jj := (1, Some 0)] ! j)) <:> j) p = (exec (Suc t) <:> j) p"
+          by simp
+        also have "... = (exec t <:> j) p"
+          using assms(2) 1 by (simp add: True assms(1) sim_write)
+        finally show ?thesis
+          using assms(4) True by simp
+      next
+        case False
+        then show ?thesis
+          by simp
+      qed
+      show "snd (xs ! j) = snd (xs[jj := (1, Some 0)] ! j)" if "j < k" for j
+        using assms(4,5) that by (cases "j = jj") simp_all
+    qed
+    ultimately show ?thesis
+      by simp
+  next
+    case 2
+    then have "?lhs p = enc_upd (zip_cont t xs i) jj (sim_write t ! jj)"
+      by simp
+    then show ?thesis
+      using 2 assms(1,2,4,5) sim_write' zip_cont_nth_eq_updI1 by auto
+  next
+    case 3
+    then show ?thesis
+      using zip_cont_def assms(3) by auto
+  qed
+qed
+
+lemma sem_cmdL5_neq_pos:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "snd (xs ! jj) = Some 0"
+    and "i \<noteq> exec t <#> jj"
+    and "i < TT"
+    and "tps' = tpsL t xs (Suc i) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL5 jj) (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL5 jj)"
+    using turing_command_cmdL5[OF assms(1)] turing_commandD(1) by simp
+  show "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(6) by simp
+  let ?rs = "read tps"
+  have rs1: "?rs ! 1 \<noteq> \<box>"
+    using read_tpsL_1_bounds assms(2,5) by (metis not_one_less_zero)
+  then show "fst (cmdL5 jj ?rs) = 0"
+    by (simp add: cmdL5_def)
+  show "act (cmdL5 jj ?rs [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "cmdL5 jj ?rs [!] j = (?rs ! j, Stay)"
+        using rs1 cmdL5_at_0 by simp
+      then show ?thesis
+        using assms tpsL_0 1 by (metis act_Stay that length_tpsL)
+    next
+      case 2
+      then have "enc_nth (?rs ! 1) (k + jj) = (if i = exec t <#> jj then 1 else 0)"
+        using assms read_tpsL_1_nth_less_2k by simp
+      then have "enc_nth (?rs ! 1) (k + jj) = 0"
+        using assms(4) by simp
+      then have "\<not> (1 < ?rs ! 1 \<and> ?rs ! 1 < G^(2*k+2)+2 \<and> ?rs ! (3+k+jj) < G \<and> enc_nth (?rs!1) (k+jj) = 1)"
+        by simp
+      then have "cmdL5 jj ?rs [!] 1 = (?rs ! 1, Right)"
+        using cmdL5_at_1_else rs1 by simp
+      then show ?thesis
+        using assms tpsL_1 2 act_Right that length_tpsL by (metis Suc_eq_plus1 prod.sel(1) tpsL_pos_1)
+    next
+      case 3
+      then have "cmdL5 jj ?rs [!] j = (?rs ! j, Stay)"
+        using rs1 cmdL5_at_2 by simp
+      then show ?thesis
+        using assms tpsL_2 3 by (metis act_Stay that length_tpsL)
+    next
+      case 4
+      then have "cmdL5 jj ?rs [!] j = (?rs ! j, Stay)"
+        using rs1 cmdL5_at_3 by simp
+      then have "act (cmdL5 jj ?rs [!] j) (tps ! j) = tps ! j"
+        using act_Stay by (simp add: \<open>length tps = 2 * k + 3\<close> that)
+      then show ?thesis
+        using assms tpsL_mvs' by (simp add: "4" add.commute)
+    next
+      case 5
+      then have "cmdL5 jj ?rs [!] j = (?rs ! j, Stay)"
+        using rs1 cmdL5_at_4 by simp
+      then have "act (cmdL5 jj ?rs [!] j) (tps ! j) = tps ! j"
+        using act_Stay by (simp add: \<open>length tps = 2 * k + 3\<close> that)
+      then show ?thesis
+        using assms tpsL_symbs' 5 by simp
+    qed
+  qed
+qed
+
+lemma sem_cmdL5_eq_pos:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "xs ! jj = (0, Some 0)"
+    and "i = exec t <#> jj"
+    and "tps' = tpsL t (xs[jj:=(1, Some 0)]) (Suc i) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+  shows "sem (cmdL5 jj) (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  have "i < TT"
+    using exec_pos_less_TT assms(1,4) by simp
+  show "proper_command (2 * k + 3) (cmdL5 jj)"
+    using turing_command_cmdL5[OF assms(1)] turing_commandD(1) by simp
+  show "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(5) by simp
+  let ?rs = "read tps"
+  have rs1: "?rs ! 1 \<noteq> \<box>"
+    using read_tpsL_1_bounds assms(2) `i < TT` by (metis not_one_less_zero)
+  then show "fst (cmdL5 jj ?rs) = 0"
+    by (simp add: cmdL5_def)
+  show "act (cmdL5 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "cmdL5 jj ?rs [!] j = (?rs ! j, Stay)"
+        using rs1 cmdL5_at_0 by simp
+      then show ?thesis
+        using assms tpsL_0 1 by (metis act_Stay that length_tpsL)
+    next
+      case 2
+      then have "enc_nth (?rs ! 1) (k + jj) = (if i = exec t <#> jj then 1 else 0)"
+        using assms `i < TT` read_tpsL_1_nth_less_2k by simp
+      then have "enc_nth (?rs ! 1) (k + jj) = 1"
+        using assms(4) by simp
+      moreover have "1 < ?rs ! 1 \<and> ?rs ! 1 < G^(2*k+2)+2"
+        using assms(2) `i < TT` read_tpsL_1_bounds by auto
+      moreover have "?rs ! (3+k+jj) < G"
+        using read_tpsL_4 assms sim_write_nth_less_G[OF assms(1)] by simp
+      ultimately have
+        "1 < ?rs ! 1 \<and> ?rs ! 1 < G^(2*k+2)+2 \<and> ?rs ! (3+k+jj) < G \<and> enc_nth (?rs!1) (k+jj) = 1"
+        by simp
+      then have "cmdL5 jj ?rs [!] 1 = (enc_upd (?rs!1) jj (?rs!(3+k+jj)), Right)"
+        using cmdL5_at_1 rs1 by simp
+      moreover have "?rs!(3+k+jj) = sim_write t ! jj"
+        by (simp add: assms(1,2) read_tpsL_4)
+      ultimately have *: "cmdL5 jj ?rs [!] 1 = (enc_upd (?rs ! 1) jj (sim_write t ! jj), Right)"
+        by simp
+
+      have "?rs ! 1 = zip_cont t xs i"
+        using assms(2) read_tpsL_1 zip_cont_def by auto
+
+      let ?tp = "act (enc_upd (?rs ! 1) jj (sim_write t ! jj), Right) (tps ! j)"
+      have "?tp = tps' ! 1"
+      proof -
+        have "?tp = ((zip_cont t xs)(i:=enc_upd (?rs ! 1) jj (sim_write t ! jj)), Suc i)"
+          using act_Right' assms tpsL_1
+          by (metis "2" add.commute fst_conv plus_1_eq_Suc snd_conv)
+        moreover have "tps' ! 1 = (zip_cont t (xs[jj:=(1, Some 0)]), Suc i)"
+          using assms(5) tpsL_1 by simp
+        moreover have "(zip_cont t xs)(i:=enc_upd (?rs ! 1) jj (sim_write t ! jj)) =
+            zip_cont t (xs[jj:=(1, Some 0)])"
+          using zip_cont_upd_eq assms `i < TT` \<open>read tps ! 1 = zip_cont t xs i\<close> by auto
+        ultimately show ?thesis
+          by auto
+      qed
+      then show ?thesis
+        using 2 * by simp
+    next
+      case 3
+      then have "cmdL5 jj ?rs [!] j = (?rs ! j, Stay)"
+        using rs1 cmdL5_at_2 by simp
+      then show ?thesis
+        using assms tpsL_2 3 by (metis act_Stay that length_tpsL)
+    next
+      case 4
+      then have "cmdL5 jj ?rs [!] j = (?rs ! j, Stay)"
+        using rs1 cmdL5_at_3 by simp
+      then have "act (cmdL5 jj ?rs [!] j) (tps ! j) = tps ! j"
+        using act_Stay by (simp add: \<open>length tps = 2 * k + 3\<close> that)
+      then show ?thesis
+        using assms tpsL_mvs' by (simp add: "4" add.commute)
+    next
+      case 5
+      then have "cmdL5 jj ?rs [!] j = (?rs ! j, Stay)"
+        using rs1 cmdL5_at_4 by simp
+      then have "act (cmdL5 jj ?rs [!] j) (tps ! j) = tps ! j"
+        using act_Stay by (simp add: \<open>length tps = 2 * k + 3\<close> that)
+      then show ?thesis
+        using assms tpsL_symbs' 5 by simp
+    qed
+  qed
+qed
+
+lemma sem_cmdL5_eq_TT:
+  assumes "jj < k" and "tps = tpsL t xs TT q mvs symbs"
+  shows "sem (cmdL5 jj) (0, tps) = (1, tps)"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL5 jj)"
+    using turing_command_cmdL5[OF assms(1)] turing_commandD(1) by simp
+  show "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  let ?rs = "read tps"
+  have rs1: "?rs ! 1 = \<box>"
+    using read_tpsL_1 assms(2) by simp
+  then show "fst (cmdL5 jj ?rs) = 1"
+    by (simp add: cmdL5_def)
+  show "\<And>i. i < 2 * k + 3 \<Longrightarrow> act (cmdL5 jj ?rs [!] i) (tps ! i) = tps ! i"
+    using len rs1 act_Stay cmdL5_eq_0 read_length by auto
+qed
+
+lemma execute_tmL45_1:
+  assumes "tt \<le> exec t <#> jj"
+    and "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "xs ! jj = (0, Some 0)"
+    and "tps' = tpsL t xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL45 jj) (0, tps) tt = (0, tps')"
+  using assms(1,5)
+proof (induction tt arbitrary: tps')
+  case 0
+  then show ?case
+    using assms(2-4) by simp
+next
+  case (Suc tt)
+  then have tt_neq: "tt \<noteq> exec t <#> jj"
+    by simp
+  have tt_le: "tt \<le> exec t <#> jj"
+    using Suc.prems by simp
+  then have tt_less: "tt < TT"
+    using exec_pos_less_TT assms(2) by (meson le_trans less_Suc_eq_le)
+  define tps_tt where "tps_tt = tpsL t xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  have "execute (tmL45 jj) (0, tps) (Suc tt) = exe (tmL45 jj) (execute (tmL45 jj) (0, tps) tt)"
+    by simp
+  also have "... = exe (tmL45 jj) (0, tps_tt)"
+    using Suc.IH assms(2-4) tt_le tps_tt_def by simp
+  also have "... = sem (cmdL5 jj) (0, tps_tt)"
+    using tmL45_def exe_lt_length by simp
+  also have "... = (0, tpsL t xs (Suc tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using sem_cmdL5_neq_pos assms(2-4) tt_neq tt_less by (simp add: tps_tt_def)
+  finally show ?case
+    by (simp add: Suc.prems(2))
+qed
+
+lemma execute_tmL45_2:
+  assumes "tt = exec t <#> jj"
+    and "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "xs ! jj = (0, Some 0)"
+    and "tps' = tpsL t (xs[jj:=(1, Some 0)]) (Suc tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+  shows "execute (tmL45 jj) (0, tps) (Suc tt) = (0, tps')"
+proof -
+  have "execute (tmL45 jj) (0, tps) (Suc tt) = exe (tmL45 jj) (execute (tmL45 jj) (0, tps) tt)"
+    by simp
+  also have "... = exe (tmL45 jj) (0, tpsL t xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using execute_tmL45_1 assms by simp
+  also have "... = sem (cmdL5 jj) (0, tpsL t xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using tmL45_def exe_lt_length by simp
+  also have "... = (0, tpsL t (xs[jj:=(1, Some 0)]) (Suc tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using sem_cmdL5_eq_pos[OF assms(2)] assms by simp
+  finally show ?thesis
+    using assms(5) by simp
+qed
+
+lemma execute_tmL45_3:
+  assumes "tt \<ge> Suc (exec t <#> jj)"
+    and "tt \<le> TT"
+    and "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "xs ! jj = (0, Some 0)"
+    and "tps' = tpsL t (xs[jj:=(1, Some 0)]) tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+  shows "execute (tmL45 jj) (0, tps) tt = (0, tps')"
+  using assms(1,2,6)
+proof (induction tt arbitrary: tps' rule: nat_induct_at_least)
+  case base
+  then show ?case
+    using assms(3-5,7) execute_tmL45_2 by simp
+next
+  case (Suc tt)
+  then have tt: "tt < TT" "tt \<noteq> exec t <#> jj"
+    by simp_all
+  have "execute (tmL45 jj) (0, tps) (Suc tt) = exe (tmL45 jj) (execute (tmL45 jj) (0, tps) tt)"
+    by simp
+  also have "... = exe (tmL45 jj) (0, tpsL t (xs[jj:=(1, Some 0)]) tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using Suc by simp
+  also have "... = sem (cmdL5 jj) (0, tpsL t (xs[jj:=(1, Some 0)]) tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using tmL45_def exe_lt_length by simp
+  also have "... = (0, tpsL t (xs[jj:=(1, Some 0)]) (Suc tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using sem_cmdL5_neq_pos tt by (simp add: assms(3) assms(7))
+  finally show ?case
+    using Suc(4) by presburger
+qed
+
+lemma execute_tmL45_4:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "xs ! jj = (0, Some 0)"
+    and "tps' = tpsL t (xs[jj:=(1, Some 0)]) TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+  shows "execute (tmL45 jj) (0, tps) (Suc TT) = (1, tps')"
+proof -
+  have "execute (tmL45 jj) (0, tps) (Suc TT) = exe (tmL45 jj) (execute (tmL45 jj) (0, tps) TT)"
+    by simp
+  also have "... = exe (tmL45 jj) (0, tps')"
+    using assms execute_tmL45_3 by (metis Suc_leI exec_pos_less_TT order_refl)
+  also have "... = sem (cmdL5 jj) (0, tps')"
+    using tmL45_def exe_lt_length by simp
+  also have "... = (1, tps')"
+    using sem_cmdL5_eq_TT assms(1,4) by simp
+  finally show ?thesis .
+qed
+
+definition "esL45 \<equiv> map (\<lambda>i. (n + 1, Suc i)) [0..<TT] @ [(n + 1, TT)]"
+
+lemma len_esL45: "length esL45 = Suc TT"
+  using esL45_def by simp
+
+lemma nth_map_upt_TT:
+  fixes es
+  assumes "es = map f [0..<TT] @ es'" and "i < TT"
+  shows "es ! i = f i"
+  using assms by (metis add.left_neutral diff_zero length_map length_upt nth_append nth_map nth_upt)
+
+lemma tmL45:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (0, Some 0)"
+    and "tps' = tpsL t (xs[jj:=(1, Some 0)]) TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL45 jj) tps esL45 tps'"
+proof
+  show "execute (tmL45 jj) (0, tps) (length esL45) = (length (tmL45 jj), tps')"
+    using tmL45_def execute_tmL45_4 esL45_def assms by simp
+  show "fst (execute (tmL45 jj) (0, tps) i) < length (tmL45 jj)" if "i < length esL45" for i
+  proof -
+    have "i \<le> TT"
+      using esL45_def that by simp
+    then consider "i \<le> exec t <#> jj" | "i = Suc (exec t <#> jj)" | "i > Suc (exec t <#> jj) \<and> i \<le> TT"
+      by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using assms execute_tmL45_1 tmL45_def by simp
+    next
+      case 2
+      then show ?thesis
+        using assms execute_tmL45_2 tmL45_def by simp
+    next
+      case 3
+      then show ?thesis
+        using assms execute_tmL45_3 tmL45_def by simp
+    qed
+  qed
+  show "execute (tmL45 jj) (0, tps) (Suc i) <#> 0 = fst (esL45 ! i) \<and>
+        execute (tmL45 jj) (0, tps) (Suc i) <#> 1 = snd (esL45 ! i)"
+    if "i < length esL45" for i
+  proof -
+    have "i \<le> TT"
+      using esL45_def that by simp
+    then consider "i < exec t <#> jj" | "i = exec t <#> jj" | "i \<ge> Suc (exec t <#> jj) \<and> i < TT" | "i = TT"
+      by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "Suc i \<le> exec t <#> jj"
+        by simp
+      then have "i < TT"
+        using exec_pos_less_TT by (metis \<open>i \<le> TT\<close> assms(1) nat_less_le not_less_eq_eq)
+      then have "esL45 ! i = (n + 1, Suc i)"
+        using esL45_def nth_map_upt_TT by auto
+      then show ?thesis
+        using assms execute_tmL45_1 tpsL_pos_0 tpsL_pos_1 by (metis \<open>Suc i \<le> exec t <#> jj\<close> fst_conv snd_conv)
+    next
+      case 2
+      then have "i < TT"
+        using exec_pos_less_TT by (simp add: assms(1))
+      then have "esL45 ! i = (n + 1, Suc i)"
+        using esL45_def nth_map_upt_TT by auto
+      then show ?thesis
+        using assms execute_tmL45_2 tpsL_pos_0 tpsL_pos_1 by (metis 2 fst_conv snd_conv)
+    next
+      case 3
+      then have "esL45 ! i = (n + 1, Suc i)"
+        using esL45_def nth_map_upt_TT by auto
+      then show ?thesis
+        using assms execute_tmL45_3 tpsL_pos_0 tpsL_pos_1 3
+        by (metis Suc_leI fst_conv le_imp_less_Suc nat_less_le snd_conv)
+    next
+      case 4
+      then have "esL45 ! i = (n + 1, TT)"
+        using esL45_def by (simp add: nth_append)
+      then show ?thesis
+        using assms execute_tmL45_4 tpsL_pos_0 tpsL_pos_1 4 by simp
+    qed
+  qed
+qed
+
+definition "esL46 \<equiv> esL45 @ [(n + 1, fmt n)]"
+
+lemma len_esL46: "length esL46 = TT + 2"
+  using len_esL45 esL46_def by simp
+
+lemma tmL46:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (0, Some 0)"
+    and "tps' = tpsL t (xs[jj:=(1, Some 0)]) (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL46 jj) tps esL46 tps'"
+  unfolding tmL46_def esL46_def
+proof (rule traces_sequential)
+  let ?tps = "tpsL t (xs[jj:=(1, Some 0)]) TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  show "traces (tmL45 jj) tps esL45 ?tps"
+    using tmL45 assms by simp
+  show "traces (tm_left 1) ?tps [(n + 1, fmt n)] tps'"
+    using tpsL_pos_0 tpsL_pos_1 assms tpsL_def tpsL_1
+    by (intro traces_tm_left_1I) simp_all
+qed
+
+lemma sem_cmdL7_nonleft_gt_0:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "i < TT"
+    and "i > 0"
+    and "sim_move t ! jj \<noteq> 0"
+    and "tps' = tpsL t xs (i - 1) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL7 jj) (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL7 jj)"
+    using turing_command_cmdL7[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(7) by simp
+  define rs where "rs = read tps"
+  then have "\<not> is_beginning (rs ! 1)"
+    using read_tpsL_1_nth_2k1 assms
+    by (metis enc_nth_dec nat_neq_iff numerals(1) zero_neq_numeral)
+  then show "fst (cmdL7 jj rs) = 0"
+    unfolding cmdL7_def by simp
+
+  have "rs ! (3 + jj) = sim_move t ! jj"
+    using rs_def assms(1,2) read_tpsL_3 by simp
+  moreover have "sim_move t ! jj < 3"
+    using sim_move_def assms(1) direction_to_symbol_less sim_move_nth sim_move_nth_else
+    by (metis One_nat_def not_add_less2 not_less_eq numeral_3_eq_3 plus_1_eq_Suc)
+  ultimately have "condition7c rs jj"
+    using assms(6) by simp
+  then have *: "snd (cmdL7 jj rs) =
+    [(rs ! 0, Stay),
+     (rs ! 1, Left),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL7_def by auto
+
+  show "act (cmdL7 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 0) (tps ! 0)"
+        by simp
+      also have "... = act (rs ! 0, Stay) (tps ! 0)"
+        using * rs_def by simp
+      also have "... = tps ! 0"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 0"
+        using assms(2,7) tpsL_0 by simp
+      also have "... = tps' ! j"
+        using 1 by simp
+      finally show ?thesis .
+    next
+      case 2
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (rs ! 1, Left) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps' ! 1"
+        using act_Left len rs_def assms tpsL_1 by (metis 2 fst_conv that tpsL_pos_1)
+      also have "... = tps' ! j"
+        using 2 by simp
+      finally show ?thesis .
+    next
+      case 3
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,7) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,7) tpsL_mvs' 4 by simp
+      finally show ?thesis .
+    next
+      case 5
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,7) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma sem_cmdL7_nonleft_eq_0:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "sim_move t ! jj \<noteq> 0"
+  shows "sem (cmdL7 jj) (0, tps) = (1, tps)"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL7 jj)"
+    using turing_command_cmdL7[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps = 2 * k + 3"
+    using assms(2) by simp
+
+  define rs where "rs = read tps"
+  then have "is_beginning (rs ! 1)"
+    using read_tpsL_1_nth_2k1 assms enc_nth_def read_tpsL_1_bounds zero_less_Suc
+    by simp
+  then show "fst (cmdL7 jj (read tps)) = 1"
+    using cmdL7_def rs_def by simp
+
+  have "rs ! (3 + jj) = sim_move t ! jj"
+    using rs_def assms(1,2) read_tpsL_3 by simp
+  then have "condition7c rs jj"
+    using sim_move direction_to_symbol_less sim_move_nth sim_move_nth_else assms(1,4)
+    by (metis less_Suc_eq not_add_less2 numeral_3_eq_3 numeral_eq_iff numerals(1) plus_1_eq_Suc semiring_norm(86))
+  then have *: "snd (cmdL7 jj rs) =
+    [(rs ! 0, Stay),
+     (rs ! 1, Left),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL7_def by auto
+
+  show "act (cmdL7 jj (read tps) [!] j) (tps ! j) = tps ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using * act_Stay assms(2) rs_def by simp
+    next
+      case 2
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! 1, Left) (tps ! j)"
+        using * rs_def by simp
+      also have "... = tps ! j"
+        using 2 assms(2) act_Left that length_tpsL tpsL_1 tpsL_pos_1 rs_def
+        by (metis diff_is_0_eq' fst_conv less_numeral_extra(1) nat_less_le)
+      finally show ?thesis
+        by simp
+    next
+      case 3
+      then show ?thesis
+        using * act_Stay assms(2) rs_def by simp
+    next
+      case 4
+      then show ?thesis
+        using * act_Stay assms rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] len by simp
+    next
+      case 5
+      then show ?thesis
+        using * act_Stay assms rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] len by simp
+    qed
+  qed
+qed
+
+lemma execute_tmL67_nonleft_less:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "sim_move t ! jj \<noteq> 0"
+    and "tt < TT"
+    and "tps' = tpsL t xs (fmt n - tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL67 jj) (0, tps) tt = (0, tps')"
+  using assms(5,6)
+proof (induction tt arbitrary: tps')
+  case 0
+  then show ?case
+    using assms(1-4) tmL67_def by simp
+next
+  case (Suc tt)
+  have "execute (tmL67 jj) (0, tps) (Suc tt) = exe (tmL67 jj) (execute (tmL67 jj) (0, tps) tt)"
+    by simp
+  also have "... = exe (tmL67 jj) (0, tpsL t xs (fmt n - tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using Suc by simp
+  finally show ?case
+    using assms(1-4) sem_cmdL7_nonleft_gt_0 tmL67_def exe_lt_length Suc by simp
+qed
+
+lemma execute_tmL67_nonleft_finish:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "sim_move t ! jj \<noteq> 0"
+    and "tps' = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL67 jj) (0, tps) TT = (1, tps')"
+  using assms execute_tmL67_nonleft_less sem_cmdL7_nonleft_eq_0 tmL67_def exe_lt_length
+  by simp
+
+definition "esL67 \<equiv> map (\<lambda>i. (n + 1, i)) (rev [0..<fmt n]) @ [(n + 1, 0)]"
+
+lemma esL67_at_fmtn [simp]: "esL67 ! (fmt n) = (n + 1, 0)"
+  using esL67_def by (simp add: nth_append)
+
+lemma esL67_at_lt_fmtn [simp]: "i < fmt n \<Longrightarrow> esL67 ! i = (n + 1, fmt n - i - 1)"
+proof -
+  assume "i < fmt n"
+  then have "(rev [0..<fmt n]) ! i = fmt n - 1 - i"
+    by (metis Suc_diff_1 add.left_neutral bot_nat_0.extremum diff_diff_add diff_less_Suc diff_zero
+      length_upt less_nat_zero_code nat_less_le nth_upt plus_1_eq_Suc rev_nth)
+  moreover have "length (map (Pair (Suc n)) (rev [0..<fmt n])) = fmt n"
+    by simp
+  ultimately show ?thesis
+    by (simp add: \<open>i < fmt n\<close> esL67_def nth_append)
+qed
+
+lemma tmL67_nonleft:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "sim_move t ! jj \<noteq> 0"
+    and "tps' = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL67 jj) tps esL67 tps'"
+proof
+  have len: "length esL67 = TT"
+    using esL67_def by simp
+  then show 1: "execute (tmL67 jj) (0, tps) (length esL67) = (length (tmL67 jj), tps')"
+    using assms tmL67_def execute_tmL67_nonleft_finish by simp
+  show "\<And>i. i < length esL67 \<Longrightarrow>
+        fst (execute (tmL67 jj) (0, tps) i) < length (tmL67 jj)"
+    using len assms execute_tmL67_nonleft_less tmL67_def by simp
+  show "(execute (tmL67 jj) (0, tps) (Suc i)) <#> 0 = fst (esL67 ! i) \<and>
+        (execute (tmL67 jj) (0, tps) (Suc i)) <#> 1 = snd (esL67 ! i)"
+      if "i < length esL67" for i
+  proof (cases "i = fmt n")
+    case True
+    then show ?thesis
+      using assms that 1 tpsL_pos_0 tpsL_pos_1 len by simp
+  next
+    case False
+    then have "Suc i < TT"
+      using that len by simp
+    moreover from this have "esL67 ! i = (n + 1, fmt n - 1 - i)"
+      by simp
+    ultimately show ?thesis
+      using tpsL_pos_0 tpsL_pos_1 assms(1-5) execute_tmL67_nonleft_less
+      by (metis (no_types, lifting) diff_diff_left fst_conv plus_1_eq_Suc snd_conv)
+  qed
+qed
+
+lemma sem_cmdL7_1:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "i < TT"
+    and "i > exec t <#> jj"
+    and "sim_move t ! jj = 0"
+    and "tps' = tpsL t xs (i - 1) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL7 jj) (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL7 jj)"
+    using turing_command_cmdL7[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(8) by simp
+
+  define rs where "rs = read tps"
+  then have not_beginning: "\<not> is_beginning (rs ! 1)"
+    using read_tpsL_1_nth_2k1 assms enc_nth_def read_tpsL_1_bounds zero_less_Suc
+    by simp
+  then show "fst (cmdL7 jj (read tps)) = 0"
+    using cmdL7_def rs_def by simp
+
+  have "rs ! (3 + jj) = \<box>"
+    using rs_def read_tpsL_3 assms by simp
+  moreover have "enc_nth (rs ! 1) (k + jj) = 0"
+    using assms rs_def read_tpsL_1_nth_less_2k by simp
+  ultimately have "condition7c rs jj"
+    using not_beginning by simp
+  then have *: "snd (cmdL7 jj rs) =
+    [(rs ! 0, Stay),
+     (rs ! 1, Left),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL7_def by auto
+
+  show "act (cmdL7 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 0) (tps ! 0)"
+        by simp
+      also have "... = act (rs ! 0, Stay) (tps ! 0)"
+        using * rs_def by simp
+      also have "... = tps ! 0"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 0"
+        using assms(2,8) tpsL_0 by simp
+      also have "... = tps' ! j"
+        using 1 by simp
+      finally show ?thesis .
+    next
+      case 2
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (rs ! 1, Left) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps' ! 1"
+        using act_Left len rs_def assms tpsL_1 by (metis 2 fst_conv that tpsL_pos_1)
+      also have "... = tps' ! j"
+        using 2 by simp
+      finally show ?thesis .
+    next
+      case 3
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,8) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,8) tpsL_mvs' 4 by simp
+      finally show ?thesis .
+    next
+      case 5
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,8) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma execute_tmL67_1:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 0"
+    and "tt < TT - exec t <#> jj"
+    and "tps' = tpsL t xs (fmt n - tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL67 jj) (0, tps) tt = (0, tps')"
+  using assms(6,7)
+proof (induction tt arbitrary: tps')
+  case 0
+  then show ?case
+    by (simp add: assms(2))
+next
+  case (Suc tt)
+  then have "execute (tmL67 jj) (0, tps) (Suc tt) = sem (cmdL7 jj) (execute (tmL67 jj) (0, tps) tt)"
+    using exe_lt_length tmL67_def by simp
+  then show ?case
+    using assms(1-5) sem_cmdL7_1 Suc by simp
+qed
+
+lemma zip_cont_enc_upd_Some:
+  assumes "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (1, None)"
+    and "i = exec (Suc t) <#> jj"
+  shows "(zip_cont t xs)(i:=(enc_upd (zip_cont t xs i) (k + jj) 1)) = zip_cont t (xs[jj:=(1, Some 1)])"
+    (is "?lhs = ?rhs")
+proof
+  fix p
+  have "i < TT"
+    using assms(1,4) exec_pos_less_TT by simp
+
+  consider "p < TT \<and> p \<noteq> i" | "p < TT \<and> p = i" | "p \<ge> TT"
+    by linarith
+  then show "?lhs p = ?rhs p"
+  proof (cases)
+    case 1
+    then have "?lhs p = zip_cont t xs p"
+      by simp
+    moreover have "zip_cont t xs p = zip_cont t (xs[jj:=(1, Some 1)]) p"
+    proof (rule zip_cont_eqI)
+      show "p < TT"
+        using 1 by simp
+      show "(exec (t + fst (xs ! j)) <:> j) p = (exec (t + fst (xs[jj := (1, Some 1)] ! j)) <:> j) p"
+        if "j < k" for j
+        using assms(1-3) by (cases "j = jj") simp_all
+      show "(case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if p = (exec (t + d)) <#> j then 1 else 0) =
+        (case snd (xs[jj := (1, Some 1)] ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if p = (exec (t + d)) <#> j then 1 else 0)"
+          (is "?lhs = ?rhs")
+        if "j < k" for j
+      proof (cases "j = jj")
+        case True
+        then show ?thesis
+          using 1 assms by simp
+      next
+        case False
+        then show ?thesis
+          by simp
+      qed
+    qed
+    ultimately show ?thesis
+      by simp
+  next
+    case 2
+    then show ?thesis
+      using assms enc_upd_zip_cont_None_Some by simp
+  next
+    case 3
+    then show ?thesis
+      using `i < TT` zip_cont_eq_0 by simp
+  qed
+qed
+
+lemma zip_cont_enc_upd_Some_Right:
+  assumes "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (1, None)"
+    and "i = Suc (exec t <#> jj)"
+    and "sim_move t ! jj = 2"
+  shows "(zip_cont t xs)(i:=(enc_upd (zip_cont t xs i) (k + jj) 1)) = zip_cont t (xs[jj:=(1, Some 1)])"
+proof -
+  have "i = exec (Suc t) <#> jj"
+    using assms sim_move by simp
+  then show ?thesis
+    using zip_cont_enc_upd_Some[OF assms(1-3)] by simp
+qed
+
+lemma zip_cont_enc_upd_Some_Left:
+  assumes "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (1, None)"
+    and "Suc i = exec t <#> jj"
+    and "sim_move t ! jj = 0"
+  shows "(zip_cont t xs)(i:=(enc_upd (zip_cont t xs i) (k + jj) 1)) = zip_cont t (xs[jj:=(1, Some 1)])"
+    (is "?lhs = ?rhs")
+proof -
+  have "i = exec (Suc t) <#> jj"
+    using assms sim_move by simp
+  then show ?thesis
+    using zip_cont_enc_upd_Some[OF assms(1-3)] by simp
+qed
+
+lemma zip_cont_enc_upd_None:
+  assumes "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "i = exec t <#> jj"
+  shows "(zip_cont t xs)(i:=(enc_upd (zip_cont t xs i) (k + jj) 0)) = zip_cont t (xs[jj:=(1, None)])"
+    (is "?lhs = ?rhs")
+proof
+  fix p
+  consider "p < TT \<and> p \<noteq> i" | "p < TT \<and> p = i" | "p \<ge> TT"
+    by linarith
+  then show "?lhs p = ?rhs p"
+  proof (cases)
+    case 1
+    then have "?lhs p = zip_cont t xs p"
+      by simp
+    moreover have "zip_cont t xs p = zip_cont t (xs[jj:=(1, None)]) p"
+    proof (rule zip_cont_eqI)
+      show "p < TT"
+        using 1 by simp
+      show "(exec (t + fst (xs ! j)) <:> j) p = (exec (t + fst (xs[jj := (1, None)] ! j)) <:> j) p"
+        if "j < k" for j
+        using assms(1-3) by (cases "j = jj") simp_all
+      show "(case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if p = (exec (t + d)) <#> j then 1 else 0) =
+          (case snd (xs[jj := (1, None)] ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if p = (exec (t + d)) <#> j then 1 else 0)"
+        if "j < k" for j
+      using assms 1 by (cases "j = jj") simp_all
+    qed
+    ultimately show ?thesis
+      by simp
+  next
+    case 2
+    then have "?lhs p = enc_upd (zip_cont t xs i) (k + jj) 0"
+      by simp
+    moreover have "enc_upd (zip_cont t xs i) (k + jj) 0 = zip_cont t (xs[jj:=(1, None)]) i"
+      using assms(1-4) enc_upd_zip_cont_Some_None by simp
+    ultimately show ?thesis
+      using 2 by simp
+  next
+    case 3
+    moreover have "i < TT"
+      using assms(4) by (simp add: assms(1) exec_pos_less_TT)
+    ultimately show ?thesis
+      using zip_cont_eq_0 by simp
+  qed
+qed
+
+lemma sem_cmdL7_2a:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "i = exec t <#> jj"
+    and "i > 0"
+    and "sim_move t ! jj = 0"
+    and "tps' = tpsL t (xs[jj:=(1, None)]) (i - 1) 1 (\<lambda>j. if j = jj then 3 else sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL7 jj) (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL7 jj)"
+    using turing_command_cmdL7[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(8) by simp
+
+  define rs where "rs = read tps"
+  then have not_beginning: "\<not> is_beginning (rs ! 1)"
+    using read_tpsL_1_nth_2k1 assms enc_nth_def read_tpsL_1_bounds zero_less_Suc exec_pos_less_TT
+    by simp
+  then show "fst (cmdL7 jj (read tps)) = 0"
+    using cmdL7_def rs_def by simp
+
+  have "i < TT"
+    using assms(5) by (simp add: assms(1) exec_pos_less_TT)
+
+  have "rs ! (3 + jj) = \<box>"
+    using rs_def read_tpsL_3 assms by simp
+  moreover have "enc_nth (rs ! 1) (k + jj) = 1"
+    using assms rs_def read_tpsL_1_nth_less_2k[OF `i < TT`] by simp
+  ultimately have "condition7a rs jj"
+    using not_beginning `i < TT` assms(2) read_tpsL_1_bounds rs_def by simp
+  then have *: "snd (cmdL7 jj rs) =
+    [(rs ! 0, Stay),
+     (enc_upd (rs ! 1) (k + jj) 0, Left),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (if j = jj then 3 else rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL7_def by auto
+
+  show "act (cmdL7 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 0) (tps ! 0)"
+        by simp
+      also have "... = act (rs ! 0, Stay) (tps ! 0)"
+        using * rs_def by simp
+      also have "... = tps ! 0"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 0"
+        using assms(2,8) tpsL_0 by simp
+      also have "... = tps' ! j"
+        using 1 by simp
+      finally show ?thesis .
+    next
+      case 2
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (enc_upd (rs ! 1) (k + jj) 0, Left) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps ! 1 |:=| (enc_upd (rs ! 1) (k + jj) 0) |-| 1"
+        using act_Left' 2 len by simp
+      also have "... = tps' ! 1"
+        using assms zip_cont_enc_upd_None rs_def read_tpsL_1 tpsL_1 zip_cont_def by simp
+      finally show ?thesis
+        using 2 by simp
+    next
+      case 3
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,8) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      show ?thesis
+      proof (cases "j = 3 + jj")
+        case True
+        then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (3, Stay) (tps ! j)"
+          using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] 4 diff_add_inverse by (smt (verit))
+        also have "... = tps' ! j"
+          using 4 assms(2,8) True act_onesie tpsL_mvs by simp
+        finally show ?thesis .
+      next
+        case False
+        then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+          using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] 4 diff_add_inverse by auto
+        also have "... = tps' ! j"
+          using 4 assms(2,8) False act_Stay len rs_def that tpsL_mvs'
+          by (smt (z3) add.commute le_add_diff_inverse2)
+        finally show ?thesis .
+      qed
+    next
+      case 5
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,8) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma execute_tmL67_2a:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 0"
+    and "exec t <#> jj > 0"
+    and "tt = TT - exec t <#> jj"
+    and "tps' = tpsL t (xs[jj:=(1, None)]) (fmt n - tt) 1 (\<lambda>j. if j = jj then 3 else sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL67 jj) (0, tps) tt = (0, tps')"
+proof -
+  have "tt > 0"
+    using assms(1,7) exec_pos_less_TT by simp
+  then have "tt - 1 < TT - exec t <#> jj"
+    using assms(6,7) by simp
+  then have *: "execute (tmL67 jj) (0, tps) (tt - 1) =
+      (0, tpsL t xs (fmt n - tt + 1) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using assms execute_tmL67_1[where ?tt="tt - 1"] by simp
+  have **: "fmt n - tt + 1 = exec t <#> jj"
+    using assms(1,6,7) exec_pos_less_TT
+    by (smt (z3) Nat.add_diff_assoc2 Suc_diff_Suc add.right_neutral add_Suc_right add_diff_cancel_right'
+      diff_Suc_Suc diff_less le_add_diff_inverse2 nat_less_le plus_1_eq_Suc zero_less_Suc)
+  have "execute (tmL67 jj) (0, tps) tt = exe (tmL67 jj) (execute (tmL67 jj) (0, tps) (tt - 1))"
+     using `tt > 0` exe_lt_length by (metis One_nat_def Suc_diff_Suc diff_zero execute.simps(2))
+  also have "... = sem (cmdL7 jj) (execute (tmL67 jj) (0, tps) (tt - 1))"
+    using tmL67_def exe_lt_length * by simp
+  also have "... = sem (cmdL7 jj) (0, tpsL t xs (fmt n - tt + 1) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using * by simp
+  also have "... = (0, tpsL t (xs[jj:=(1, None)]) (fmt n - tt) 1 (\<lambda>j. if j = jj then 3 else sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using ** assms sem_cmdL7_2a[where ?i="fmt n - tt + 1"] by simp
+  finally show ?thesis
+    using assms(8) by simp
+qed
+
+lemma zip_cont_Some_Some:
+  assumes "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "i = exec t <#> jj"
+    and "i = 0"
+    and "sim_move t ! jj = 0"
+  shows "zip_cont t xs = zip_cont t (xs[jj:=(1, Some 1)])"
+    (is "?lhs = ?rhs")
+proof
+  fix p
+  consider "p < TT" | "p \<ge> TT"
+    by linarith
+  then show "?lhs p = ?rhs p"
+  proof (cases)
+    case 1
+    then have "?lhs p = zip_cont t xs p"
+      by simp
+    moreover have "zip_cont t xs p = zip_cont t (xs[jj:=(1, Some 1)]) p"
+    proof (rule zip_cont_eqI)
+      show "p < TT"
+        using 1 by simp
+      show "\<And>j. j < k \<Longrightarrow>
+          ((exec (t + fst (xs ! j))) <:> j) p =
+          ((exec (t + fst (xs[jj := (1, Some 1)] ! j))) <:> j) p"
+        by (metis assms(2,3) fst_conv nth_list_update_eq nth_list_update_neq)
+      show "\<And>j. j < k \<Longrightarrow>
+          (case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if p = exec (t + d) <#> j then 1 else 0) =
+          (case snd (xs[jj := (1, Some 1)] ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if p = exec (t + d) <#> j then 1 else 0)"
+        using assms 1 sim_move
+        by (metis (no_types, lifting) add.commute add.right_neutral diff_add_zero nth_list_update_eq
+          nth_list_update_neq option.simps(5) plus_1_eq_Suc prod.sel(2))
+    qed
+    ultimately show ?thesis
+      by simp
+  next
+    case 2
+    then show ?thesis
+      using zip_cont_eq_0 by simp
+  qed
+qed
+
+lemma sem_cmdL7_2b:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "i = exec t <#> jj"
+    and "i = 0"
+    and "sim_move t ! jj = 0"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL7 jj) (0, tps) = (1, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL7 jj)"
+    using turing_command_cmdL7[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(8) by simp
+
+  define rs where "rs = read tps"
+  then have is_beginning: "is_beginning (rs ! 1)"
+    using read_tpsL_1_nth_2k1 assms(2,6) enc_nth_def read_tpsL_1_bounds rs_def by simp
+  then show "fst (cmdL7 jj (read tps)) = 1"
+    using assms(6) cmdL7_def rs_def by simp
+
+  have "rs ! (3 + jj) = \<box>"
+    by (simp add: rs_def assms add.commute read_tpsL_3')
+  then have "condition7c rs jj"
+    using is_beginning by simp
+  then have *: "snd (cmdL7 jj rs) =
+   [(rs ! 0, Stay),
+    (rs ! 1, Left),
+    (rs ! 2, Stay)] @
+    (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+    (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL7_def by auto
+
+  show "act (cmdL7 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 0) (tps ! 0)"
+        by simp
+      also have "... = act (rs ! 0, Stay) (tps ! 0)"
+        using * rs_def by simp
+      also have "... = tps ! 0"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 0"
+        using assms(2,8) tpsL_0 by simp
+      also have "... = tps' ! j"
+        using 1 by simp
+      finally show ?thesis .
+    next
+      case 2
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (rs ! 1, Left) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps' ! 1"
+        using zip_cont_Some_Some assms rs_def tpsL_1 "2" act_Left fst_conv len that tpsL_pos_1 by (metis zero_diff)
+      finally show ?thesis
+        using 2 by simp
+    next
+      case 3
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,8) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] 4 diff_add_inverse by auto
+      also have "... = tps' ! j"
+        using 4 assms(2,8) act_Stay len rs_def that tpsL_mvs' by (metis add.commute)
+      finally show ?thesis .
+    next
+      case 5
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,8) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma execute_tmL67_2b:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 0"
+    and "exec t <#> jj = 0"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL67 jj) (0, tps) TT = (1, tps')"
+  using execute_tmL67_1 assms exe_lt_length tmL67_def sem_cmdL7_2b by simp
+
+lemma tmL67_left_0:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 0"
+    and "exec t <#> jj = 0"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL67 jj) tps esL67 tps'"
+proof
+  show "execute (tmL67 jj) (0, tps) (length esL67) = (length (tmL67 jj), tps')"
+    using esL67_def tmL67_def execute_tmL67_2b assms by simp
+  show "\<And>i. i < length esL67 \<Longrightarrow>
+        fst (execute (tmL67 jj) (0, tps) i) < length (tmL67 jj)"
+    using esL67_def tmL67_def execute_tmL67_1 assms by simp
+  show "execute (tmL67 jj) (0, tps) (Suc i) <#> 0 = fst (esL67 ! i) \<and>
+        execute (tmL67 jj) (0, tps) (Suc i) <#> 1 = snd (esL67 ! i)"
+    if "i < length esL67" for i
+  proof (cases "i = fmt n")
+    case True
+    then have "Suc i = TT"
+      by simp
+    moreover have "esL67 ! i = (n + 1, 0)"
+      using True esL67_def by (simp add: nth_append)
+    ultimately show ?thesis
+      using assms that tpsL_pos_0 tpsL_pos_1 by (metis execute_tmL67_2b fst_conv snd_conv)
+  next
+    case False
+    then have "Suc i < TT"
+      using that esL67_def by simp
+    moreover from this have "esL67 ! i = (n + 1, fmt n - 1 - i)"
+      by simp
+    ultimately show ?thesis
+      using tpsL_pos_0 tpsL_pos_1 assms(1-6) execute_tmL67_1
+      by (metis (no_types, lifting) diff_diff_left fst_conv minus_nat.diff_0 plus_1_eq_Suc snd_conv)
+  qed
+qed
+
+lemma sem_cmdL7_3:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. if j = jj then 3 else sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, None)"
+    and "Suc i = exec t <#> jj"
+    and "sim_move t ! jj = 0"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) (i - 1) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL7 jj) (0, tps) = (if i = 0 then 1 else 0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL7 jj)"
+    using turing_command_cmdL7[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(7) by simp
+
+  define rs where "rs = read tps"
+  show "fst (cmdL7 jj (read tps)) = (if i = 0 then 1 else 0)"
+  proof (cases "i = 0")
+    case True
+    then have "is_beginning (rs ! 1)"
+      using read_tpsL_1_nth_2k1 assms(2) enc_nth_def read_tpsL_1_bounds rs_def by simp
+    then show ?thesis
+      using True cmdL7_def rs_def by simp
+  next
+    case False
+    then have "\<not> is_beginning (rs ! 1)"
+      using read_tpsL_1_nth_2k1 assms enc_nth_def exec_pos_less_TT
+      by (metis (no_types, lifting) Suc_le_lessD less_imp_le_nat less_numeral_extra(1) neq0_conv rs_def)
+    then show ?thesis
+      using False cmdL7_def rs_def by simp
+  qed
+
+  have "i < TT"
+    using assms exec_pos_less_TT by (metis Suc_less_eq less_SucI)
+
+  have "rs ! (3 + jj) = 3"
+    by (simp add: rs_def assms(1,2) add.commute read_tpsL_3')
+  moreover have "is_code (rs ! 1)"
+    using assms rs_def read_tpsL_1_nth_less_2k `i < TT` read_tpsL_1_bounds by simp
+  ultimately have "condition7b rs jj"
+    using `i < TT` assms(2) read_tpsL_1_bounds rs_def by simp
+  then have *: "snd (cmdL7 jj rs) =
+    [(rs ! 0, Stay),
+     (enc_upd (rs ! 1) (k + jj) 1, Left),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (if j = jj then 0 else rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL7_def by simp
+
+  show "act (cmdL7 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 0) (tps ! 0)"
+        by simp
+      also have "... = act (rs ! 0, Stay) (tps ! 0)"
+        using * rs_def by simp
+      also have "... = tps ! 0"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 0"
+        using assms(2,7) tpsL_0 by simp
+      also have "... = tps' ! j"
+        using 1 by simp
+      finally show ?thesis .
+    next
+      case 2
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (enc_upd (rs ! 1) (k + jj) 1, Left) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps ! 1 |:=| (enc_upd (rs ! 1) (k + jj) 1) |-| 1"
+        using act_Left' 2 len by simp
+      also have "... = tps' ! 1"
+        using assms zip_cont_enc_upd_Some_Left rs_def read_tpsL_1 tpsL_1 zip_cont_def by simp
+      finally show ?thesis
+        using 2 by simp
+    next
+      case 3
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,7) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      show ?thesis
+      proof (cases "j = 3 + jj")
+        case True
+        then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (0, Stay) (tps ! j)"
+          using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] 4 diff_add_inverse
+          by (smt (verit, ccfv_threshold))
+        also have "... = tps' ! j"
+          using 4 assms(1,2,6,7) 4 True act_onesie tpsL_mvs by simp
+        finally show ?thesis .
+      next
+        case False
+        then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+          using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] 4 diff_add_inverse by auto
+        also have "... = tps' ! j"
+          using 4 assms(2,7) False act_Stay len rs_def that tpsL_mvs'
+          by (smt (z3) add.commute le_add_diff_inverse2)
+        finally show ?thesis .
+      qed
+    next
+      case 5
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,7) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma execute_tmL67_3:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 0"
+    and "exec t <#> jj > 0"
+    and "tt = TT - exec t <#> jj"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) (fmt n - Suc tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL67 jj) (0, tps) (Suc tt) = (if fmt n - tt = 0 then 1 else 0, tps')"
+proof -
+  let ?i = "fmt n - tt"
+  let ?xs = "xs[jj:=(1, None)]"
+  let ?tps = "tpsL t ?xs ?i 1 (\<lambda>j. if j = jj then 3 else sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  have 1: "Suc ?i = exec t <#> jj"
+    using assms exec_pos_less_TT
+    by (smt (z3) Suc_diff_le diff_diff_cancel diff_is_0_eq nat_less_le neq0_conv not_less_eq zero_less_diff)
+  have 2: "?xs ! jj = (1, None)"
+    by (simp add: assms(1) assms(3))
+  have 3: "length ?xs = k"
+    by (simp add: assms(3))
+  have "execute (tmL67 jj) (0, tps) (Suc tt) = exe (tmL67 jj) (execute (tmL67 jj) (0, tps) tt)"
+    by simp
+  also have "... = exe (tmL67 jj) (0, ?tps)"
+    using assms execute_tmL67_2a by simp
+  also have "... = sem (cmdL7 jj) (0, ?tps)"
+    using tmL67_def exe_lt_length by simp
+  also have "... = (if fmt n - tt = 0 then 1 else 0, tps')"
+    using sem_cmdL7_3[OF assms(1) _ 3 2 1 assms(5)] assms(8) by simp
+  finally show ?thesis
+    by simp
+qed
+
+lemma sem_cmdL7_4:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 1)"
+    and "Suc i < exec t <#> jj"
+    and "sim_move t ! jj = 0"
+    and "tps' = tpsL t xs (i - 1) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL7 jj) (0, tps) = (if i = 0 then 1 else 0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL7 jj)"
+    using turing_command_cmdL7[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(7) by simp
+
+  define rs where "rs = read tps"
+  show "fst (cmdL7 jj (read tps)) = (if i = 0 then 1 else 0)"
+  proof (cases "i = 0")
+    case True
+    then have "is_beginning (rs ! 1)"
+      using read_tpsL_1_nth_2k1 assms(2) enc_nth_def read_tpsL_1_bounds rs_def by simp
+    then show ?thesis
+      using True cmdL7_def rs_def by simp
+  next
+    case False
+    then have "\<not> is_beginning (rs ! 1)"
+      using read_tpsL_1_nth_2k1 assms enc_nth_def exec_pos_less_TT read_tpsL_1 rs_def
+      by (metis (no_types, lifting) less_2_cases_iff nat_1_add_1 not_less_eq plus_1_eq_Suc)
+    then show ?thesis
+      using False cmdL7_def rs_def by simp
+  qed
+
+  have "i < exec t <#> jj"
+    using assms(5) by simp
+  then have "i < TT"
+    using assms(1) exec_pos_less_TT by (meson Suc_lessD less_trans_Suc)
+
+  have "rs ! (3 + jj) = \<box>"
+    using rs_def read_tpsL_3 assms by simp
+  moreover have "enc_nth (rs ! 1) (k + jj) = 0"
+    using assms rs_def read_tpsL_1_nth_less_2k[OF `i < TT`, of "k + jj"] sim_move by simp
+  ultimately have "condition7c rs jj"
+    by simp
+  then have *: "snd (cmdL7 jj rs) =
+    [(rs ! 0, Stay),
+     (rs ! 1, Left),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL7_def by auto
+
+  show "act (cmdL7 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 0) (tps ! 0)"
+        by simp
+      also have "... = act (rs ! 0, Stay) (tps ! 0)"
+        using * rs_def by simp
+      also have "... = tps ! 0"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 0"
+        using assms(2,7) tpsL_0 by simp
+      also have "... = tps' ! j"
+        using 1 by simp
+      finally show ?thesis .
+    next
+      case 2
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (rs ! 1, Left) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps' ! 1"
+        using assms rs_def tpsL_1 "2" act_Left fst_conv len that tpsL_pos_1 by metis
+      finally show ?thesis
+        using 2 by simp
+    next
+      case 3
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (cmdL7 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,7) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] 4 diff_add_inverse by auto
+      also have "... = tps' ! j"
+        using 4 assms(2,7) act_Stay len rs_def that tpsL_mvs' by (smt (z3) add.commute le_add_diff_inverse2)
+      finally show ?thesis .
+    next
+      case 5
+      then have "act (cmdL7 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,7) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma execute_tmL67_4:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 0"
+    and "exec t <#> jj > 0"
+    and "tt \<ge> Suc (Suc (TT - exec t <#> jj))"
+    and "tt \<le> TT"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) (fmt n - tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL67 jj) (0, tps) tt = (if TT - tt = 0 then 1 else 0, tps')"
+  using assms(7,8,9)
+proof (induction tt arbitrary: tps' rule: nat_induct_at_least)
+  case base
+  let ?tt = "TT - exec t <#> jj"
+  let ?xs = "xs[jj:=(1, Some 1)]"
+  let ?tps = "tpsL t ?xs (fmt n - Suc ?tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  have "execute (tmL67 jj) (0, tps) (Suc (Suc ?tt)) = exe (tmL67 jj) (execute (tmL67 jj) (0, tps) (Suc ?tt))"
+    by simp
+  also have "... = exe (tmL67 jj) (if fmt n - ?tt = 0 then 1 else 0, ?tps)"
+    using execute_tmL67_3 assms by simp
+  also have "... = sem (cmdL7 jj) (0, ?tps)"
+    using tmL67_def base exe_lt_length by simp
+  finally show ?case
+    using sem_cmdL7_4 assms base.prems(2) by simp
+next
+  case (Suc tt)
+  let ?tt = "TT - exec t <#> jj"
+  let ?xs = "xs[jj:=(1, Some 1)]"
+  let ?tps = "tpsL t ?xs (fmt n - tt) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  have "execute (tmL67 jj) (0, tps) (Suc tt) = exe (tmL67 jj) (execute (tmL67 jj) (0, tps) tt)"
+    by simp
+  also have "... = exe (tmL67 jj) (if Suc (fmt n) - tt = 0 then 1 else 0, ?tps)"
+    using Suc by simp
+  also have "... = sem (cmdL7 jj) (0, ?tps)"
+    using Suc.prems(1) exe_lt_length tmL67_def by auto
+  finally show ?case
+    using assms sem_cmdL7_4 Suc by simp
+qed
+
+lemma tmL67_left_gt_0:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 0"
+    and "exec t <#> jj > 0"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL67 jj) tps esL67 tps'"
+proof
+  show 1: "execute (tmL67 jj) (0, tps) (length esL67) = (length (tmL67 jj), tps')"
+  proof (cases "exec t <#> jj = 1")
+    case True
+    then show ?thesis
+      using assms(7) execute_tmL67_3[OF assms(1-6)] esL67_def tmL67_def by simp
+  next
+    case False
+    then have "TT \<ge> Suc (Suc (TT - exec t <#> jj))"
+      using assms(1,6,7) exec_pos_less_TT
+      by (metis Suc_leI add_diff_cancel_right' diff_diff_cancel diff_less nat_less_le plus_1_eq_Suc zero_less_Suc)
+    then show ?thesis
+      using assms(7) execute_tmL67_4[OF assms(1-6), where ?tt=TT] esL67_def tmL67_def by simp
+  qed
+  show "fst (execute (tmL67 jj) (0, tps) tt) < length (tmL67 jj)" if "tt < length esL67" for tt
+  proof -
+    have "tt < TT"
+      using that esL67_def by simp
+    then consider
+        "tt < TT - exec t <#> jj"
+      | "tt = TT - exec t <#> jj"
+      | "tt = Suc (TT - exec t <#> jj)"
+      | "tt \<ge> Suc (Suc (TT - exec t <#> jj))"
+      by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using assms execute_tmL67_1 tmL67_def by simp
+    next
+      case 2
+      then show ?thesis
+        using assms execute_tmL67_2a tmL67_def by simp
+    next
+      case 3
+      then show ?thesis
+        using assms execute_tmL67_3 tmL67_def `tt < TT` by simp
+    next
+      case 4
+      then show ?thesis
+        using assms execute_tmL67_4 tmL67_def `tt < TT` by simp
+    qed
+  qed
+  show "execute (tmL67 jj) (0, tps) (Suc tt) <#> 0 = fst (esL67 ! tt) \<and>
+        execute (tmL67 jj) (0, tps) (Suc tt) <#> 1 = snd (esL67 ! tt)"
+    if "tt < length esL67" for tt
+  proof -
+    have *: "Suc tt \<le> TT"
+      using that esL67_def by simp
+    then consider
+        "Suc tt < TT - exec t <#> jj"
+      | "Suc tt = TT - exec t <#> jj"
+      | "Suc tt = Suc (TT - exec t <#> jj)"
+      | "Suc tt \<ge> Suc (Suc (TT - exec t <#> jj))"
+      using esL67_def `tt < length esL67` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using execute_tmL67_1[OF assms(1-5), where ?tt="Suc tt"] tmL67_def tpsL_pos_0 tpsL_pos_1 *
+        by simp
+    next
+      case 2
+      then show ?thesis
+        using assms execute_tmL67_2a[OF assms(1-6), where ?tt="Suc tt"] tmL67_def tpsL_pos_0 tpsL_pos_1 *
+        by simp
+    next
+      case 3
+      then show ?thesis
+        using assms(6) execute_tmL67_3[OF assms(1-6), where ?tt="tt"] tmL67_def tpsL_pos_0 tpsL_pos_1 *
+        by (smt (verit, ccfv_threshold) add.commute diff_Suc_1 diff_diff_left diff_is_0_eq
+          esL67_at_fmtn esL67_at_lt_fmtn nat_less_le plus_1_eq_Suc prod.collapse prod.inject)
+    next
+      case 4
+      then show ?thesis
+        using assms(7) execute_tmL67_4[OF assms(1-6) _ *] * tmL67_def tpsL_pos_0 tpsL_pos_1 1 esL67_at_fmtn esL67_at_lt_fmtn esL67_def
+        by (smt (verit, best) One_nat_def Suc_diff_Suc add.commute diff_Suc_1 fst_conv le_neq_implies_less
+          length_append length_map length_rev length_upt list.size(3) list.size(4) minus_nat.diff_0 not_less_eq
+          plus_1_eq_Suc snd_conv)
+    qed
+  qed
+qed
+
+lemma tmL67_left:
+  assumes "jj < k"
+    and "tps = tpsL t xs (fmt n) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 0"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL67 jj) tps esL67 tps'"
+  using assms tmL67_left_0 tmL67_left_gt_0 by (cases "exec t <#> jj = 0") simp_all
+
+definition "esL47 \<equiv> esL46 @ esL67"
+
+lemma len_esL47: "length esL47 = 2 * TT + 2"
+  using len_esL46 esL47_def esL67_def by simp
+
+lemma tmL47_nonleft:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (0, Some 0)"
+    and "sim_move t ! jj \<noteq> 0"
+    and "tps' = tpsL t (xs[jj:=(1, Some 0)]) 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL47 jj) tps esL47 tps'"
+  unfolding tmL47_def esL47_def
+  using assms
+  by (intro traces_sequential[OF tmL46 tmL67_nonleft]) simp_all
+
+lemma tmL47_left:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (0, Some 0)"
+    and "sim_move t ! jj = 0"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL47 jj) tps esL47 tps'"
+  unfolding tmL47_def esL47_def
+  using assms
+  by (intro traces_sequential[OF tmL46 tmL67_left[where ?xs="xs[jj:=(1, Some 0)]"]]) simp_all
+
+lemma sem_cmdL8_nonright:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "i < TT"
+    and "sim_move t ! jj \<noteq> 2"
+    and "tps' = tpsL t xs (Suc i) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL8 jj) (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL8 jj)"
+    using turing_command_cmdL8[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(6) by simp
+  define rs where "rs = read tps"
+  then have "rs ! 1 \<noteq> \<box>"
+    using assms by (metis not_one_less_zero read_tpsL_1_bounds(1))
+  then show "fst (cmdL8 jj rs) = 0"
+    unfolding cmdL8_def by simp
+
+  have "rs ! (3 + jj) = sim_move t ! jj"
+    using rs_def assms(1,2) read_tpsL_3 by simp
+  moreover have "sim_move t ! jj < 3"
+    using sim_move_def assms(1) direction_to_symbol_less sim_move_nth sim_move_nth_else
+    by (metis One_nat_def not_add_less2 not_less_eq numeral_3_eq_3 plus_1_eq_Suc)
+  ultimately have "condition8d rs jj"
+    using assms(5) \<open>rs ! 1 \<noteq> \<box>\<close> by simp
+  then have *: "snd (cmdL8 jj rs) =
+    [(rs ! 0, Stay),
+     (rs ! 1, Right),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL8_def by auto
+
+  show "act (cmdL8 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        by (metis "*" act_Stay append.simps(2) assms(2) assms(6) len nth_Cons_0 rs_def that tpsL_0)
+    next
+      case 2
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (rs ! 1, Right) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps' ! 1"
+        using act_Right len rs_def assms tpsL_1 that tpsL_pos_1
+        by (metis "2" add.commute fst_conv plus_1_eq_Suc)
+      also have "... = tps' ! j"
+        using 2 by simp
+      finally show ?thesis .
+    next
+      case 3
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,6) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,6) tpsL_mvs' 4 by simp
+      finally show ?thesis .
+    next
+      case 5
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,6) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma sem_cmdL8_TT:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "i = TT"
+  shows "sem (cmdL8 jj) (0, tps) = (1, tps)"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL8 jj)"
+    using turing_command_cmdL8[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps = 2 * k + 3"
+    using assms(2) by simp
+  define rs where "rs = read tps"
+  then have "rs ! 1 = \<box>"
+    using assms read_tpsL_1 by simp
+  then show "fst (cmdL8 jj rs) = 1"
+    unfolding cmdL8_def by simp
+
+  have "rs ! (3 + jj) = sim_move t ! jj"
+    using rs_def assms(1,2) read_tpsL_3 by simp
+  moreover have "sim_move t ! jj < 3"
+    using sim_move_def assms(1) direction_to_symbol_less sim_move_nth sim_move_nth_else
+    by (metis One_nat_def not_add_less2 not_less_eq numeral_3_eq_3 plus_1_eq_Suc)
+  ultimately have "condition8c rs jj"
+    using \<open>rs ! 1 = \<box>\<close> by simp
+  then have *: "snd (cmdL8 jj rs) =
+    [(rs ! 0, Stay),
+     (rs ! 1, Stay),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL8_def by simp
+
+  show "act (cmdL8 jj (read tps) [!] j) (tps ! j) = tps ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+      using "*" act_Stay len rs_def
+        threeplus2k_2[where ?a="(rs ! 0, Stay)"] threeplus2k_3[where ?a="(rs ! 0, Stay)"]
+      by (cases) simp_all
+  qed
+qed
+
+lemma execute_tmL78_nonright_le_TT:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "sim_move t ! jj \<noteq> 2"
+    and "tt \<le> TT"
+    and "tps' = tpsL t xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL78 jj) (0, tps) tt = (0, tps')"
+  using assms(5,6)
+proof (induction tt arbitrary: tps')
+  case 0
+  then show ?case
+    using assms(1-4) by simp
+next
+  case (Suc tt)
+  then have "tt < TT"
+    by simp
+  have "execute (tmL78 jj) (0, tps) (Suc tt) = exe (tmL78 jj) (execute (tmL78 jj) (0, tps) tt)"
+    by simp
+  also have "... = exe (tmL78 jj) (0, tpsL t xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using Suc by simp
+  also have "... = sem (cmdL8 jj) (0, tpsL t xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using tmL78_def exe_lt_length by simp
+  finally show ?case
+    using sem_cmdL8_nonright[OF assms(1) _ assms(3) `tt < TT` assms(4)] Suc by simp
+qed
+
+lemma execute_tmL78_nonright_eq_Suc_TT:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "sim_move t ! jj \<noteq> 2"
+    and "tps' = tpsL t xs TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL78 jj) (0, tps) (Suc TT) = (1, tps')"
+  using assms sem_cmdL8_TT execute_tmL78_nonright_le_TT[where ?tt=TT] exe_lt_length tmL78_def
+  by simp
+
+definition "esL78 \<equiv> map (\<lambda>i. (n + 1, Suc i)) ([0..<TT]) @ [(n + 1, TT)]"
+
+lemma tmL78_nonright:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "sim_move t ! jj \<noteq> 2"
+    and "tps' = tpsL t xs TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL78 jj) tps esL78 tps'"
+proof
+  have len: "length esL78 = Suc TT"
+    using esL78_def by simp
+  then show 1: "execute (tmL78 jj) (0, tps) (length esL78) = (length (tmL78 jj), tps')"
+    using assms tmL78_def execute_tmL78_nonright_eq_Suc_TT by simp
+  show "\<And>i. i < length esL78 \<Longrightarrow>
+        fst (execute (tmL78 jj) (0, tps) i) < length (tmL78 jj)"
+    using len assms execute_tmL78_nonright_le_TT tmL78_def by simp
+  show "(execute (tmL78 jj) (0, tps) (Suc i)) <#> 0 = fst (esL78 ! i) \<and>
+        (execute (tmL78 jj) (0, tps) (Suc i)) <#> 1 = snd (esL78 ! i)"
+      if "i < length esL78" for i
+  proof (cases "i = TT")
+    case True
+    then have "esL78 ! i = (n + 1, TT)"
+      using esL78_def by (simp add: nth_append)
+    then show ?thesis
+      using assms that tpsL_pos_0 tpsL_pos_1 len 1 True by simp
+  next
+    case False
+    then have "i < TT"
+      using that len by simp
+    moreover from this have "esL78 ! i = (n + 1, Suc i)"
+      using esL78_def nth_map_upt_TT by auto
+    ultimately show ?thesis
+      using tpsL_pos_0 tpsL_pos_1 assms(1-4) execute_tmL78_nonright_le_TT
+      by (metis Suc_leI fst_conv snd_conv)
+  qed
+qed
+
+lemma sem_cmdL8_1:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "i < exec t <#> jj"
+    and "sim_move t ! jj = 2"
+    and "tps' = tpsL t xs (Suc i) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL8 jj) (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL8 jj)"
+    using turing_command_cmdL8[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(7) by simp
+
+  have "i < TT"
+    using assms exec_pos_less_TT by (meson Suc_less_eq less_SucI less_trans_Suc)
+
+  define rs where "rs = read tps"
+  then have "rs ! 1 \<noteq> \<box>"
+    using assms `i < TT` by (metis not_one_less_zero read_tpsL_1_bounds(1))
+  then show "fst (cmdL8 jj rs) = 0"
+    unfolding cmdL8_def by simp
+
+  have "rs ! (3 + jj) = sim_move t ! jj"
+    using rs_def assms(1,2) read_tpsL_3 by simp
+  moreover have "sim_move t ! jj = 2"
+    using sim_move_def assms(1,6) direction_to_symbol_less sim_move_nth sim_move_nth_else
+    by simp
+  moreover have "enc_nth (rs ! 1) (k + jj) = 0"
+    using assms rs_def read_tpsL_1_nth_less_2k[OF `i < TT`, of "k + jj"] by simp
+  ultimately have "condition8d rs jj"
+    using assms \<open>rs ! 1 \<noteq> \<box>\<close> by simp
+  then have *: "snd (cmdL8 jj rs) =
+    [(rs ! 0, Stay),
+     (rs ! 1, Right),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL8_def by auto
+
+  show "act (cmdL8 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using "*" act_Stay append.simps(2) assms len nth_Cons_0 rs_def that tpsL_0 by metis
+    next
+      case 2
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (rs ! 1, Right) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps' ! 1"
+        using act_Right len rs_def assms tpsL_1 that tpsL_pos_1
+        by (metis "2" add.commute fst_conv plus_1_eq_Suc)
+      also have "... = tps' ! j"
+        using 2 by simp
+      finally show ?thesis .
+    next
+      case 3
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,7) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,7) tpsL_mvs' 4 by simp
+      finally show ?thesis .
+    next
+      case 5
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,7) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma execute_tmL78_1:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 2"
+    and "tt \<le> exec t <#> jj"
+    and "tps' = tpsL t xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL78 jj) (0, tps) tt = (0, tps')"
+  using assms(6,7)
+proof (induction tt arbitrary: tps')
+  case 0
+  then show ?case
+    using assms(1-5) by simp
+next
+  case (Suc tt)
+  then have "tt < exec t <#> jj"
+    by simp
+  have "execute (tmL78 jj) (0, tps) (Suc tt) = exe (tmL78 jj) (execute (tmL78 jj) (0, tps) tt)"
+    by simp
+  also have "... = exe (tmL78 jj) (0, tpsL t xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using Suc by simp
+  also have "... = sem (cmdL8 jj) (0, tpsL t xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j))"
+    using exe_lt_length tmL78_def by simp
+  finally show ?case
+    using assms(1-5) sem_cmdL8_1[where ?i=tt] Suc by simp
+qed
+
+lemma sem_cmdL8_2:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "i = exec t <#> jj"
+    and "sim_move t ! jj = 2"
+    and "tps' = tpsL t (xs[jj:=(1, None)]) (Suc i) 1 (\<lambda>j. if j = jj then 3 else sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL8 jj) (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL8 jj)"
+    using turing_command_cmdL8[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(7) by simp
+
+  have "i < TT"
+    using assms exec_pos_less_TT by (meson Suc_less_eq less_SucI less_trans_Suc)
+
+  define rs where "rs = read tps"
+  then have "rs ! 1 \<noteq> \<box>"
+    using assms `i < TT` by (metis not_one_less_zero read_tpsL_1_bounds(1))
+  then show "fst (cmdL8 jj rs) = 0"
+    unfolding cmdL8_def by simp
+
+  have "rs ! (3 + jj) = 2"
+    using rs_def read_tpsL_3 assms by simp
+  moreover have "enc_nth (rs ! 1) (k + jj) = 1"
+    using assms rs_def read_tpsL_1_nth_less_2k[OF `i < TT`] by simp
+  ultimately have "condition8a rs jj"
+    using `i < TT` assms(2) read_tpsL_1_bounds rs_def by simp
+  then have *: "snd (cmdL8 jj rs) =
+    [(rs ! 0, Stay),
+     (enc_upd (rs ! 1) (k + jj) 0, Right),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (if j = jj then 3 else rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL8_def by simp
+
+  show "act (cmdL8 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 0) (tps ! 0)"
+        by simp
+      also have "... = act (rs ! 0, Stay) (tps ! 0)"
+        using * rs_def by simp
+      also have "... = tps ! 0"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 0"
+        using assms(2,7) tpsL_0 by simp
+      also have "... = tps' ! j"
+        using 1 by simp
+      finally show ?thesis .
+    next
+      case 2
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (enc_upd (rs ! 1) (k + jj) 0, Right) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps ! 1 |:=| (enc_upd (rs ! 1) (k + jj) 0) |+| 1"
+        using act_Right' 2 len by simp
+      also have "... = tps' ! 1"
+        using assms zip_cont_enc_upd_None rs_def read_tpsL_1 tpsL_1 zip_cont_def by simp
+      finally show ?thesis
+        using 2 by simp
+    next
+      case 3
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,7) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      show ?thesis
+      proof (cases "j = 3 + jj")
+        case True
+        then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (3, Stay) (tps ! j)"
+          using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] 4 diff_add_inverse by (smt (verit))
+        also have "... = tps' ! j"
+          using 4 assms(2,7) True act_onesie tpsL_mvs by simp
+        finally show ?thesis .
+      next
+        case False
+        then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+          using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] 4 diff_add_inverse by auto
+        also have "... = tps' ! j"
+          using 4 assms(2,7) False act_Stay len rs_def that tpsL_mvs'
+          by (smt (z3) add.commute le_add_diff_inverse2)
+        finally show ?thesis .
+      qed
+    next
+      case 5
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,7) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma execute_tmL78_2:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 2"
+    and "tps' = tpsL t (xs[jj:=(1, None)]) (Suc (exec t <#> jj)) 1 (\<lambda>j. if j = jj then 3 else sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL78 jj) (0, tps) (Suc (exec t <#> jj)) = (0, tps')"
+  using assms exe_lt_length tmL78_def execute_tmL78_1 sem_cmdL8_2 by simp
+
+lemma sem_cmdL8_3:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. if j = jj then 3 else sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, None)"
+    and "i = Suc (exec t <#> jj)"
+    and "sim_move t ! jj = 2"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) (Suc i) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL8 jj) (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL8 jj)"
+    using turing_command_cmdL8[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(7) by simp
+
+  have "i < TT"
+    using assms exec_pos_less_TT sim_move
+    by (metis (no_types, lifting) add_2_eq_Suc' diff_Suc_1)
+  moreover define rs where "rs = read tps"
+  ultimately have "rs ! 1 \<noteq> \<box>"
+    by (metis (no_types, lifting) assms(2) not_one_less_zero read_tpsL_1_bounds(1))
+  then show "fst (cmdL8 jj (read tps)) = 0"
+    using cmdL8_def rs_def by simp
+
+  have "rs ! (3 + jj) = 3"
+    by (simp add: rs_def assms(1,2) add.commute read_tpsL_3')
+  moreover have "is_code (rs ! 1)"
+    using assms rs_def read_tpsL_1_nth_less_2k `i < TT` read_tpsL_1_bounds by simp
+  ultimately have "condition7b rs jj"
+    using `i < TT` assms(2) read_tpsL_1_bounds rs_def by simp
+  then have *: "snd (cmdL8 jj rs) =
+    [(rs ! 0, Stay),
+     (enc_upd (rs ! 1) (k + jj) 1, Right),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (if j = jj then 2 else rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL8_def by simp
+
+  show "act (cmdL8 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 0) (tps ! 0)"
+        by simp
+      also have "... = act (rs ! 0, Stay) (tps ! 0)"
+        using * rs_def by simp
+      also have "... = tps ! 0"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 0"
+        using assms(2,7) tpsL_0 by simp
+      also have "... = tps' ! j"
+        using 1 by simp
+      finally show ?thesis .
+    next
+      case 2
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (enc_upd (rs ! 1) (k + jj) 1, Right) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps ! 1 |:=| (enc_upd (rs ! 1) (k + jj) 1) |+| 1"
+        using act_Right' 2 len by simp
+      also have "... = tps' ! 1"
+        using assms zip_cont_enc_upd_Some_Right rs_def read_tpsL_1 tpsL_1 zip_cont_def by simp
+      finally show ?thesis
+        using 2 by simp
+    next
+      case 3
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,7) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      show ?thesis
+      proof (cases "j = 3 + jj")
+        case True
+        then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (2, Stay) (tps ! j)"
+          using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] 4
+          by (smt (verit, ccfv_SIG) diff_add_inverse)
+        also have "... = tps' ! j"
+          using 4 assms(1,2,6,7) 4 True act_onesie tpsL_mvs by simp
+        finally show ?thesis .
+      next
+        case False
+        then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+          using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] 4 diff_add_inverse by auto
+        also have "... = tps' ! j"
+          using 4 assms(2,7) False act_Stay len rs_def that tpsL_mvs'
+          by (smt (z3) add.commute le_add_diff_inverse2)
+        finally show ?thesis .
+      qed
+    next
+      case 5
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,7) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma execute_tmL78_3:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 2"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) (Suc (Suc (exec t <#> jj))) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL78 jj) (0, tps) (Suc (Suc (exec t <#> jj))) = (0, tps')"
+  using assms exe_lt_length tmL78_def execute_tmL78_2 sem_cmdL8_3 by simp
+
+lemma sem_cmdL8_4:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 1)"
+    and "i > Suc (exec t <#> jj)"
+    and "i < TT"
+    and "sim_move t ! jj = 2"
+    and "tps' = tpsL t xs (Suc i) 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "sem (cmdL8 jj) (0, tps) = (0, tps')"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) (cmdL8 jj)"
+    using turing_command_cmdL8[OF assms(1)] turing_commandD(1) by simp
+  show len: "length tps = 2 * k + 3"
+    using assms(2) by simp
+  show "length tps' = 2 * k + 3"
+    using assms(8) by simp
+
+  define rs where "rs = read tps"
+  then have "rs ! 1 \<noteq> \<box>"
+    using assms by (metis not_one_less_zero read_tpsL_1_bounds(1))
+  then show "fst (cmdL8 jj rs) = 0"
+    unfolding cmdL8_def by simp
+
+  have "rs ! (3 + jj) = sim_move t ! jj"
+    using rs_def assms read_tpsL_3 by simp
+  moreover have "sim_move t ! jj = 2"
+    using sim_move_def assms(1,7) direction_to_symbol_less sim_move_nth sim_move_nth_else
+    by simp
+  moreover have "enc_nth (rs ! 1) (k + jj) = 0"
+    using assms rs_def read_tpsL_1_nth_less_2k[OF assms(6), of "k + jj"] sim_move by simp
+  ultimately have "condition8d rs jj"
+    using assms \<open>rs ! 1 \<noteq> \<box>\<close> by simp
+  then have *: "snd (cmdL8 jj rs) =
+    [(rs ! 0, Stay),
+     (rs ! 1, Right),
+     (rs ! 2, Stay)] @
+     (map (\<lambda>j. (rs ! (j + 3), Stay)) [0..<k]) @
+     (map (\<lambda>j. (rs ! (3 + k + j), Stay)) [0..<k])"
+    unfolding cmdL8_def by auto
+
+  show "act (cmdL8 jj (read tps) [!] j) (tps ! j) = tps' ! j" if "j < 2 * k + 3" for j
+  proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using "*" act_Stay append.simps(2) assms len nth_Cons_0 rs_def that tpsL_0 by metis
+    next
+      case 2
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 1) (tps ! 1)"
+        by simp
+      also have "... = act (rs ! 1, Right) (tps ! 1)"
+        using * rs_def by simp
+      also have "... = tps' ! 1"
+        using act_Right len rs_def assms tpsL_1 that tpsL_pos_1 2
+        by (metis add.commute fst_conv plus_1_eq_Suc)
+      also have "... = tps' ! j"
+        using 2 by simp
+      finally show ?thesis .
+    next
+      case 3
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (cmdL8 jj (read tps) [!] 2) (tps ! 2)"
+        by simp
+      also have "... = act (rs ! 2, Stay) (tps ! 2)"
+        using * rs_def by simp
+      also have "... = tps ! 2"
+        using act_Stay len rs_def by simp
+      also have "... = tps' ! 2"
+        using assms(2,8) tpsL_2 by simp
+      also have "... = tps' ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,8) tpsL_mvs' 4 by simp
+      finally show ?thesis .
+    next
+      case 5
+      then have "act (cmdL8 jj (read tps) [!] j) (tps ! j) = act (rs ! j, Stay) (tps ! j)"
+        using * rs_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+      also have "... = tps ! j"
+        using len act_Stay rs_def that by simp
+      also have "... = tps' ! j"
+        using assms(2,8) tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+lemma execute_tmL78_4:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 2"
+    and "tt \<ge> Suc (Suc (exec t <#> jj))"
+    and "tt \<le> TT"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL78 jj) (0, tps) tt = (0, tps')"
+  using assms(6,7,8)
+proof (induction tt arbitrary: tps' rule: nat_induct_at_least)
+  case base
+  then show ?case
+    using assms(1-5) execute_tmL78_3 by simp
+next
+  case (Suc tt)
+  then have "tt < TT"
+    by simp
+  let ?xs = "xs[jj:=(1, Some 1)]"
+  let ?tps = "tpsL t ?xs tt 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  have "execute (tmL78 jj) (0, tps) (Suc tt) = exe (tmL78 jj) (execute (tmL78 jj) (0, tps) tt)"
+    by simp
+  also have "... = exe (tmL78 jj) (0, ?tps)"
+    using Suc by simp
+  also have "... = sem (cmdL8 jj) (0, ?tps)"
+    using tmL78_def exe_lt_length by simp
+  then show ?case
+    using sem_cmdL8_4[where ?i=tt] assms Suc by simp
+qed
+
+lemma execute_tmL78_5:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 2"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "execute (tmL78 jj) (0, tps) (Suc TT) = (1, tps')"
+proof -
+  have *: "TT \<ge> Suc (Suc (exec t <#> jj))"
+    using exec_pos_less_TT sim_move assms(1,5)
+    by (metis Suc_leI add_2_eq_Suc' add_diff_cancel_left' plus_1_eq_Suc)
+  have "execute (tmL78 jj) (0, tps) (Suc TT) = exe (tmL78 jj) (execute (tmL78 jj) (0, tps) TT)"
+    by simp
+  also have "... = exe (tmL78 jj) (0, tps')"
+    using execute_tmL78_4[OF assms(1-5) *] assms(6) by simp
+  also have "... = sem (cmdL8 jj) (0, tps')"
+    using tmL78_def exe_lt_length by simp
+  finally show ?thesis
+    using assms(1,3,6) sem_cmdL8_TT by simp
+qed
+
+lemma tmL78_right:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 2"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL78 jj) tps esL78 tps'"
+proof
+  have len: "length esL78 = Suc TT"
+    using esL78_def by simp
+  show "execute (tmL78 jj) (0, tps) (length esL78) = (length (tmL78 jj), tps')"
+    using len execute_tmL78_5 assms tmL78_def by simp
+  show "fst (execute (tmL78 jj) (0, tps) tt) < length (tmL78 jj)"
+    if "tt < length esL78" for tt
+  proof -
+    have "tt < Suc TT"
+      using that len by simp
+    then consider
+        "tt \<le> exec t <#> jj"
+      | "tt = Suc (exec t <#> jj)"
+      | "tt = Suc (Suc (exec t <#> jj))"
+      | "tt > Suc (Suc (exec t <#> jj))"
+      by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using assms execute_tmL78_1 tmL78_def by simp
+    next
+      case 2
+      then show ?thesis
+        using assms execute_tmL78_2 tmL78_def by simp
+    next
+      case 3
+      then show ?thesis
+        using assms execute_tmL78_3 tmL78_def by simp
+    next
+      case 4
+      then show ?thesis
+        using assms execute_tmL78_4 tmL78_def `tt < Suc TT` by simp
+    qed
+  qed
+  show "execute (tmL78 jj) (0, tps) (Suc tt) <#> 0 = fst (esL78 ! tt) \<and>
+        execute (tmL78 jj) (0, tps) (Suc tt) <#> 1 = snd (esL78 ! tt)"
+        if "tt < length esL78" for tt
+  proof -
+    have *: "Suc tt \<le> Suc TT"
+      using that esL78_def by simp
+    then consider
+        "Suc tt \<le> exec t <#> jj"
+      | "Suc tt = Suc (exec t <#> jj)"
+      | "Suc tt = Suc (Suc (exec t <#> jj))"
+      | "Suc tt > Suc (Suc (exec t <#> jj)) \<and> Suc tt \<le> TT"
+      | "Suc tt = Suc TT"
+       by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "esL78 ! tt = (n + 1, Suc tt)"
+        using nth_map_upt_TT esL78_def by (metis "*" assms(1) exec_pos_less_TT nat_less_le not_less_eq_eq)
+      then show ?thesis
+        using execute_tmL78_1[OF assms(1-5), where ?tt="Suc tt"] tmL78_def tpsL_pos_0 tpsL_pos_1 * 1
+        by simp
+    next
+      case 2
+      then show ?thesis
+        using assms execute_tmL78_2[OF assms(1-5)] tmL78_def tpsL_pos_0 tpsL_pos_1 *
+        by (metis (no_types, lifting) esL78_def exec_pos_less_TT fst_conv nat.inject nth_map_upt_TT snd_conv)
+    next
+      case 3
+      then have "tt < TT"
+        by (metis add_2_eq_Suc' assms(1) assms(5) diff_Suc_1 exec_pos_less_TT sim_move)
+      then have "esL78 ! tt = (n + 1, Suc tt)"
+        using nth_map_upt_TT esL78_def by auto
+      then show ?thesis
+        using assms(6) execute_tmL78_3[OF assms(1-5)] tmL78_def tpsL_pos_0 tpsL_pos_1 *
+        using 3 by simp
+    next
+      case 4
+      then have **: "Suc tt \<ge> Suc (Suc (exec t <#> jj))"
+        by simp
+      show ?thesis
+        using execute_tmL78_4[OF assms(1-5) **] tmL78_def tpsL_pos_0 tpsL_pos_1 esL78_def
+        by (metis "4" Suc_le_lessD fst_conv nth_map_upt_TT snd_conv)
+    next
+      case 5
+      then have "esL78 ! tt = (n + 1, TT)"
+        using esL78_def by (simp add: nth_append)
+      then show ?thesis
+        using assms(6) execute_tmL78_5[OF assms(1-5)] tmL78_def tpsL_pos_0 tpsL_pos_1 esL78_def 5
+        by simp
+    qed
+  qed
+qed
+
+lemma zip_cont_Stay:
+  assumes "jj < k"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 1"
+  shows "zip_cont t xs = zip_cont t (xs[jj:=(1, Some 1)])"
+proof
+  fix i
+  let ?xs = "xs[jj := (1, Some 1)]"
+  show "zip_cont t xs i = zip_cont t ?xs i"
+  proof (cases "i < TT")
+    case True
+    then show ?thesis
+    proof (rule zip_cont_eqI)
+      show "\<And>j. j < k \<Longrightarrow>
+          (exec (t + fst (xs ! j)) <:> j) i = (exec (t + fst (?xs ! j)) <:> j) i"
+        using True assms nth_list_update fst_conv by metis
+      show "\<And>j. j < k \<Longrightarrow>
+          (case snd (xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) =
+          (case snd (?xs ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0)"
+        using assms sim_move
+        by (metis (no_types, lifting) add.commute add.right_neutral add_diff_cancel_right'
+          nth_list_update_eq nth_list_update_neq option.simps(5) plus_1_eq_Suc snd_conv)
+    qed
+  next
+    case False
+    then show ?thesis
+      by (simp add: zip_cont_def)
+  qed
+qed
+
+lemma tpsL_Stay:
+  assumes "jj < k"
+    and "tps = tpsL t xs i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (1, Some 0)"
+    and "sim_move t ! jj = 1"
+  shows "tps = tpsL t (xs[jj:=(1, Some 1)]) i 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+proof -
+  let ?lhs = "((\<lfloor>zs\<rfloor>, n + 1) #
+      (zip_cont t xs, i) #
+      \<lceil>fst (exec (t + 1))\<rceil> #
+      map (onesie \<circ> (!) (sim_move t)) [0..<k] @
+      map (onesie \<circ> (!) (sim_write t)) [0..<k])"
+  let ?xs = "xs[jj:=(1, Some 1)]"
+  let ?rhs = "((\<lfloor>zs\<rfloor>, n + 1) #
+      (zip_cont t ?xs, i) #
+      \<lceil>fst (exec (t + 1))\<rceil> #
+      map (onesie \<circ> (!) (sim_move t)) [0..<k] @
+      map (onesie \<circ> (!) (sim_write t)) [0..<k])"
+  have "?lhs = ?rhs"
+  proof (intro nth_equalityI)
+    show "length ?lhs = length ?rhs"
+      by simp
+    show "?lhs ! j = ?rhs ! j" if "j < length ?lhs" for j
+    proof -
+      consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+        using `j < length ?lhs` by fastforce
+      then show ?thesis
+        using zip_cont_Stay assms by (cases) auto
+    qed
+  qed
+  then show ?thesis
+    using assms tpsL_def by simp
+qed
+
+definition "esL48 \<equiv> esL47 @ esL78"
+
+lemma len_esL48: "length esL48 = 3 * TT + 3"
+  using len_esL47 esL48_def esL78_def by simp
+
+lemma tmL48_left:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (0, Some 0)"
+    and "sim_move t ! jj = 0"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL48 jj) tps esL48 tps'"
+  unfolding tmL48_def esL48_def
+  using assms
+  by (intro traces_sequential[OF tmL47_left tmL78_nonright[where ?xs="xs[jj:=(1, Some 1)]"]]) simp_all
+
+lemma tmL48_right:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (0, Some 0)"
+    and "sim_move t ! jj = 2"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL48 jj) tps esL48 tps'"
+  unfolding tmL48_def esL48_def
+  using assms
+  by (intro traces_sequential[OF tmL47_nonleft tmL78_right[where ?xs="xs[jj:=(1, Some 0)]"]]) simp_all
+
+lemma tmL48_stay:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (0, Some 0)"
+    and "sim_move t ! jj = 1"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL48 jj) tps esL48 tps'"
+proof -
+  let ?xs = "xs[jj:=(1, Some 0)]"
+  let ?tps = "tpsL t ?xs TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  have "traces (tmL48 jj) tps esL48 ?tps"
+    unfolding tmL48_def esL48_def
+    using assms
+    by (intro traces_sequential[OF tmL47_nonleft tmL78_nonright[where ?xs="?xs"]]) simp_all
+  then show ?thesis
+    using tpsL_Stay[where ?xs="?xs"] assms by simp
+qed
+
+lemma tmL48:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (0, Some 0)"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL48 jj) tps esL48 tps'"
+proof -
+  consider "sim_move t ! jj = 0" | "sim_move t ! jj = 1" | "sim_move t ! jj = 2"
+    using direction_to_symbol_less sim_move_def assms(1) sim_move_nth sim_move_nth_else
+    by (metis (no_types, lifting) One_nat_def Suc_1 less_Suc_eq less_nat_zero_code numeral_3_eq_3)
+  then show ?thesis
+    using assms tmL48_left tmL48_right tmL48_stay
+    by (cases) simp_all
+qed
+
+definition "esL49 \<equiv> esL48 @ map (\<lambda>i. (n + 1, i)) (rev [0..<TT]) @ [(n + 1, 0)]"
+
+lemma len_esL49: "length esL49 = 4 * TT + 4"
+  using len_esL48 esL49_def by simp
+
+lemma tmL49:
+  assumes "jj < k"
+    and "tps = tpsL t xs 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+    and "length xs = k"
+    and "xs ! jj = (0, Some 0)"
+    and "tps' = tpsL t (xs[jj:=(1, Some 1)]) 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL49 jj) tps esL49 tps'"
+  unfolding tmL49_def esL49_def
+proof (rule traces_sequential)
+  let ?tps = "tpsL t (xs[jj:=(1, Some 1)]) TT 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  show "traces (tmL48 jj) tps esL48 ?tps"
+    using assms tmL48 by simp
+  show "traces tm_left_until1 ?tps (map (Pair (n + 1)) (rev [0..<Suc (fmt n)]) @ [(n + 1, 0)]) tps'"
+  proof (rule traces_tm_left_until_1I)
+    show "1 < length ?tps"
+      by simp
+    show "begin_tape {y. y < G ^ (2 * k + 2) + 2 \<and> 1 < y \<and> dec y ! (2 * k + 1) = 1} (?tps ! 1)"
+      using tpsL_1 begin_tape_zip_cont by simp
+    show "map (Pair (n + 1)) (rev [0..<Suc (fmt n)]) @ [(n + 1, 0)] =
+        map (Pair (?tps :#: 0)) (rev [0..< ?tps :#: 1]) @ [(?tps :#: 0, 0)]"
+      using tpsL_pos_0 tpsL_pos_1 by presburger
+    show "tps' = ?tps [1 := ?tps ! 1 |#=| 0]"
+      using assms tpsL_def by simp
+  qed
+qed
+
+definition xs49 :: "nat \<Rightarrow> (nat \<times> nat option) list" where
+  "xs49 j \<equiv> replicate j (1, Some 1) @ replicate (k - j) (0, Some 0)"
+
+lemma length_xs49: "j \<le> k \<Longrightarrow> length (xs49 j) = k"
+  using xs49_def by simp
+
+lemma xs49_less:
+  assumes "j \<le> k" and "i < j"
+  shows "xs49 j ! i = (1, Some 1)"
+  unfolding xs49_def using assms by (simp add: nth_append)
+
+lemma xs49_ge:
+  assumes "j \<le> k" and "i \<ge> j" and "i < k"
+  shows "xs49 j ! i = (0, Some 0)"
+  unfolding xs49_def using assms by (simp add: nth_append)
+
+lemma xs49_upd:
+  assumes "j < k"
+  shows "xs49 (Suc j) = (xs49 j)[j := (1, Some 1)]"
+    (is "?lhs = ?rhs")
+proof (rule nth_equalityI)
+  show "length ?lhs = length ?rhs"
+    by (simp add: Suc_leI assms length_xs49 less_imp_le_nat)
+  show "\<And>i. i < length ?lhs \<Longrightarrow> ?lhs ! i = ?rhs ! i"
+    using length_xs49 assms xs49_ge xs49_less
+    by (metis less_Suc_eq less_or_eq_imp_le not_less nth_list_update)
+qed
+
+lemma tmL49_upt:
+  assumes "j \<le> k"
+    and "tps' = tpsL t (xs49 j) 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL49_upt j) (tpsL4 t) (concat (replicate j esL49)) tps'"
+  using assms
+proof (induction j arbitrary: tps')
+  case 0
+  then show ?case
+    using xs49_def tpsL4_def assms by auto
+next
+  case (Suc j)
+  then have "j < k"
+    by simp
+  let ?tps = "tpsL t (xs49 j) 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  have "tmL49_upt (Suc j) = tmL49_upt j ;; tmL49 j"
+    by simp
+  moreover have "concat (replicate (Suc j) esL49) = concat (replicate j esL49) @ esL49"
+    by (smt (z3) append.assoc append_replicate_commute append_same_eq concat.simps(2) concat_append
+      replicate.simps(2))
+  moreover have "traces (tmL49_upt j ;; tmL49 j) (tpsL4 t) (concat (replicate j esL49) @ esL49) tps'"
+  proof (rule traces_sequential)
+    show "traces (tmL49_upt j) (tpsL4 t) (concat (replicate j esL49)) ?tps"
+       using Suc by simp
+    show "traces (tmL49 j) ?tps esL49 tps'"
+      using tmL49[OF `j < k`, where ?tps="?tps"] length_xs49 xs49_upd Suc \<open>j < k\<close> xs49_ge
+      by simp
+  qed
+  ultimately show ?case
+    by simp
+qed
+
+definition "esL49_upt \<equiv> concat (replicate k esL49)"
+
+lemma length_concat_replicate: "length (concat (replicate m xs)) = m * length xs"
+  by (induction m) simp_all
+
+lemma len_esL49_upt: "length esL49_upt = k * (4 * TT + 4)"
+  using len_esL49 esL49_upt_def length_concat_replicate[of k esL49] by simp
+
+corollary tmL49_upt':
+  assumes "tps' = tpsL t (xs49 k) 0 1 (\<lambda>j. sim_move t ! j) (\<lambda>j. sim_write t ! j)"
+  shows "traces (tmL49_upt k) (tpsL4 t) esL49_upt tps'"
+  using tmL49_upt[of k] assms esL49_upt_def by simp
+
+definition "esL9 t \<equiv> esL4 t @ esL49_upt"
+
+lemma len_esL9: "length (esL9 t) = k * (4 * TT + 4) + t + 2 * TT + 4"
+  using len_esL4 len_esL49_upt esL9_def by simp
+
+lemma xs49_k: "xs49 k = replicate k (1, Some 1)"
+  using xs49_def by simp
+
+definition "tpsL9 t \<equiv> tpsL
+  t
+  (replicate k (1, Some 1))
+  0
+  1
+  (\<lambda>j. sim_move t ! j)
+  (\<lambda>j. sim_write t ! j)"
+
+lemma tmL9:
+  assumes "t < TT"
+  shows "traces tmL9 (tpsL0 t) (esL9 t) (tpsL9 t)"
+  unfolding tmL9_def esL9_def
+  using assms tmL4 tmL49_upt'
+  by (intro traces_sequential) (auto simp add: tpsL9_def xs49_k)
+
+definition "esL10 t \<equiv> esL9 t @ esC t"
+
+lemma len_esL10: "length (esL10 t) = k * (4 * TT + 4) + 2 * t + 2 * TT + 5"
+  using len_esL9 len_esL9 esL10_def esC_def by simp
+
+definition "tpsL10 t \<equiv> tpsL
+  t
+  (replicate k (1, Some 1))
+  t
+  1
+  (\<lambda>j. sim_move t ! j)
+  (\<lambda>j. sim_write t ! j)"
+
+lemma tmL10:
+  assumes "t < TT"
+  shows "traces tmL10 (tpsL0 t) (esL10 t) (tpsL10 t)"
+  unfolding tmL10_def esL10_def
+proof (rule traces_sequential[OF tmL9[OF assms]])
+  have "t \<le> TT"
+    using assms by simp
+  then show "traces tmC (tpsL9 t) (esC t) (tpsL10 t)"
+    using tmC_general tpsL9_def tpsL10_def by simp
+qed
+
+definition "tpsL11 t \<equiv> tpsL
+  (Suc t)
+  (replicate k (0, Some 0))
+  t
+  0
+  (\<lambda>j. sim_move t ! j)
+  (\<lambda>j. sim_write t ! j)"
+
+lemma enc_upd_2k:
+  assumes "dec n = (map f [0..<k] @ map h [0..<k] @ [a, b])"
+  shows "enc_upd n (2 * k) 1 = enc (map f [0..<k] @ map h [0..<k] @ [1, b])"
+  using assms enc_upd_def by (metis append_assoc list_update_length nth_list_update_neq twok_nth)
+
+lemma enc_upd_zip_cont:
+  assumes "t < TT"
+    and "xs1 = replicate k (1, Some 1)"
+    and "xs0 = (replicate k (0, Some 0))"
+  shows "enc_upd (zip_cont t xs1 t) (2 * k) 1 = zip_cont (Suc t) xs0 t"
+proof -
+  let ?n = "zip_cont t xs1 t"
+  have xs1: "fst (xs1 ! j) = 1" "snd (xs1 ! j) = Some 1" if "j < k" for j
+    using assms(2) that by simp_all
+  have "zip_cont t xs1 t = enc
+     (map (\<lambda>j. (exec (t + fst (xs1 ! j)) <:> j) t) [0..<k] @
+      map (\<lambda>j. case snd (xs1 ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if t = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [0,
+       if t = 0 then 1 else 0])"
+    using zip_cont_def assms(1) by simp
+  also have "... = enc
+     (map (\<lambda>j. (exec (t + 1) <:> j) t) [0..<k] @
+      map (\<lambda>j. case Some 1 of None \<Rightarrow> 0 | Some d \<Rightarrow> if t = exec (t + d) <#> j then 1 else 0) [0..<k] @
+      [0,
+       if t = 0 then 1 else 0])"
+    using xs1 by (smt (z3) atLeastLessThan_iff map_eq_conv set_upt)
+  finally have 1: "zip_cont t xs1 t = enc
+     (map (\<lambda>j. (exec (Suc t) <:> j) t) [0..<k] @
+      map (\<lambda>j. if t = exec (Suc t) <#> j then 1 else 0) [0..<k] @
+      [0,
+       if t = 0 then 1 else 0])"
+       (is "_ = enc ?ys")
+    by simp
+
+  have xs0: "fst (xs0 ! j) = 0" "snd (xs0 ! j) = Some 0" if "j < k" for j
+    using assms(3) that by simp_all
+  have "zip_cont (Suc t) xs0 t = enc
+     (map (\<lambda>j. (exec (Suc t + fst (xs0 ! j)) <:> j) t) [0..<k] @
+      map (\<lambda>j. case snd (xs0 ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if t = exec (Suc t + d) <#> j then 1 else 0) [0..<k] @
+      [1,
+       if t = 0 then 1 else 0])"
+    using zip_cont_def assms(1) by simp
+  also have "... = enc
+     (map (\<lambda>j. (exec (Suc t) <:> j) t) [0..<k] @
+      map (\<lambda>j. case Some 0 of None \<Rightarrow> 0 | Some d \<Rightarrow> if t = exec (Suc t + d) <#> j then 1 else 0) [0..<k] @
+      [1,
+       if t = 0 then 1 else 0])"
+    using xs0 by (smt (verit, ccfv_SIG) add.right_neutral atLeastLessThan_iff map_eq_conv set_upt)
+  finally have 2: "zip_cont (Suc t) xs0 t = enc
+     (map (\<lambda>j. (exec (Suc t) <:> j) t) [0..<k] @
+      map (\<lambda>j. if t = exec (Suc t) <#> j then 1 else 0) [0..<k] @
+      [1,
+       if t = 0 then 1 else 0])"
+       (is "_ = enc ?zs")
+    by simp
+  moreover have "?zs = ?ys [2 * k := 1]"
+    by (smt (z3) Suc_1 append_assoc diff_zero length_append length_map length_upt list_update_length mult_Suc nat_mult_1)
+  moreover have "?ys = dec ?n"
+    using dec_zip_cont assms by simp
+  ultimately show ?thesis
+    using enc_upd_def 1 by presburger
+qed
+
+lemma enc_upd_zip_cont_upd:
+  assumes "t < TT"
+    and "xs1 = replicate k (1, Some 1)"
+    and "xs0 = (replicate k (0, Some 0))"
+  shows "(zip_cont t xs1) (t:=enc_upd (zip_cont t xs1 t) (2 * k) 1) = zip_cont (Suc t) xs0"
+proof
+  fix i
+  consider "i = t" | "i \<noteq> t \<and> i < TT" | "i \<ge> TT"
+    using assms(1) by linarith
+  then show "((zip_cont t xs1)(t := enc_upd (zip_cont t xs1 t) (2 * k) 1)) i = zip_cont (Suc t) xs0 i"
+  proof (cases)
+    case 1
+    then show ?thesis
+      using enc_upd_zip_cont assms by simp
+  next
+    case 2
+    then have "i \<noteq> t" "i < TT"
+      by simp_all
+    have xs1: "fst (xs1 ! j) = 1" "snd (xs1 ! j) = Some 1" if "j < k" for j
+      using assms(2) that by simp_all
+    have "zip_cont t xs1 i = enc
+      (map (\<lambda>j. (exec (t + fst (xs1 ! j)) <:> j) i) [0..<k] @
+       map (\<lambda>j. case snd (xs1 ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+       [if i < t then 1 else 0,
+        if i = 0 then 1 else 0])"
+      using zip_cont_def assms(1) `i < TT` by simp
+    also have "... = enc
+      (map (\<lambda>j. (exec (t + 1) <:> j) i) [0..<k] @
+       map (\<lambda>j. case Some 1 of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (t + d) <#> j then 1 else 0) [0..<k] @
+       [if i < t then 1 else 0,
+        if i = 0 then 1 else 0])"
+      using xs1 by (smt (z3) atLeastLessThan_iff map_eq_conv set_upt)
+    finally have 1: "zip_cont t xs1 i = enc
+      (map (\<lambda>j. (exec (Suc t) <:> j) i) [0..<k] @
+       map (\<lambda>j. if i = exec (Suc t) <#> j then 1 else 0) [0..<k] @
+       [if i < t then 1 else 0,
+        if i = 0 then 1 else 0])"
+      by simp
+
+    have xs0: "fst (xs0 ! j) = 0" "snd (xs0 ! j) = Some 0" if "j < k" for j
+      using assms(3) that by simp_all
+    have "zip_cont (Suc t) xs0 i = enc
+      (map (\<lambda>j. (exec (Suc t + fst (xs0 ! j)) <:> j) i) [0..<k] @
+       map (\<lambda>j. case snd (xs0 ! j) of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (Suc t + d) <#> j then 1 else 0) [0..<k] @
+       [if i < Suc t then 1 else 0,
+        if i = 0 then 1 else 0])"
+      using zip_cont_def[of "Suc t" "xs0" i] `i < TT` assms(1) by simp
+    also have "... = enc
+      (map (\<lambda>j. (exec (Suc t) <:> j) i) [0..<k] @
+       map (\<lambda>j. case Some 0 of None \<Rightarrow> 0 | Some d \<Rightarrow> if i = exec (Suc t + d) <#> j then 1 else 0) [0..<k] @
+       [if i < Suc t then 1 else 0,
+        if i = 0 then 1 else 0])"
+      using xs0 by (smt (verit, ccfv_SIG) add.right_neutral atLeastLessThan_iff map_eq_conv set_upt)
+    finally have 2: "zip_cont (Suc t) xs0 i = enc
+      (map (\<lambda>j. (exec (Suc t) <:> j) i) [0..<k] @
+       map (\<lambda>j. if i = exec (Suc t) <#> j then 1 else 0) [0..<k] @
+       [if i < t then 1 else 0,
+        if i = 0 then 1 else 0])"
+      using `i \<noteq> t` by simp
+    then show ?thesis
+      using 1 `i \<noteq> t` by simp
+  next
+    case 3
+    then show ?thesis
+      using zip_cont_def assms(1) by simp
+  qed
+qed
+
+lemma sem_cmdL11:
+  assumes "t < TT"
+  shows "sem cmdL11 (0, tpsL10 t) = (1, tpsL11 t)"
+proof (rule semI[of "2 * k + 3"])
+  show "proper_command (2 * k + 3) cmdL11"
+    using cmdL11_def by simp
+  show len: "length (tpsL10 t) = 2 * k + 3" "length (tpsL11 t) = 2 * k + 3"
+    using tpsL10_def tpsL11_def by simp_all
+  show "fst (cmdL11 (read (tpsL10 t))) = 1"
+    using cmdL11_def by simp
+  let ?tps = "tpsL10 t"
+  let ?xs = "replicate k (1::nat, Some 1::nat option)"
+  have tps1: "?tps ! 1 = (zip_cont t ?xs, t)"
+    using tpsL_1 tpsL10_def by simp
+  have tps1': "tpsL11 t ! 1 = (zip_cont (Suc t) (replicate k (0, Some 0)), t)"
+    using tpsL_1 tpsL11_def by simp
+  let ?rs = "read ?tps"
+  have "is_code (?rs ! 1)"
+    using tpsL10_def assms read_tpsL_1_bounds by simp
+  have rs1: "?rs ! 1 = zip_cont t ?xs t"
+    using tps1 read_def tpsL_def tpsL10_def by force
+  show " act (cmdL11 ?rs [!] j) (?tps ! j) = tpsL11 t ! j"
+      if "j < 2 * k + 3" for j
+    proof -
+    consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < 2 * k + 3` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using tpsL10_def tpsL11_def read_tpsL_0 cmdL11_def act_Stay len(1) that tpsL_0
+        by (smt (verit) append_Cons nth_Cons_0 prod.sel(2))
+    next
+      case 2
+      then have "act (cmdL11 ?rs [!] j) (?tps ! j) = act (cmdL11 ?rs [!] 1) (?tps ! 1)"
+        by simp
+      also have "... = act (enc_upd (?rs ! 1) (2 * k) 1, Stay) (?tps ! 1)"
+        using cmdL11_def `is_code (?rs ! 1)` by simp
+      also have "... = (?tps ! 1) |:=| enc_upd (?rs ! 1) (2 * k) 1"
+        by (simp add: act_Stay tps1 "2" act_Stay' len(1) that)
+      also have "... = tpsL11 t ! 1"
+        using enc_upd_zip_cont_upd rs1 tps1' tps1 assms by simp
+      finally show ?thesis
+        using 2 by simp
+    next
+      case 3
+      then have "act (cmdL11 ?rs [!] j) ((?tps) ! j) = act (cmdL11 ?rs [!] 2) (?tps ! 2)"
+        by simp
+      also have "... = act (?rs ! 2, Stay) (?tps ! 2)"
+        using cmdL11_def by simp
+      also have "... = ?tps ! 2"
+        using act_Stay len by simp
+      also have "... = (tpsL11 t) ! 2"
+        using tpsL_2 tpsL11_def tpsL10_def by simp
+      also have "... = (tpsL11 t) ! j"
+        using 3 by simp
+      finally show ?thesis .
+    next
+      case 4
+      then have "act (cmdL11 ?rs [!] j) (?tps ! j) = act (?rs ! j, Stay) (?tps ! j)"
+        using cmdL11_def threeplus2k_2[where ?a="(?rs ! 0, Stay)"] by simp
+      also have "... = (tpsL10 t) ! j"
+        using len act_Stay that by simp
+      also have "... = (tpsL11 t) ! j"
+        using tpsL11_def tpsL10_def tpsL_mvs' 4 by simp
+      finally show ?thesis .
+    next
+      case 5
+      then have "act (cmdL11 ?rs [!] j) (?tps ! j) = act (?rs ! j, Stay) (?tps ! j)"
+        using cmdL11_def threeplus2k_3[where ?a="(?rs ! 0, Stay)"] by simp
+      also have "... = (tpsL10 t) ! j"
+        using len act_Stay that by simp
+      also have "... = (tpsL11 t) ! j"
+        using tpsL11_def tpsL10_def tpsL_symbs' 5 by simp
+      finally show ?thesis .
+    qed
+  qed
+qed
+
+definition "esL11 t \<equiv> esL10 t @ [(n + 1, t)]"
+
+lemma len_esL11: "length (esL11 t) = k * (4 * TT + 4) + 2 * t + 2 * TT + 6"
+  using len_esL10 esL11_def by simp
+
+lemma tmL11:
+  assumes "t < TT"
+  shows "traces tmL11 (tpsL0 t) (esL11 t) (tpsL11 t)"
+  unfolding tmL11_def esL11_def
+proof (rule traces_sequential[OF tmL10[OF assms]])
+  let ?cmd = "[cmdL11]"
+  let ?es = "[(n + 1, t)]"
+  show "traces ?cmd (tpsL10 t) ?es (tpsL11 t)"
+  proof
+    show 1: "execute ?cmd (0, tpsL10 t) (length ?es) = (length ?cmd, tpsL11 t)"
+    proof -
+      have "execute ?cmd (0, tpsL10 t) (length ?es) = exe ?cmd (0, tpsL10 t)"
+        by simp
+      also have "... = sem cmdL11 (0, tpsL10 t)"
+        using exe_lt_length cmdL11_def by simp
+      finally show ?thesis
+        using sem_cmdL11[OF assms] by simp
+    qed
+    show "\<And>i. i < length [(n + 1, t)] \<Longrightarrow>
+          fst (execute ?cmd (0, tpsL10 t) i) < length ?cmd"
+      by simp
+    show "\<And>i. i < length [(n + 1, t)] \<Longrightarrow>
+          execute ?cmd (0, tpsL10 t) (Suc i) <#> 0 = fst (?es ! i) \<and>
+          execute ?cmd (0, tpsL10 t) (Suc i) <#> 1 = snd (?es ! i)"
+      using 1 tpsL11_def tpsL_pos_0 tpsL_pos_1
+      by (metis One_nat_def add.commute fst_conv less_Suc0 list.size(3) list.size(4) nth_Cons_0 plus_1_eq_Suc snd_conv)
+  qed
+qed
+
+definition "esL12 t \<equiv> esL11 t @ map (\<lambda>i. (n + 1, i)) (rev [0..<t]) @ [(n + 1, 0)]"
+
+lemma len_esL12: "length (esL12 t) = k * (4 * TT + 4) + 3 * t + 2 * TT + 7"
+  using len_esL11 esL12_def by simp
+
+definition "tpsL12 t \<equiv> tpsL
+  (Suc t)
+  (replicate k (0, Some 0))
+  0
+  0
+  (\<lambda>j. sim_move t ! j)
+  (\<lambda>j. sim_write t ! j)"
+
+lemma tmL12:
+  assumes "t < TT"
+  shows "traces tmL12 (tpsL0 t) (esL12 t) (tpsL12 t)"
+  unfolding tmL12_def esL12_def
+proof (rule traces_sequential[OF tmL11[OF assms]])
+  show "traces tm_left_until1 (tpsL11 t) (map (Pair (n + 1)) (rev [0..<t]) @ [(n + 1, 0)]) (tpsL12 t)"
+  proof (rule traces_tm_left_until_1I)
+    show "1 < length (tpsL11 t)"
+      using tpsL11_def by simp
+    show "begin_tape {y. y < G ^ (2 * k + 2) + 2 \<and> 1 < y \<and> dec y ! (2 * k + 1) = 1} (tpsL11 t ! 1)"
+      using tpsL_1 begin_tape_zip_cont tpsL11_def by simp
+    show "map (Pair (n + 1)) (rev [0..<t]) @ [(n + 1, 0)] =
+      map (Pair (tpsL11 t :#: 0)) (rev [0..<tpsL11 t :#: 1]) @ [(tpsL11 t :#: 0, 0)]"
+      using tpsL_pos_0 tpsL_pos_1 tpsL11_def by simp
+    show "tpsL12 t = (tpsL11 t)[1 := tpsL11 t ! 1 |#=| 0]"
+      using tpsL12_def tpsL11_def tpsL_def by simp
+  qed
+qed
+
+definition "tpsL13 t \<equiv> tpsL
+    (Suc t)
+    (replicate k (0, Some 0))
+    0
+    0
+    (\<lambda>j. 0)
+    (\<lambda>j. 0)"
+
+definition "esL13 t \<equiv> esL12 t @ [(n + 1, 0)]"
+
+lemma len_esL13: "length (esL13 t) = k * (4 * TT + 4) + 3 * t + 2 * TT + 8"
+  using len_esL12 esL13_def by simp
+
+lemma tmL13:
+  assumes "t < TT"
+  shows "traces tmL13 (tpsL0 t) (esL13 t) (tpsL13 t)"
+  unfolding tmL13_def esL13_def
+proof (rule traces_sequential[OF tmL12[OF assms]])
+  show "traces (tm_write_many {3..<2 * k + 3} 0) (tpsL12 t) [(n + 1, 0)] (tpsL13 t)"
+  proof (rule traces_tm_write_manyI[where ?k="2*k+3"])
+    show "0 \<notin> {3..<2 * k + 3}"
+      by simp
+    show "\<forall>j\<in>{3..<2 * k + 3}. j < 2 * k + 3"
+      by simp
+    show "2 \<le> 2 * k + 3"
+      by simp
+    show "length (tpsL12 t) = 2 * k + 3" "length (tpsL13 t) = 2 * k + 3"
+      using tpsL12_def tpsL13_def length_tpsL by simp_all
+    show "tpsL13 t ! j = tpsL12 t ! j |:=| 0" if "j \<in> {3..<2 * k + 3}" for j
+    proof (cases "j < k + 3")
+      case True
+      then have "3 \<le> j \<and> j < k + 3"
+        using that by simp
+      then show ?thesis
+        using tpsL13_def tpsL12_def tpsL_mvs' onesie_write by simp
+    next
+      case False
+      then have "k + 3 \<le> j \<and> j < 2 * k + 3"
+        using that by simp
+      then show ?thesis
+        using tpsL13_def tpsL12_def tpsL_symbs' onesie_write by simp
+    qed
+    show "tpsL13 t ! j = tpsL12 t ! j" if "j < 2 * k + 3" "j \<notin> {3..<2 * k + 3}" for j
+    proof -
+      from that have "j < 3"
+        by simp
+      then show ?thesis
+        using tpsL13_def tpsL12_def tpsL_def less_Suc_eq numeral_3_eq_3 by auto
+    qed
+    show "[(n + 1, 0)] = [(tpsL12 t :#: 0, tpsL12 t :#: 1)]"
+      using tpsL12_def tpsL_pos_0 tpsL_pos_1 by simp
+  qed
+qed
+
+corollary tmL13':
+  assumes "t < TT"
+  shows "traces tmL13 (tpsC1 t) (esL13 t) (tpsL13 t)"
+  using tmL13 tpsC1_def tpsL0_def assms by simp
+
+definition "esLoop_while t \<equiv>
+  esC t @ [(tpsC1 t :#: 0, tpsC1 t :#: 1)] @ esL13 t @ [(tpsL13 t :#: 0, tpsL13 t :#: 1)]"
+
+definition "esLoop_break \<equiv> (esC TT) @ [(tpsC1 TT :#: 0, tpsC1 TT :#: 1)]"
+
+lemma len_esLoop_while: "length (esLoop_while t) = k * (4 * TT + 4) + 4 * t + 2 * TT + 11"
+  using len_esL13 esC_def esLoop_while_def by simp
+
+lemma tmLoop_while:
+  assumes "t < TT"
+  shows "trace tmLoop (0, tpsC0 t) (esLoop_while t) (0, tpsL13 t)"
+  unfolding tmLoop_def
+proof (rule tm_loop_sem_true_tracesI[OF tmC tmL13'])
+  show "t \<le> TT" and "t < TT"
+    using assms by simp_all
+  show "0 < read (tpsC1 t) ! 1"
+    using tpsC1_def read_tpsL_1_bounds(1) assms by (metis gr0I not_one_less_zero)
+  show "esLoop_while t =
+      esC t @ [(tpsC1 t :#: 0, tpsC1 t :#: 1)] @ esL13 t @ [(tpsL13 t :#: 0, tpsL13 t :#: 1)]"
+    using esLoop_while_def by simp
+qed
+
+lemma tmLoop_while_end:
+  "trace tmLoop (0, tpsC0 0) (concat (map esLoop_while [0..<TT])) (0, tpsC0 TT)"
+proof (rule tm_loop_trace_simple)
+  have "tpsL13 t = tpsC0 (Suc t)" if "t < TT" for t
+    using tpsL13_def tpsC0_def by simp
+  then show "trace tmLoop (0, tpsC0 i) (esLoop_while i) (0, tpsC0 (Suc i))" if "i < TT" for i
+    using tmLoop_while that by simp
+qed
+
+lemma len_esLoop_break: "length esLoop_break = TT + 2"
+  using esLoop_break_def esC_def by simp
+
+lemma tmLoop_break: "traces tmLoop (tpsC0 TT) esLoop_break (tpsC1 TT)"
+  unfolding tmLoop_def
+proof (rule tm_loop_sem_false_traces[OF tmC])
+  show "TT \<le> TT"
+    by simp
+  show "\<not> 0 < read (tpsC1 TT) ! 1"
+    using read_tpsL_1 tpsC1_def by simp
+  show "esLoop_break = esC (TT) @ [(tpsC1 TT :#: 0, tpsC1 TT :#: 1)]"
+    using esLoop_break_def by simp
+qed
+
+definition "esLoop \<equiv> concat (map esLoop_while [0..<TT]) @ esLoop_break"
+
+lemma len_esLoop1: "u \<le> TT \<Longrightarrow> length (concat (map esLoop_while [0..<u])) \<le> u * (k * (4 * TT + 4) + 4 * TT + 2 * TT + 11)"
+  using len_esLoop_while by (induction u) simp_all
+
+lemma len_esLoop2: "length (concat (map esLoop_while [0..<TT])) \<le> TT * (k * (4 * TT + 4) + 4 * TT + 2 * TT + 11)"
+  using len_esLoop1[of TT] by simp
+
+lemma len_esLoop3: "length esLoop \<le> TT * (k * (4 * TT + 4) + 4 * TT + 2 * TT + 11) + TT + 2"
+  using len_esLoop2 esC_def esLoop_def esLoop_break_def by simp
+
+lemma len_esLoop: "length esLoop \<le> 28 * k * TT * TT"
+proof -
+  have "length esLoop \<le> TT * (k * (4 * TT + 4) + 4 * TT + 2 * TT + 11) + TT + 2"
+    using len_esLoop3 .
+  also have "... = TT * (k * (4 * TT + 4) + 6 * TT + 11) + TT + 2"
+    by simp
+  also have "... \<le> TT * (k * (4 * TT + 4) + 6 * TT + 11) + 3 * TT"
+    by simp
+  also have "... = TT * k * (4 * TT + 4) + TT * 6 * TT + TT * 11 + 3 * TT"
+    by algebra
+  also have "... = TT * k * (4 * TT + 4) + TT * 6 * TT + 14 * TT"
+    by simp
+  also have "... = k * 4 * TT * TT + k * 4 * TT + 6 * TT * TT + 14 * TT"
+    by algebra
+  also have "... \<le> k * 4 * TT * TT + k * 4 * TT * TT + 6 * TT * TT + 14 * TT * TT"
+    by simp
+  also have "... = (k * 4 + k * 4 + 6 + 14) * TT * TT"
+    by algebra
+  also have "... = (k * 8 + 20) * TT * TT"
+    by algebra
+  also have "... \<le> 28 * k * TT * TT"
+  proof -
+    have "k * 8 + 20 \<le> 28 * k"
+      using k_ge_2 by simp
+    then show ?thesis
+      by (meson mult_le_mono1)
+  qed
+  finally show ?thesis
+    by simp
+qed
+
+lemma tmLoop: "traces tmLoop (tpsC0 0) esLoop (tpsC1 TT)"
+  unfolding esLoop_def using traces_additive[OF tmLoop_while_end tmLoop_break] .
+
+lemma tps9_tpsC0: "tps9 = tpsC0 0"
+  using tps9_def tpsC0_def tps9_tpsL by simp
+
+definition "es10 \<equiv> es9 @ esLoop"
+
+lemma len_es10: "length es10 \<le> length (es_fmt n) + 40 * k * TT * TT"
+proof -
+  have "length es10 \<le> length (es_fmt n) + 2 * TT + 2 * n + 8 + 28 * k * TT * TT"
+    using len_es9 len_esLoop es10_def by simp
+  also have "... \<le> length (es_fmt n) + 2 * TT + 2 * TT + 8 + 28 * k * TT * TT"
+  proof -
+    have "2 * n \<le> 2 * TT"
+      using fmt_ge_n Suc_mult_le_cancel1 le_SucI numeral_2_eq_2 by metis
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<le> length (es_fmt n) + 12 * TT * TT + 28 * k * TT * TT"
+    by simp
+  also have "... \<le> length (es_fmt n) + 12 * k * TT * TT + 28 * k * TT * TT"
+  proof -
+    have "12 \<le> 12 * k"
+      using k_ge_2 by simp
+    then have "12 * TT * TT \<le> 12 * k * TT * TT"
+      using mult_le_mono1 by presburger
+    then show ?thesis
+      by simp
+  qed
+  also have "... = length (es_fmt n) + 40 * k * TT * TT"
+    by linarith
+  finally show ?thesis .
+qed
+
+lemma tm10: "traces tm10 tps0 es10 (tpsC1 TT)"
+  unfolding tm10_def es10_def
+  using traces_sequential[OF tm9] tps9_tpsC0 tmLoop
+  by simp
+
+
+subsubsection \<open>Cleaning up the output\<close>
+
+abbreviation "tps10 \<equiv> tpsC1 TT"
+
+definition "es11 \<equiv> es10 @ map (\<lambda>i. (n + 1, i)) (rev [0..<TT]) @ [(n + 1, 0)]"
+
+lemma len_es11: "length es11 \<le> length (es_fmt n) + 40 * k * TT * TT + Suc TT"
+  using es11_def len_es10 by simp
+
+definition "tps11 \<equiv> tps10[1 := ltransplant (tps10 ! 1) (tps10 ! 1) ec1 TT]"
+
+lemma tm11: "traces tm11 tps0 es11 tps11"
+  unfolding tm11_def es11_def
+proof (rule traces_sequential[OF tm10])
+  show "traces
+     (tm_ltrans_until 1 1 StartSym ec1)
+     (tpsC1 (Suc (fmt n)))
+     (map (Pair (n + 1)) (rev [0..<Suc (fmt n)]) @ [(n + 1, 0)]) tps11"
+  proof (rule traces_tm_ltrans_until_11I[where ?n=TT and ?G=G'])
+    show "1 < length (tpsC1 (Suc (fmt n)))"
+      using tpsC1_def by simp
+    show "\<forall>h<G'. ec1 h < G'"
+      using ec1 by simp
+    show "lneigh (tps10 ! 1) StartSym TT"
+      using begin_tape_def begin_tape_zip_cont tpsC1_def tpsL_def by (intro lneighI) simp_all
+    show "Suc (fmt n) \<le> tpsC1 (Suc (fmt n)) :#: 1"
+      using tpsC1_def tpsL_def by simp
+    show "map (Pair (n + 1)) (rev [0..<TT]) @ [(n + 1, 0)] =
+        map (\<lambda>i. (tps10 :#: 0, tps10 :#: 1 - Suc i)) [0..<TT] @ [(tps10 :#: 0, tps10 :#: 1 - TT)]"
+    proof -
+      have 1: "tps10 :#: 0 = n + 1"
+        using tpsC1_def tpsL_pos_0 by simp
+      moreover have 2: "tps10 :#: 1 = TT"
+        using tpsC1_def tpsL_pos_1 by simp
+      ultimately have "map (\<lambda>i. (tps10 :#: 0, tps10 :#: 1 - Suc i)) [0..<TT] = map (\<lambda>i. (n + 1, TT - Suc i)) [0..<TT]"
+        by simp
+      moreover have "map (\<lambda>i. (c1, c2 - Suc i)) [0..<c2] = map (Pair c1) (rev [0..<c2])" for c1 c2 :: nat
+        by (intro nth_equalityI, simp)
+         (metis (no_types, lifting) add_cancel_left_left add_lessD1 diff_less diff_zero
+          length_map length_upt nth_map_upt rev_map rev_nth zero_less_Suc)
+      ultimately have "map (\<lambda>i. (tps10 :#: 0, tps10 :#: 1 - Suc i)) [0..<TT] = map (Pair (n + 1)) (rev [0..<TT])"
+        by metis
+      then show ?thesis
+        using 1 2 by simp
+    qed
+    show "tps11 = (tpsC1 TT) [1 := ltransplant (tpsC1 TT ! 1) (tpsC1 TT ! 1) ec1 TT]"
+      using tps11_def by simp
+  qed
+qed
+
+definition "es12 \<equiv> es11 @ [(n + 1, 1)]"
+
+text \<open>
+The upper bound on the length of the trace will help us establish an upper bound
+of the total running time.
+\<close>
+
+lemma length_es12: "length es12 \<le> length (es_fmt n) + 43 * k * TT * TT"
+proof -
+  have "length es12 \<le> length (es_fmt n) + 40 * k * TT * TT + 3 * TT * TT"
+    using es12_def len_es11 by simp
+  moreover have "3 * TT * TT \<le> 3 * k * TT * TT"
+  proof -
+    have "3 \<le> 3 * k"
+      using k_ge_2 by simp
+    then show ?thesis
+      by (meson mult_le_mono1)
+  qed
+  ultimately show ?thesis
+    by linarith
+qed
+
+definition "tps12 \<equiv> tps11[1 := tps11 ! 1 |:=| (ec1 (tps11 :.: 1)) |+| 1]"
+
+lemma tm12: "traces tm12 tps0 es12 tps12"
+  unfolding tm12_def es12_def
+proof (rule traces_sequential[OF tm11])
+  show "traces (tm_rtrans 1 ec1) tps11 [(n + 1, 1)] tps12"
+  proof (rule traces_tm_rtrans_1I)
+    show "1 < length tps11"
+      using tps11_def tpsC1_def by simp
+    show "[(n + 1, 1)] = [(tps11 :#: 0, tps11 :#: 1 + 1)]"
+      using tps11_def tpsC1_def tpsL_pos_0 tpsL_pos_1 ltransplant_def by simp
+    show "tps12 = tps11[1 := tps11 ! 1 |:=| ec1 (tps11 :.: 1) |+| 1]"
+      using tps12_def by simp
+  qed
+qed
+
+lemma tps11_0: "(tps11 ::: 1) 0 = (zip_cont TT (replicate k (0, Some 0))) 0"
+  using tps11_def tpsC1_def tpsL_def ltransplant_def by simp
+
+lemma tps11_gr0_exec:
+  assumes "i > 0"
+  shows "(tps11 ::: 1) i = (exec TT <:> 1) i"
+proof -
+  let ?tp = "tps10 ! 1"
+    let ?xs = "replicate k (0, Some 0)"
+  have 1: "tps11 ! 1 = ltransplant ?tp ?tp ec1 TT"
+    using tps11_def tpsC1_def tpsL_def by simp
+  have 2: "tps10 :#: 1 = TT"
+    using tpsC1_def tpsL_def by simp
+  show ?thesis
+  proof (cases "i \<le> TT")
+    case le_TT: True
+    then have "0 < i \<and> i \<le> TT"
+      using assms by simp
+    then have *: "(tps11 ::: 1) i = ec1 (fst ?tp i)"
+      using 1 tpsC1_def tpsL_def ltransplant_def by simp
+    show ?thesis
+    proof (cases "i = TT")
+      case True
+      then have "\<not> is_code ((zip_cont TT ?xs) i)"
+        by (simp add: zip_cont_eq_0)
+      then have "(tps11 ::: 1) i = 0"
+        using * 2 True tpsC1_at_T by simp
+      moreover have "(exec TT <:> 1) TT = 0"
+        using tps_ge_TT_0 by simp
+      ultimately show ?thesis
+        using True by simp
+    next
+      case False
+      then have "i < TT"
+        using le_TT by simp
+      then have "fst ?tp i = (zip_cont TT ?xs) i"
+        using tpsC1_def tpsL_def by simp
+      then have "(tps11 ::: 1) i = ec1 ((zip_cont TT ?xs) i)"
+        using * by simp
+      moreover have "is_code ((zip_cont TT ?xs) i)"
+        using zip_cont_gt_1 zip_cont_less `i < TT` by simp
+      ultimately have "(tps11 ::: 1) i = enc_nth ((zip_cont TT ?xs) i) 1"
+        by simp
+      then have "(tps11 ::: 1) i = (exec TT <:> 1) i"
+        using enc_nth_def dec_zip_cont_less_k[OF `i < TT`] k_ge_2 by simp
+      then show ?thesis
+        by simp
+    qed
+  next
+    case False
+    then have "(tps11 ::: 1) i = 0"
+      using 1 tpsC1_def tpsL_def ltransplant_def zip_cont_eq_0 by force
+    moreover have "(exec TT <:> 1) i = 0"
+      using False tps_ge_TT_0 by simp
+    ultimately show ?thesis
+      by simp
+  qed
+qed
+
+definition "tps12' \<equiv>
+    [(\<lfloor>zs\<rfloor>, n + 1),
+     (exec TT <:> 1, 1),
+     \<lceil>fst (exec TT)\<rceil>] @
+    map (\<lambda>i. \<lceil>\<box>\<rceil>) [0..<k] @
+    map (\<lambda>i. \<lceil>\<box>\<rceil>) [0..<k]"
+
+lemma tps12': "tps12' = tps12"
+proof (rule nth_equalityI)
+  show "length tps12' = length tps12"
+    using tps12'_def tps12_def tps11_def tpsC1_def by simp
+  show "tps12' ! j = tps12 ! j" if "j < length tps12'" for j
+  proof -
+    have "length tps12' = 2 * k + 3"
+      using tps12'_def by simp
+    then consider "j = 0" | "j = 1" | "j = 2" | "3 \<le> j \<and> j < k + 3" | "k + 3 \<le> j \<and> j < 2 * k + 3"
+      using `j < length tps12'` by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        unfolding tps12'_def tps12_def tps11_def tpsC1_def tpsL_def by simp
+    next
+      case 2
+      then have lhs: "tps12' ! j = (\<lambda>i. (exec TT <:> 1) i, 1)"
+        using tps12'_def by simp
+      let ?tp = "tps10 ! 1"
+      let ?xs = "replicate k (0, Some 0)"
+      have "tps11 :#: 1 = 0"
+        using tps11_def ltransplant_def tpsC1_def tpsL_pos_1 by simp
+      have rhs: "tps12 ! j = (ltransplant ?tp ?tp ec1 TT) |:=| (ec1 (tps11 :.: 1)) |+| 1"
+        using tps12_def 2 \<open>length tps12' = length tps12\<close> tps11_def that by simp
+      have tps10: "tps10 ! j = (zip_cont TT ?xs, TT)"
+        using tpsC1_def 2 tpsL_1 by simp
+      show "tps12' ! j = tps12 ! j"
+      proof
+        show "tps12' :#: j = tps12 :#: j"
+          using lhs rhs ltransplant_def tps10 2 by simp
+        have tps12: "tps12 ! 1 = tps11 ! 1 |:=| (ec1 (tps11 :.: 1)) |+| 1"
+          using tps12_def "2" \<open>length tps12' = length tps12\<close> that by auto
+        have "(tps12' ::: 1) i = (tps12 ::: 1) i" for i
+        proof (cases "i = 0")
+          case True
+          then have "(tps12 ::: 1) i = ec1 (tps11 :.: 1)"
+            using tps12 `tps11 :#: 1 = 0` by simp
+          moreover have "(tps11 :.: 1) = (zip_cont TT ?xs) 0"
+            using tps11_0 `tps11 :#: 1 = 0` by simp
+          ultimately have "(tps12 ::: 1) i = ec1 ((zip_cont TT ?xs) 0)"
+            by simp
+          moreover have "is_code ((zip_cont TT ?xs) 0)"
+            using zip_cont_gt_1 zip_cont_less by simp
+          ultimately have "(tps12 ::: 1) i = enc_nth ((zip_cont TT ?xs) 0) 1"
+            by simp
+          then have "(tps12 ::: 1) i = enc_nth (zip_cont TT ?xs i) 1"
+            using True by simp
+          then have "(tps12 ::: 1) i = (exec TT <:> 1) i"
+            using enc_nth_def dec_zip_cont_less_k True k_ge_2 by simp
+          then show ?thesis
+            using tps12'_def by simp
+        next
+          case False
+          then have "(tps12 ::: 1) i = (tps11 ::: 1) i"
+            using tps12 `tps11 :#: 1 = 0` by simp
+          then have "(tps12 ::: 1) i = (exec TT <:> 1) i"
+            using False tps11_gr0_exec by simp
+          moreover have "(tps12' ::: 1) i = (exec TT <:> 1) i"
+            using tps12'_def by simp
+          ultimately show ?thesis
+            by simp
+        qed
+        then show "tps12' ::: j = tps12 ::: j"
+          using 2 by auto
+      qed
+    next
+      case 3
+      then show ?thesis
+        unfolding tps12'_def tps12_def tps11_def tpsC1_def tpsL_def by simp
+    next
+      case 4
+      then show ?thesis
+        unfolding tps12'_def tps12_def tps11_def tpsC1_def
+        using tpsL_mvs' threeplus2k_2[where ?a="(\<lfloor>zs\<rfloor>, n + 1)"]
+        by simp
+    next
+      case 5
+      then show ?thesis
+        unfolding tps12'_def tps12_def tps11_def tpsC1_def
+        using tpsL_symbs' threeplus2k_3[where ?a="(\<lfloor>zs\<rfloor>, n + 1)"]
+        by simp
+    qed
+  qed
+qed
+
+lemma tm12': "traces tm12 tps0 es12 tps12'"
+  using tm12 tps12' by simp
+
+end  (* context for zs *)
+
+
+subsection \<open>Shrinking the Turing machine to two tapes\<close>
+
+text \<open>
+The simulator TM @{const tm12} has $2k + 3$ tapes, of which $2k + 1$ are
+immobile and thus can be removed by the memorization-in-states technique,
+resulting in a two-tape TM.
+\<close>
+
+lemma immobile_tm12:
+  assumes "j > 1" and "j < 2 * k + 3"
+  shows "immobile tm12 j (2 * k + 3)"
+proof -
+  have "immobile tm1 j (2 * k + 3)"
+    unfolding tm1_def
+    using immobile_append_tapes[of j "2*k+3", OF _ _ _ fmt(1)] assms
+    by simp
+  moreover have "immobile tm1_2 j (2 * k + 3)"
+    using tm1_2_def tm_const_until_def immobile_tm_trans_until assms by simp
+  ultimately have "immobile tm2 j (2 * k + 3)"
+    using tm2_def immobile_sequential tm1_2_tm tm1_tm by simp
+  then have "immobile tm3 j (2 * k + 3)"
+    using tm3_def immobile_sequential[OF tm2_tm] tm_start_tm immobile_tm_start assms G'_ge by simp
+  then have "immobile tm4 j (2 * k + 3)"
+    using tm4_def immobile_sequential[OF tm3_tm tm3_4_tm] immobile_tm_write assms by simp
+  then have "immobile tm5 j (2 * k + 3)"
+    using tm5_def immobile_sequential[OF tm4_tm] G'_ge(1) immobile_tm_right tm_right_tm assms by simp
+  then have "immobile tm6 j (2 * k + 3)"
+    using tm6_def immobile_sequential[OF tm5_tm tm5_6_tm] immobile_tm_trans_until tm5_6_def assms by simp
+  then have "immobile tm7 j (2 * k + 3)"
+    using tm7_def immobile_sequential[OF tm6_tm tm_left_until1_tm] immobile_tm_left_until assms by simp
+  then have "immobile tm8 j (2 * k + 3)"
+    using tm8_def immobile_sequential[OF tm7_tm] immobile_tm_write assms G'_ge tm_write_tm by simp
+  then have 9: "immobile tm9 j (2 * k + 3)"
+    using tm9_def immobile_sequential[OF tm8_tm] immobile_tm_write_many tm_write_many_tm k_ge_2 G'_ge assms
+    by simp
+
+  have C: "immobile tmC j (2 * k + 3)"
+    unfolding tmC_def tm_right_until_def tm_cp_until_def
+    using tm_cp_until_tm immobile_tm_trans_until G'_ge(1) assms
+    by simp
+
+  have "cmdL2 rs [~] j = Stay" if "length rs = 2 * k + 3" for rs
+  proof (cases "rs ! 1 = \<box>")
+    case True
+    then show ?thesis
+      using cmdL2_def assms that by simp
+  next
+    case False
+    then consider "j = 2" | "3 \<le> j \<and> j < 3 + k" | "3 + k \<le> j \<and> j < 2 * k + 3"
+      using assms by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using cmdL2_def assms that by simp
+    next
+      case 2
+      then show ?thesis
+        using assms that cmdL2_at_3 False by simp
+    next
+      case 3
+      then show ?thesis
+        using assms that cmdL2_at_4 False by simp
+    qed
+  qed
+  then have "immobile tmL1_2 j (2 * k + 3)"
+    using tmL1_2_def by auto
+  then have "immobile tmL2 j (2 * k + 3)"
+    unfolding tmL2_def tmL1_def
+    using tm_left_until1_tm immobile_tm_left_until tmL2_tm immobile_sequential tmL1_2_tm assms
+    by auto
+  moreover have "cmdL3 rs [~] j = Stay" if "length rs = 2 * k + 3" for rs
+  proof -
+    consider "j = 2" | "3 \<le> j \<and> j < 3 + k" | "3 + k \<le> j \<and> j < 2 * k + 3"
+      using assms by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using cmdL3_def assms that by simp
+    next
+      case 2
+      then show ?thesis
+        using assms that cmdL3_at_3a cmdL3_at_3b
+        by (metis (no_types, lifting) add.commute prod.sel(2))
+    next
+      case 3
+      then show ?thesis
+        using assms that cmdL3_at_4a cmdL3_at_4b
+        by (metis (no_types, lifting) add.commute prod.sel(2))
+    qed
+  qed
+  ultimately have "immobile tmL3 j (2 * k + 3)"
+    unfolding tmL3_def
+    using tmL2_tm immobile_sequential assms tmL2_3_def tmL2_3_tm immobile_def
+    by simp
+  then have L4: "immobile tmL4 j (2 * k + 3)"
+    unfolding tmL4_def
+    using tmL3_tm immobile_sequential assms tm_left_until1_tm immobile_tm_left_until
+    by auto
+
+  have "(cmdL5 jj) rs [~] j = Stay" if "length rs = 2 * k + 3" and "jj < k" for rs jj
+  proof (cases "rs ! 1 = \<box>")
+    case True
+    then show ?thesis
+      using cmdL5_eq_0 assms that by simp
+  next
+    case False
+    then consider "j = 2" | "3 \<le> j \<and> j < 3 + k" | "3 + k \<le> j \<and> j < 2 * k + 3"
+      using assms by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using that by (simp add: cmdL5_def)
+    next
+      case 2
+      then show ?thesis
+        using assms that cmdL5_at_3 False by simp
+    next
+      case 3
+      then show ?thesis
+        using assms that cmdL5_at_4 False by simp
+    qed
+  qed
+  then have "immobile (tmL45 jj) j (2 * k + 3)" if "jj < k" for jj
+    by (auto simp add: that tmL45_def)
+  then have L46: "immobile (tmL46 jj) j (2 * k + 3)" if "jj < k" for jj
+    using tmL46_def immobile_sequential[OF tmL45_tm] tm_left_tm immobile_tm_left assms that k_ge_2 G'_ge by simp
+
+  have "(cmdL7 jj) rs [~] j = Stay" if "length rs = 2 * k + 3" and "jj < k" for rs jj
+  proof -
+    consider (a) "condition7a rs jj" | (b) "condition7b rs jj" | (c) "condition7c rs jj"
+      by blast
+    then show ?thesis
+    proof (cases)
+      case a
+      consider "j = 2" | "3 \<le> j \<and> j < k + 3" | "3 + k \<le> j \<and> j < 2 * k + 3"
+        using assms by linarith
+      then show ?thesis
+        using cmdL7_def a threeplus2k_2[of _ _ "(rs ! 0, Stay)"] threeplus2k_3[of _ _ "(rs ! 0, Stay)"]
+        by (cases) simp_all
+    next
+      case b
+      consider "j = 2" | "3 \<le> j \<and> j < k + 3" | "3 + k \<le> j \<and> j < 2 * k + 3"
+        using assms by linarith
+      then show ?thesis
+        using cmdL7_def b threeplus2k_2[of _ _ "(rs ! 0, Stay)"] threeplus2k_3[of _ _ "(rs ! 0, Stay)"]
+        by (cases) simp_all
+    next
+      case c
+      consider "j = 2" | "3 \<le> j \<and> j < k + 3" | "3 + k \<le> j \<and> j < 2 * k + 3"
+        using assms by linarith
+      then show ?thesis
+        using cmdL7_def c threeplus2k_2[of _ _ "(rs ! 0, Stay)"] threeplus2k_3[of _ _ "(rs ! 0, Stay)"]
+        by (cases) simp_all
+    qed
+  qed
+  then have "immobile (tmL67 jj) j (2 * k + 3)" if "jj < k" for jj
+    by (auto simp add: that tmL67_def)
+  then have L47: "immobile (tmL47 jj) j (2 * k + 3)" if "jj < k" for jj
+    using tmL47_def immobile_sequential[OF tmL46_tm tmL67_tm] L46 assms that by simp
+
+  have "(cmdL8 jj) rs [~] j = Stay" if "length rs = 2 * k + 3" and "jj < k" for rs jj
+  proof -
+    consider (a) "condition8a rs jj" | (b) "condition8b rs jj" | (c) "condition8c rs jj" | (d) "condition8d rs jj"
+      by blast
+    then show ?thesis
+    proof (cases)
+      case a
+      consider "j = 2" | "3 \<le> j \<and> j < k + 3" | "3 + k \<le> j \<and> j < 2 * k + 3"
+        using assms by linarith
+      then show ?thesis
+        using cmdL8_def a threeplus2k_2[of _ _ "(rs ! 0, Stay)"] threeplus2k_3[of _ _ "(rs ! 0, Stay)"]
+        by (cases) simp_all
+    next
+      case b
+      consider "j = 2" | "3 \<le> j \<and> j < k + 3" | "3 + k \<le> j \<and> j < 2 * k + 3"
+        using assms by linarith
+      then show ?thesis
+        using cmdL8_def b threeplus2k_2[of _ _ "(rs ! 0, Stay)"] threeplus2k_3[of _ _ "(rs ! 0, Stay)"]
+        by (cases) simp_all
+    next
+      case c
+      consider "j = 2" | "3 \<le> j \<and> j < k + 3" | "3 + k \<le> j \<and> j < 2 * k + 3"
+        using assms by linarith
+      then show ?thesis
+        using cmdL8_def c threeplus2k_2[of _ _ "(rs ! 0, Stay)"] threeplus2k_3[of _ _ "(rs ! 0, Stay)"]
+        by (cases) simp_all
+    next
+      case d
+      consider "j = 2" | "3 \<le> j \<and> j < k + 3" | "3 + k \<le> j \<and> j < 2 * k + 3"
+        using assms by linarith
+      then show ?thesis
+        using cmdL8_def d threeplus2k_2[of _ _ "(rs ! 0, Stay)"] threeplus2k_3[of _ _ "(rs ! 0, Stay)"]
+        by (cases) simp_all
+    qed
+  qed
+  then have "immobile (tmL78 jj) j (2 * k + 3)" if "jj < k" for jj
+    by (auto simp add: that tmL78_def)
+  then have "immobile (tmL48 jj) j (2 * k + 3)" if "jj < k" for jj
+    using tmL48_def immobile_sequential[OF tmL47_tm tmL78_tm] L47 assms that by simp
+  then have L49: "immobile (tmL49 jj) j (2 * k + 3)" if "jj < k" for jj
+    using tmL49_def immobile_sequential[OF tmL48_tm] tm_left_until1_tm immobile_tm_left_until assms that by simp
+
+  have L49_upt: "immobile (tmL49_upt j') j (2 * k + 3)" if "j' \<le> k" for j'
+    using that
+  proof (induction j')
+    case 0
+    then show ?case
+      by auto
+  next
+    case (Suc j')
+    have "tmL49_upt (Suc j') = tmL49_upt j' ;; tmL49 j'"
+      by simp
+    moreover have "turing_machine (2*k+3) G' (tmL49_upt j')"
+      using tmL49_upt_tm Suc by simp
+    moreover have "immobile (tmL49_upt j') j (2*k+3)"
+      using Suc by simp
+    moreover have "turing_machine (2*k+3) G' (tmL49 j')"
+      using tmL49_tm Suc by simp
+    moreover have "immobile (tmL49 j') j (2*k+3)"
+      using L49 Suc by simp
+    ultimately show ?case
+      using immobile_sequential by simp
+  qed
+  then have "immobile tmL9 j (2 * k + 3)"
+    using tmL9_def immobile_sequential[OF tmL4_tm tmL49_upt_tm] L4 by simp
+  then have L10: "immobile tmL10 j (2 * k + 3)"
+    using tmL10_def immobile_sequential[OF tmL9_tm tmC_tm] C by simp
+
+  have "cmdL11 rs [~] j = Stay" if "length rs = 2 * k + 3" and "jj < k" for rs jj
+  proof -
+    consider "j = 2" | "3 \<le> j \<and> j < 3 + k" | "3 + k \<le> j \<and> j < 2 * k + 3"
+      using assms by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        by (simp add: cmdL11_def)
+    next
+      case 2
+      then show ?thesis
+        using cmdL11_def threeplus2k_2[where ?a="(rs ! 0, Stay)"] by simp
+    next
+      case 3
+      then show ?thesis
+        using cmdL11_def threeplus2k_3[where ?a="(rs ! 0, Stay)"] by simp
+    qed
+  qed
+  then have "immobile [cmdL11] j (2 * k + 3)"
+    using k_ge_2 assms by force
+  then have "immobile tmL11 j (2 * k + 3)"
+    using tmL11_def immobile_sequential[OF tmL10_tm tmL1011_tm] L10 by simp
+  then have "immobile tmL12 j (2 * k + 3)"
+    using tmL12_def immobile_sequential[OF tmL11_tm tm_left_until1_tm] immobile_tm_left_until assms by simp
+  then have "immobile tmL13 j (2 * k + 3)"
+    using tmL13_def immobile_sequential[OF tmL12_tm tm_write_many_tm] immobile_tm_write_many
+      assms k_ge_2 G'_ge(1)
+    by simp
+  then have "immobile tmLoop j (2 * k + 3)"
+    using tmLoop_def C immobile_loop[OF tmC_tm tmL13_tm] assms(2) by simp
+  then have "immobile tm10 j (2 * k + 3)"
+    using tm10_def immobile_sequential[OF tm9_tm tmLoop_tm] 9 by simp
+  then have "immobile tm11 j (2 * k + 3)"
+    using tm11_def immobile_sequential[OF tm10_tm tm_ltrans_until_tm] ec1 G'_ge immobile_tm_ltrans_until assms
+    by simp
+  then show "immobile tm12 j (2 * k + 3)"
+    using tm12_def immobile_sequential[OF tm11_tm tm_rtrans_tm] ec1 G'_ge immobile_tm_rtrans assms by simp
+qed
+
+definition "tps12'' zs \<equiv>
+  [(\<lfloor>zs\<rfloor>, length zs + 1),
+   (exec zs (Suc (fmt (length zs))) <:> 1, 1)]"
+
+lemma tps12'':
+  assumes "bit_symbols zs"
+  shows "tps12'' zs = take 2 (tps12' zs)"
+  using tps12'_def tps12''_def assms by simp
+
+text \<open>
+This is the actual simulator Turing machine we are constructing in this section.
+It is @{const tm12} stripped of all memorization tapes:
+\<close>
+
+definition "tmO2T \<equiv> icartesian (2 * k + 1) tm12 G'"
+
+lemma tmO2T_tm: "turing_machine 2 G' tmO2T"
+  unfolding tmO2T_def
+  using immobile_tm12 tm12_tm icartesian_tm[of "2 * k + 1" G']
+  by (metis (no_types, lifting) One_nat_def Suc_le_lessD add.assoc add_less_mono1 le_add2
+    numeral_3_eq_3 one_add_one plus_1_eq_Suc)
+
+text \<open>
+The constructed two-tape Turing machine computes the same output as the original
+Turing machine.
+\<close>
+
+lemma tmO2T:
+  assumes "bit_symbols zs"
+  shows "traces tmO2T (snd (start_config 2 zs)) (es12 zs) (tps12'' zs)"
+proof -
+  have *: "2 * k + 1 + 2 = 2 * k + 3"
+    by simp
+  then have "turing_machine (2 * k + 1 + 2) G' tm12"
+    using tm12_tm by metis
+  moreover have "\<And>j. j < 2 * k + 1 \<Longrightarrow> immobile tm12 (j + 2) (2 * k + 1 + 2)"
+    using immobile_tm12 immobile_def by simp
+  moreover have "\<forall>i<length zs. zs ! i < G'"
+    using assms G'_ge_G zs_less_G by (meson order_less_le_trans)
+  moreover have "traces tm12 (snd (start_config (2 * k + 1 + 2) zs)) (es12 zs) (tps12' zs)"
+    using tm12' tps0_start_config assms * by (metis (no_types, lifting) prod.sel(2))
+  ultimately show ?thesis
+    using icartesian[of "2 * k + 1" G' tm12 zs "es12 zs" "tps12' zs"] tmO2T_def tps12'' assms by simp
+qed
+
+
+subsection \<open>Time complexity\<close>
+
+text \<open>
+This is the bound for the running time of @{const tmO2T}:
+\<close>
+
+definition TTT :: "nat \<Rightarrow> nat" where
+  "TTT \<equiv> \<lambda>n. length (es_fmt n) + 43 * k * Suc (fmt n) * Suc (fmt n)"
+
+lemma execute_tmO2T:
+  assumes "bit_symbols zs"
+  shows "execute tmO2T (start_config 2 zs) (TTT (length zs)) = (length tmO2T, tps12'' zs)"
+proof -
+  have "trace tmO2T (start_config 2 zs) (es12 zs) (length tmO2T, tps12'' zs)"
+    using tmO2T assms traces_def start_config_def by simp
+  then have "execute tmO2T (start_config 2 zs) (length (es12 zs)) = (length tmO2T, tps12'' zs)"
+    using trace_def by simp
+  moreover have "length (es12 zs) \<le> TTT (length zs)"
+    using assms length_es12 TTT_def by simp
+  ultimately show ?thesis
+    by (metis execute_after_halting_ge fst_conv)
+qed
+
+text \<open>
+The simulator TM @{const tmO2T} halts with the output tape head on cell~1.
+\<close>
+
+lemma execute_tmO2T_1:
+  assumes "bit_symbols zs"
+  shows "execute tmO2T (start_config 2 zs) (TTT (length zs)) <!> 1 =
+    (execute M (start_config k zs) (T (length zs)) <:> 1, 1)"
+proof -
+  have "T (length zs) \<le> Suc (fmt (length zs))"
+    by (metis add_leD1 le_Suc_eq fmt(4) T'_def)
+  then have *: "execute M (start_config k zs) (T (length zs)) =
+      execute M (start_config k zs) (Suc (fmt (length zs)))"
+    using execute_after_halting_ge time_bound_T time_bound_def assms by (metis (no_types, lifting))
+
+  have "execute tmO2T (start_config 2 zs) (TTT (length zs)) = (length tmO2T, tps12'' zs)"
+    using assms execute_tmO2T by simp
+  then have "execute tmO2T (start_config 2 zs) (TTT (length zs)) <!> 1 =
+      (execute M (start_config k zs) (Suc (fmt (length zs))) <:> 1, 1)"
+    using tps12''_def exec_def assms by simp
+  then show ?thesis
+    using * by simp
+qed
+
+lemma poly_TTT: "big_oh_poly TTT"
+proof -
+  have 1: "big_oh_poly (\<lambda>n. length (es_fmt n))"
+    using fmt(2) by simp
+  have "big_oh_poly (\<lambda>n. fmt n + 1)"
+    using fmt(3) big_oh_poly_const big_oh_poly_sum by blast
+  then have "big_oh_poly (\<lambda>n. Suc (fmt n))"
+    by simp
+  then have "big_oh_poly (\<lambda>n. Suc (fmt n) * Suc (fmt n))"
+    using big_oh_poly_prod by blast
+  moreover have "big_oh_poly (\<lambda>n. 43 * k)"
+    using big_oh_poly_const by simp
+  ultimately have "big_oh_poly (\<lambda>n. 43 * k * (Suc (fmt n) * Suc (fmt n)))"
+    using big_oh_poly_prod by blast
+  moreover have "(\<lambda>n. 43 * k * (Suc (fmt n) * Suc (fmt n))) = (\<lambda>n. 43 * k * Suc (fmt n) * Suc (fmt n))"
+    by (metis (mono_tags, opaque_lifting) mult.assoc)
+  ultimately have "big_oh_poly (\<lambda>n. 43 * k * Suc (fmt n) * Suc (fmt n))"
+    by simp
+  then have "big_oh_poly (\<lambda>n. length (es_fmt n) + 43 * k * Suc (fmt n) * Suc (fmt n))"
+    using 1 big_oh_poly_sum by simp
+  then show ?thesis
+    unfolding TTT_def by simp
+qed
+
+
+subsection \<open>Obliviousness\<close>
+
+text \<open>
+The two-tape simulator machine is oblivious.
+\<close>
+
+lemma tmO2T_oblivious:
+  assumes "length zs1 = length zs2" and "bit_symbols zs1" and "bit_symbols zs2"
+  shows "es12 zs1 = es12 zs2"
+proof -
+  have "es1 zs1 = es1 zs2"
+    using es1_def assms by simp
+
+  moreover have "es1_2 zs1 = es1_2 zs2"
+    using es1_2_def assms by (metis (no_types, lifting))
+  ultimately have "es2 zs1 = es2 zs2"
+    using es2_def assms by simp
+  then have "es3 zs1 = es3 zs2"
+    using es3_def assms by simp
+  then have "es4 zs1 = es4 zs2"
+    using es4_def assms by simp
+  then have "es5 zs1 = es5 zs2"
+    using es5_def assms by simp
+  then have "es6 zs1 = es6 zs2"
+    using es6_def assms by simp
+  then have "es7 zs1 = es7 zs2"
+    using es7_def assms by simp
+  then have "es8 zs1 = es8 zs2"
+    using es8_def assms by simp
+  then have 9: "es9 zs1 = es9 zs2"
+    using es9_def assms by simp
+
+  have C: "esC zs1 t = esC zs2 t" for t
+    using esC_def assms by simp
+  then have Loop_break: "esLoop_break zs1 = esLoop_break zs2"
+    using esLoop_break_def tpsC1_def tpsL_def assms by simp
+
+  have "esL1 zs1 = esL1 zs2"
+    using esL1_def assms by auto
+  moreover have "esL1_2 zs1 = esL1_2 zs2"
+    using esL1_2_def assms by simp
+  ultimately have "esL2 zs1 = esL2 zs2"
+    using esL2_def assms by auto
+  then have "esL3 zs1 = esL3 zs2"
+    using esL3_def assms by auto
+  then have L4: "esL4 zs1 = esL4 zs2"
+    using esL4_def assms by auto
+
+  have "esL45 zs1 = esL45 zs2"
+    using esL45_def assms by simp
+  then have "esL46 zs1 = esL46 zs2"
+    using esL46_def assms by simp
+  moreover have "esL67 zs1 = esL67 zs2"
+    using esL67_def assms by simp
+  ultimately have "esL47 zs1 = esL47 zs2"
+    using esL47_def assms by simp
+  moreover have "esL78 zs1 = esL78 zs2"
+    using esL78_def assms by simp
+  ultimately have "esL48 zs1 = esL48 zs2"
+    using esL48_def assms by simp
+  then have "esL49 zs1 = esL49 zs2"
+    using esL49_def assms by simp
+  then have "esL49_upt zs1 = esL49_upt zs2"
+    using esL49_upt_def assms by simp
+  then have "esL9 zs1 = esL9 zs2"
+    using esL9_def L4 assms by auto
+  then have "esL10 zs1 = esL10 zs2"
+    using esL10_def C assms by auto
+  then have "esL11 zs1 = esL11 zs2"
+    using esL11_def assms by auto
+  then have "esL12 zs1 = esL12 zs2"
+    using esL12_def assms by auto
+  then have "esL13 zs1 = esL13 zs2"
+    using esL13_def assms by auto
+  then have "esLoop_while zs1 = esLoop_while zs2"
+    using esLoop_while_def C tpsC1_def tpsL13_def tpsL_def assms by auto
+  then have "esLoop zs1 = esLoop zs2"
+    using esLoop_def Loop_break assms by auto
+  then have "es10 zs1 = es10 zs2"
+    using es10_def 9 assms by auto
+  then have "es11 zs1 = es11 zs2"
+    using es11_def assms by simp
+  then show "es12 zs1 = es12 zs2"
+    using es12_def assms by simp
+qed
+
+end  (* locale two_tape *)
+
+
+section \<open>$\NP$ and obliviousness\label{s:oblivious-np}\<close>
+
+text \<open>
+This section presents the main result of this chapter: For every language $L \in
+\NP$ there is a polynomial-time two-tape oblivious verifier TM that halts with
+the output tape head on a \textbf{1} symbol iff.\ in the input $\langle x,
+u\rangle$, the string $u$ is a certificate for $x$. The proof combines two
+lemmas. First @{thm [source] NP_output_len_1}, which says that we can assume the
+verifier outputs only one symbol (namely, \textbf{0} or \textbf{1}), and second
+@{thm [source] two_tape.execute_tmO2T_1}, which says that the two-tape oblivious
+TM halts with output tape head in cell~1. This cell will contain either
+\textbf{0} or \textbf{1} by the first lemma.
+\<close>
+
+lemma NP_imp_oblivious_2tape:
+  fixes L :: language
+  assumes "L \<in> \<N>\<P>"
+  obtains M G T p where
+    "big_oh_poly T" and
+    "polynomial p" and
+    "turing_machine 2 G M" and
+    "oblivious M" and
+    "\<And>y. bit_symbols y \<Longrightarrow> fst (execute M (start_config 2 y) (T (length y))) = length M" and
+    "\<And>x. x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> execute M (start_config 2 \<langle>x; u\<rangle>) (T (length \<langle>x; u\<rangle>)) <.> 1 = \<one>)"
+proof -
+  define Q where "Q = (\<lambda>L k G M p T fverify.
+    turing_machine k G M \<and>
+    polynomial p \<and>
+    big_oh_poly T \<and>
+    computes_in_time k M fverify T \<and>
+    (\<forall>y. length (fverify y) = 1) \<and>
+    (\<forall>x. (x \<in> L) = (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>])))"
+  have "\<N>\<P> = {L :: language. \<exists>k G M p T fverify. Q L k G M p T fverify}"
+    unfolding NP_output_len_1 Q_def by simp
+  then obtain k G M p T fverify where "Q L k G M p T fverify"
+    using assms by blast
+  then have alt:
+    "turing_machine k G M"
+    "polynomial p"
+    "big_oh_poly T"
+    "computes_in_time k M fverify T"
+    "\<And>y. length (fverify y) = 1"
+    "\<And>x. (x \<in> L) = (\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>])"
+    using Q_def by simp_all
+
+  have tm_M: "turing_machine k G M"
+    using alt(1) .
+  have poly_T: "big_oh_poly T"
+    using alt(3) .
+  have time_bound_T: "time_bound M k T"
+    unfolding time_bound_def
+  proof standard+
+    fix zs
+    assume zs: "bit_symbols zs"
+    define x where "x = symbols_to_string zs"
+    then have "zs = string_to_symbols x"
+      using bit_symbols_to_symbols zs by simp
+    then show "fst (execute M (start_config k zs) (T (length zs))) = length M"
+      using computes_in_time_def alt(4)
+      by (metis (no_types, lifting) execute_after_halting_ge length_map running_timeD(1))
+  qed
+
+  interpret two: two_tape M k G T
+    using tm_M poly_T time_bound_T two_tape_def by simp
+
+  let ?M = two.tmO2T
+  let ?T = two.TTT
+  let ?G = two.G'
+  have "big_oh_poly ?T"
+    using two.poly_TTT .
+  moreover have "polynomial p"
+    using alt(2) .
+  moreover have "turing_machine 2 ?G ?M"
+    using two.tmO2T_tm .
+  moreover have "oblivious ?M"
+  proof -
+    let ?e = "\<lambda>n. two.es12 (replicate n 2)"
+    have "\<exists>tps. trace ?M (start_config 2 zs) (?e (length zs)) (length ?M, tps)"
+        if "bit_symbols zs" for zs
+    proof -
+      have "traces ?M (snd (start_config 2 zs)) (two.es12 zs) (two.tps12'' zs)"
+        using that two.tmO2T by simp
+      then have *: "trace ?M (start_config 2 zs) (two.es12 zs) (length ?M, two.tps12'' zs)"
+        using start_config_def traces_def by simp
+
+      let ?r = "replicate (length zs) 2"
+      have "length zs = length ?r"
+        by simp
+      then have "two.es12 zs = two.es12 ?r"
+        using two.tmO2T_oblivious that by (metis nth_replicate)
+      then have "trace ?M (start_config 2 zs) (?e (length zs)) (length ?M, two.tps12'' zs)"
+        using * by simp
+      then show ?thesis
+        by auto
+    qed
+    then show ?thesis
+      using oblivious_def by fast
+  qed
+  moreover have "fst (execute ?M (start_config 2 y) (?T (length y))) = length ?M" if "bit_symbols y" for y
+    using that two.execute_tmO2T by simp
+  moreover have "x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> execute ?M (start_config 2 \<langle>x; u\<rangle>) (?T (length \<langle>x; u\<rangle>)) <.> 1 = \<one>)"
+    (is "?lhs = ?rhs") for x
+  proof
+    show "?lhs \<Longrightarrow> ?rhs"
+    proof -
+      assume ?lhs
+      then have "\<exists>u. length u = p (length x) \<and> fverify \<langle>x, u\<rangle> = [\<bbbI>]"
+        using alt(6) by simp
+      then obtain u where u: "length u = p (length x)" "fverify \<langle>x, u\<rangle> = [\<bbbI>]"
+        by auto
+
+      let ?y = "fverify \<langle>x, u\<rangle>"
+      let ?cfg = "execute M (start_config k \<langle>x; u\<rangle>) (T (length \<langle>x, u\<rangle>))"
+      have "computes_in_time k M fverify T"
+        using alt(4) by simp
+      then have cfg: "?cfg <:> 1 = string_to_contents ?y"
+        using computes_in_time_execute by simp
+
+      have "bit_symbols \<langle>x; u\<rangle>"
+        by simp
+      then have "execute ?M (start_config 2 \<langle>x; u\<rangle>) (?T (length \<langle>x; u\<rangle>)) <!> 1 =
+          (execute M (start_config k \<langle>x; u\<rangle>) (T (length \<langle>x; u\<rangle>)) <:> 1, 1)"
+        using two.execute_tmO2T_1 by blast
+      then have "execute ?M (start_config 2 \<langle>x; u\<rangle>) (?T (length \<langle>x; u\<rangle>)) <!> 1 =
+          (string_to_contents ?y, 1)"
+         using cfg by simp
+      then have "execute ?M (start_config 2 \<langle>x; u\<rangle>) (?T (length \<langle>x; u\<rangle>)) <!> 1 =
+          (string_to_contents [\<bbbI>], 1)"
+        using u(2) by auto
+      moreover have "|.| (string_to_contents [\<bbbI>], 1) = \<one>"
+        by simp
+      ultimately have "execute ?M (start_config 2 \<langle>x; u\<rangle>) (?T (length \<langle>x; u\<rangle>)) <.> 1 = \<one>"
+        by simp
+      then show ?thesis
+        using u(1) by auto
+    qed
+    show "?rhs \<Longrightarrow> ?lhs"
+    proof -
+      assume ?rhs
+      then obtain u where u:
+        "length u = p (length x)"
+        "execute ?M (start_config 2 \<langle>x; u\<rangle>) (?T (length \<langle>x; u\<rangle>)) <.> 1 = \<one>"
+        by auto
+      let ?zs = "\<langle>x; u\<rangle>"
+      have "bit_symbols \<langle>x; u\<rangle>"
+        by simp
+      then have *: "execute ?M (start_config 2 ?zs) (?T (length ?zs)) <!> 1 =
+          (execute M (start_config k ?zs) (T (length ?zs)) <:> 1, 1)"
+        using two.execute_tmO2T_1 by blast
+
+      let ?y = "fverify \<langle>x, u\<rangle>"
+      let ?cfg = "execute M (start_config k ?zs) (T (length \<langle>x, u\<rangle>))"
+      have "computes_in_time k M fverify T"
+        using alt(4) by simp
+      then have cfg: "?cfg <:> 1 = string_to_contents ?y"
+        using computes_in_time_execute by simp
+      then have "execute ?M (start_config 2 ?zs) (?T (length ?zs)) <!> 1 =
+          (string_to_contents (fverify \<langle>x, u\<rangle>), 1)"
+        using * by simp
+      then have "execute ?M (start_config 2 ?zs) (?T (length ?zs)) <.> 1 =
+          string_to_contents (fverify \<langle>x, u\<rangle>) 1"
+        by simp
+      then have **: "string_to_contents (fverify \<langle>x, u\<rangle>) 1 = \<one>"
+        using u(2) by simp
+
+      have "length (fverify \<langle>x, u\<rangle>) = 1"
+        using alt(5) by simp
+      then have "string_to_contents (fverify \<langle>x, u\<rangle>) 1 =
+          (if fverify \<langle>x, u\<rangle> ! 0 then \<one> else \<zero>)"
+        by simp
+      then have "(if fverify \<langle>x, u\<rangle> ! 0 then \<one> else \<zero>) = \<one>"
+        using ** by auto
+      then have "fverify \<langle>x, u\<rangle> ! 0 = \<bbbI>"
+        by (metis numeral_eq_iff semiring_norm(89))
+      moreover have "y = [\<bbbI>]" if "length y = 1" and "y ! 0" for y
+        using that by (metis (full_types) One_nat_def Suc_length_conv length_0_conv nth_Cons')
+      ultimately have "fverify \<langle>x, u\<rangle> = [\<bbbI>]"
+        using alt(5) by simp
+      then show ?lhs
+        using u(1) alt(6) by auto
+    qed
+  qed
+  ultimately show ?thesis
+    using that by simp
+qed
+
+end
\ No newline at end of file
diff --git a/thys/Cook_Levin/Oblivious_Polynomial.thy b/thys/Cook_Levin/Oblivious_Polynomial.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Oblivious_Polynomial.thy
@@ -0,0 +1,1473 @@
+section \<open>Constructing polynomials in polynomial time\label{s:oblivious-polynomial}\<close>
+
+theory Oblivious_Polynomial
+  imports Oblivious
+begin
+
+text \<open>
+Our current goal is to simulate a polynomial time multi-tape TM on a two-tape
+oblivious TM in polynomial time. To help with the obliviousness we first want to
+mark on the simulator's output tape a space that is at least as large as the
+space the simulated TM uses on any of its tapes but that still is only
+polynomial in size. In this section we construct oblivious Turing machines for
+that.
+
+An upper bound for the size this space is provided by the simulated TM's running
+time, which by assumption is polynomially bounded. So for our purposes any
+polynomially bounded function that bounds the running time will do.
+
+In this section we devise a family of two-tape oblivious TMs that contains for
+every polynomial degree $d \ge 1$ a TM that writes $\mathbf{1}^{p(n)}$ to the
+output tape for some polynomial $p$ with $p(n) \ge n^d$, where $n$ is the length
+of the input to the TM. Together with a TM that appends a constant number $c$ of
+ones we get a family of TMs, parameterized by $c$ and $d$, that runs in
+polynomial time and writes more than $c + n^d$ symbols~\textbf{1} to the work
+tape.
+
+This meets our goal for this section because every polynomially bounded
+function is bounded by a function of the form $n \mapsto c + n^d$ for some
+$c, d\in\nat$.
+
+The TMs in the family are built from three building block TMs. The first TM
+initializes its output tape with $\mathbf{1}^n$ where $n$ is the length of the
+input. The second TM multiplies the number of symbols on the output tape by
+(roughly) the length of the input, turning a sequence $\mathbf{1}^m$ into
+(roughly) $\mathbf{1}^{mn}$ for arbitrary $m$. The third TM appends
+$\mathbf{1}^c$ for some constant $c$. By repeating the second TM we can achieve
+arbitrarily high polynomial degrees.
+
+All three TMs do essentially only one thing with the input, namely copying it to
+the output tape while mapping all symbols to \textbf{1}, which is an operation
+that depends only on the length of the input. Therefore all three TMs are
+oblivious, and combining them also yields an oblivious TM.
+
+The Turing machines require one extra symbol beyond the four default symbols,
+but work for all alphabet sizes $G \ge 5$.
+
+\null
+\<close>
+
+locale turing_machine_poly =
+  fixes G :: nat
+  assumes G: "G \<ge> 5"
+begin
+
+lemma G_ge4 [simp]: "G \<ge> 4"
+  using G by linarith
+
+abbreviation tps_ones :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tps_ones zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>i. if i = 0 then \<triangleright> else if i \<le> m then \<one> else \<box>, 1)]"
+
+
+subsection \<open>Initializing the output tape\<close>
+
+text \<open>
+The first building block is a TM that ``copies'' the input to the output tape,
+thereby replacing every symbol by the symbol \textbf{1}.
+\<close>
+
+definition tmA :: machine where
+  "tmA \<equiv>
+    tm_right 0 ;; tm_right 1 ;; tm_const_until 0 1 {\<box>} \<one> ;; tm_cr 0 ;; tm_cr 1"
+
+lemma tmA_tm: "turing_machine 2 G tmA"
+  unfolding tmA_def using tm_right_tm tm_const_until_tm tm_cr_tm G by simp
+
+definition "tm1 \<equiv> tm_right 0"
+definition "tm2 \<equiv> tm1 ;; tm_right 1"
+definition "tm3 \<equiv> tm2 ;; tm_const_until 0 1 {\<box>} \<one>"
+definition "tm4 \<equiv> tm3 ;; tm_cr 0"
+definition "tm5 \<equiv> tm4 ;; tm_cr 1"
+
+lemma tm5_eq_tmA: "tm5 = tmA"
+  unfolding tmA_def tm5_def tm4_def tm3_def tm2_def tm1_def by simp
+
+definition tps0 :: "symbol list \<Rightarrow> tape list" where
+  "tps0 zs \<equiv>
+    [(\<lfloor>zs\<rfloor>, 0),
+     (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)]"
+
+lemma length_tps0 [simp]: "length (tps0 n) = 2"
+  unfolding tps0_def by simp
+
+definition tps1 :: "symbol list \<Rightarrow> tape list" where
+  "tps1 zs \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)]"
+
+definition es1 :: "(nat \<times> nat) list" where
+  "es1 \<equiv> [(1, 0)]"
+
+lemma tm1: "traces tm1 (tps0 zs) es1 (tps1 zs)"
+  unfolding tm1_def
+  by (rule traces_tm_right_0I) (simp_all add: tps0_def tps1_def es1_def)
+
+definition tps2 :: "symbol list \<Rightarrow> tape list" where
+  "tps2 zs \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 1)]"
+
+definition es2 :: "(nat \<times> nat) list" where
+  "es2 \<equiv> es1 @ [(1, 1)]"
+
+lemma length_es2: "length es2 = 2"
+  unfolding es1_def es2_def by simp
+
+lemma tm2: "traces tm2 (tps0 zs) es2 (tps2 zs)"
+  unfolding tm2_def es2_def
+proof (rule traces_sequential[OF tm1])
+  show "traces (tm_right 1) (tps1 zs) [(1, 1)] (tps2 zs)"
+    using tps1_def tps2_def by (intro traces_tm_right_1I) simp_all
+qed
+
+definition tps3 :: "symbol list \<Rightarrow> tape list" where
+  "tps3 zs \<equiv>
+    [(\<lfloor>zs\<rfloor>, length zs + 1),
+     (\<lambda>i. if i = 0 then \<triangleright> else if i \<le> length zs then \<one> else \<box>, length zs + 1)]"
+
+definition es23 :: "nat \<Rightarrow> (nat \<times> nat) list" where
+  "es23 n \<equiv> map (\<lambda>i. (i + 2, i + 2)) [0..<n] @ [(n + 1, n + 1)]"
+
+definition es3 :: "nat \<Rightarrow> (nat \<times> nat) list" where
+  "es3 n \<equiv> es2 @ (es23 n)"
+
+lemma length_es3: "length (es3 n) = n + 3"
+  unfolding es3_def es23_def using length_es2 by simp
+
+lemma tm3:
+  assumes "proper_symbols zs"
+  shows "traces tm3 (tps0 zs) (es3 (length zs)) (tps3 zs)"
+  unfolding tm3_def es3_def
+proof (rule traces_sequential[OF tm2])
+  show "traces (tm_const_until 0 1 {\<box>} \<one>) (tps2 zs) (es23 (length zs)) (tps3 zs)"
+  proof (rule traces_tm_const_until_01I)
+    show "1 < length (tps2 zs)"
+      using tps2_def by simp
+    show "rneigh (tps2 zs ! 0) {\<box>} (length zs)"
+      using rneigh_def contents_def tps2_def assms by auto
+    show "es23 (length zs) =
+        map (\<lambda>i. (tps2 zs :#: 0 + Suc i, tps2 zs :#: 1 + Suc i))
+        [0..<length zs] @
+        [(tps2 zs :#: 0 + length zs, tps2 zs :#: 1 + length zs)]"
+      unfolding es23_def using tps2_def by simp
+    show "tps3 zs = (tps2 zs)
+        [0 := tps2 zs ! 0 |+| length zs,
+         1 := constplant (tps2 zs ! 1) \<one> (length zs)]"
+      using tps3_def tps2_def constplant by auto
+  qed
+qed
+
+definition tps4 :: "symbol list \<Rightarrow> tape list" where
+  "tps4 zs \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>i. if i = 0 then \<triangleright> else if i \<le> length zs then \<one> else \<box>, length zs + 1)]"
+
+definition es34 :: "nat \<Rightarrow> (nat \<times> nat) list" where
+  "es34 n \<equiv> map (\<lambda>i. (i, n + 1)) (rev [0..<n + 1]) @ [(0, n + 1)] @ [(1, n + 1)]"
+
+definition es4 :: "nat \<Rightarrow> (nat \<times> nat) list" where
+  "es4 n \<equiv> es3 n @ es34 n"
+
+lemma length_es4: "length (es4 n) = 2 * n + 6"
+  unfolding es4_def es34_def using length_es3 by simp
+
+lemma tm4:
+  assumes "proper_symbols zs"
+  shows "traces tm4 (tps0 zs) (es4 (length zs)) (tps4 zs)"
+  unfolding tm4_def es4_def
+proof (rule traces_sequential[OF tm3])
+  show "proper_symbols zs"
+    using assms .
+  show "traces (tm_cr 0) (tps3 zs) (es34 (length zs)) (tps4 zs)"
+  proof (rule traces_tm_cr_0I)
+    show "1 < length (tps3 zs)"
+      using tps3_def by simp
+    show "clean_tape (tps3 zs ! 0)"
+     using assms tps3_def by simp
+    show "es34 (length zs) =
+        map (\<lambda>i. (i, tps3 zs :#: 1)) (rev [0..<tps3 zs :#: 0]) @
+        [(0, tps3 zs :#: 1), (1, tps3 zs :#: 1)]"
+      using tps3_def es34_def by simp
+    show "tps4 zs = (tps3 zs)[0 := tps3 zs ! 0 |#=| 1]"
+      using tps3_def tps4_def by simp
+  qed
+qed
+
+definition tps5 :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tps5 zs m \<equiv> tps_ones zs m"
+
+definition es45 :: "nat \<Rightarrow> (nat \<times> nat) list" where
+  "es45 n \<equiv> map (\<lambda>i. (1, i)) (rev [0..<n + 1]) @ [(1, 0)] @ [(1, 1)]"
+
+definition es5 :: "nat \<Rightarrow> (nat \<times> nat) list" where
+  "es5 n \<equiv> es4 n @ es45 n"
+
+lemma length_es5: "length (es5 n) = 3 * n + 9"
+  unfolding es5_def es45_def using length_es4 by simp
+
+lemma tm5:
+  assumes "proper_symbols zs"
+  shows "traces tm5 (tps0 zs) (es5 (length zs)) (tps5 zs (length zs))"
+  unfolding tm5_def es5_def
+proof (rule traces_sequential[OF tm4])
+  show "proper_symbols zs"
+   using assms .
+  show "traces (tm_cr 1) (tps4 zs) (es45 (length zs)) (tps5 zs (length zs))"
+  proof (rule traces_tm_cr_1I)
+    show "1 < length (tps4 zs)"
+      using tps4_def by simp
+    show "clean_tape (tps4 zs ! 1)"
+      using tps4_def clean_tape_def by simp
+    show "es45 (length zs) =
+        map (Pair (tps4 zs :#: 0)) (rev [0..<tps4 zs :#: 1]) @
+        [(tps4 zs :#: 0, 0), (tps4 zs :#: 0, 1)]"
+      using tps4_def by (simp add: es45_def)
+    show "tps5 zs (length zs) = (tps4 zs)[1 := tps4 zs ! 1 |#=| 1]"
+      using tps4_def tps5_def by simp
+  qed
+qed
+
+corollary tmA:
+  assumes "proper_symbols zs"
+  shows "traces tmA (tps0 zs) (es5 (length zs)) (tps_ones zs (length zs))"
+  using tps5_def tm5_eq_tmA tm5 assms by simp
+
+lemma length_tps_ones [simp]: "length (tps_ones zs m) = 2"
+  by simp
+
+
+subsection \<open>Multiplying by the input length\<close>
+
+text \<open>
+The next Turing machine turns a symbol sequence $\mathbf{1}^m$ on its output tape
+into $\mathbf{1}^{m+1+mn}$ where $n$ is the length of the input.
+
+The TM first appends to the output tape symbols a @{text "\<bar>"} symbol. Then it
+performs a loop with $m$ iterations. In each iteration it replaces a @{text \<one>}
+before the @{text "\<bar>"} by @{text \<zero>} in order to count the iterations. Then it
+copies (replacing each symbol by @{text \<one>}) the input after the output tape
+symbols. After the loop the output tape contains $\mathbf{0}^m|\mathbf{1}^{mn}$.
+Finally the @{text "\<bar>"} and @{text \<zero>} symbols are replaced by @{text \<one>}
+symbols, yielding the desired result.
+\<close>
+
+definition tmB :: machine where
+  "tmB \<equiv>
+    tm_right_until 1 {\<box>} ;;
+    tm_write 1 \<bar> ;;
+    tm_cr 1 ;;
+    WHILE tm_right_until 1 {\<one>, \<bar>} ; \<lambda>rs. rs ! 1 = \<one> DO
+       tm_write 1 \<zero> ;;
+       tm_right_until 1 {0} ;;
+       tm_const_until 0 1 {\<box>} \<one> ;;
+       tm_cr 0 ;;
+       tm_cr 1
+    DONE ;;
+    tm_write 1 \<one> ;;
+    tm_cr 1 ;;
+    tm_const_until 1 1 {\<one>} \<one> ;;
+    tm_cr 1"
+
+lemma tmB_tm: "turing_machine 2 G tmB"
+  unfolding tmB_def
+  using tm_right_until_tm tm_write_tm tm_cr_tm tm_const_until_tm G
+    turing_machine_loop_turing_machine turing_machine_sequential_turing_machine
+  by simp
+
+definition "tmB1 \<equiv> tm_right_until 1 {\<box>}"
+definition "tmB2 \<equiv> tmB1 ;; tm_write 1 \<bar>"
+definition "tmB3 \<equiv> tmB2 ;; tm_cr 1"
+definition "tmK1 \<equiv> tm_right_until 1 {\<one>, \<bar>}"
+definition "tmL1 \<equiv> tm_write 1 \<zero>"
+definition "tmL2 \<equiv> tmL1 ;; tm_right_until 1 {\<box>}"
+definition "tmL3 \<equiv> tmL2 ;; tm_const_until 0 1 {\<box>} \<one>"
+definition "tmL4 \<equiv> tmL3 ;; tm_cr 0"
+definition "tmL5 \<equiv> tmL4 ;; tm_cr 1"
+definition "tmLoop \<equiv> WHILE tmK1 ; \<lambda>rs. rs ! 1 = \<one> DO tmL5 DONE"
+definition "tmB4 \<equiv> tmB3 ;; tmLoop"
+definition "tmB5 \<equiv> tmB4 ;; tm_write 1 \<one>"
+definition "tmB6 \<equiv> tmB5 ;; tm_cr 1"
+definition "tmB7 \<equiv> tmB6 ;; tm_const_until 1 1 {\<one>} \<one>"
+definition "tmB8 \<equiv> tmB7 ;; tm_cr 1"
+
+lemma tmB_eq_tmB8: "tmB = tmB8"
+  unfolding tmB_def tmB1_def tmB2_def tmB3_def tmK1_def tmL1_def tmL2_def tmL3_def
+    tmL4_def tmL5_def tmLoop_def tmB4_def tmB5_def tmB6_def tmB7_def tmB8_def
+  by simp
+
+definition tpsB1 :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsB1 zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>i. if i = 0 then \<triangleright> else if i \<le> m then \<one> else \<box>, m + 1)]"
+
+definition esB1 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB1 n m \<equiv> map (\<lambda>i. (1, 1 + Suc i)) [0..<m] @ [(1, 1 + m)]"
+
+lemma length_esB1: "length (esB1 n m) = m + 1"
+  using esB1_def by (metis Suc_eq_plus1 length_append_singleton length_map length_upt minus_nat.diff_0)
+
+lemma tmB1:
+  assumes "proper_symbols zs"
+  shows "traces tmB1 (tps_ones zs m) (esB1 (length zs) m) (tpsB1 zs m)"
+  unfolding tmB1_def
+proof (rule traces_tm_right_until_1I[where ?n=m])
+  show "1 < length (tps_ones zs m)"
+    by simp
+  show "rneigh (tps_ones zs m ! 1) {0} m"
+    using rneighI by simp
+  show "esB1 (length zs) m =
+      map (\<lambda>i. (tps_ones zs m :#: 0, tps_ones zs m :#: 1 + Suc i)) [0..<m] @
+      [(tps_ones zs m :#: 0, tps_ones zs m :#: 1 + m)]"
+    by (simp add: esB1_def)
+  show "tpsB1 zs m = (tps_ones zs m)[1 := tps_ones zs m ! 1 |+| m]"
+    using tpsB1_def by simp
+qed
+
+definition tpsB2 :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsB2 zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>i. if i = 0 then \<triangleright> else if i \<le> m then \<one> else if i = m + 1 then \<bar> else \<box>, m + 1)]"
+
+definition esB12 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB12 n m \<equiv> [(1, m + 1)]"
+
+definition esB2 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB2 n m \<equiv> esB1 n m @ esB12 n m"
+
+lemma length_esB2: "length (esB2 n m) = m + 2"
+  by (simp add: esB12_def esB2_def length_esB1)
+
+lemma tmB2:
+  assumes "proper_symbols zs"
+  shows "traces tmB2 (tps_ones zs m) (esB2 (length zs) m) (tpsB2 zs m)"
+  unfolding tmB2_def esB2_def
+proof (rule traces_sequential[OF tmB1])
+  show "proper_symbols zs"
+    using assms .
+  show "traces (tm_write 1 \<bar>) (tpsB1 zs m) (esB12 (length zs) m) (tpsB2 zs m)"
+  proof (rule traces_tm_write_1I)
+    show "1 < length (tpsB1 zs m)"
+      using tpsB1_def by simp_all
+    show "esB12 (length zs) m = [(tpsB1 zs m :#: 0, tpsB1 zs m :#: 1)]"
+      using tpsB1_def by (simp add: esB12_def)
+    show "tpsB2 zs m = (tpsB1 zs m)[1 := tpsB1 zs m ! 1 |:=| \<bar>]"
+      using tpsB2_def tpsB1_def by auto
+  qed
+qed
+
+definition tpsB3 :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsB3 zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>i. if i = 0 then \<triangleright> else if i \<le> m then \<one> else if i = m + 1 then \<bar> else 0, 1)]"
+
+definition esB23 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB23 n m \<equiv> map (Pair 1) (rev [0..<m + 1]) @ [(1, 0), (1, 1)]"
+
+definition esB3 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB3 n m \<equiv> esB2 n m @ esB23 n m"
+
+lemma length_esB3: "length (esB3 n m) = 2 * m + 5"
+  by (simp add: esB3_def length_esB2 esB23_def)
+
+lemma tmB3:
+  assumes "proper_symbols zs"
+  shows "traces tmB3 (tps_ones zs m) (esB3 (length zs) m) (tpsB3 zs m)"
+  unfolding tmB3_def esB3_def
+proof (rule traces_sequential[OF tmB2])
+  show "proper_symbols zs"
+    using assms .
+  show "traces (tm_cr 1) (tpsB2 zs m) (esB23 (length zs) m) (tpsB3 zs m)"
+  proof (rule traces_tm_cr_1I)
+    show "1 < length (tpsB2 zs m)"
+      using tpsB2_def by simp
+    show "clean_tape (tpsB2 zs m ! 1)"
+      using tpsB2_def clean_tape_def by simp
+    show "esB23 (length zs) m =
+        map (Pair (tpsB2 zs m :#: 0)) (rev [0..<tpsB2 zs m :#: 1]) @
+        [(tpsB2 zs m :#: 0, 0), (tpsB2 zs m :#: 0, 1)]"
+      by (simp add: esB23_def tpsB2_def)
+    show "tpsB3 zs m = (tpsB2 zs m)[1 := tpsB2 zs m ! 1 |#=| 1]"
+      using tpsB2_def tpsB3_def by simp
+  qed
+qed
+
+definition tpsK0 :: "symbol list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsK0 zs m i \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> i then \<zero>
+           else if x \<le> m then \<one>
+           else if x = m + 1 then \<bar>
+           else if x \<le> m + 1 + i * length zs then \<one>
+           else 0,
+      1)]"
+
+lemma tpsK0_eq_tpsB3: "tpsK0 zs m 0 = tpsB3 zs m"
+  using tpsK0_def tpsB3_def by auto
+
+definition tpsK1 :: "symbol list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tape list" where
+ "tpsK1 zs m i \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> i then \<zero>
+           else if x \<le> m then \<one>
+           else if x = m + 1 then \<bar>
+           else if x \<le> m + 1 + i * length zs then \<one>
+           else 0,
+      i + 1)]"
+
+definition esK1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esK1 n m i \<equiv> map (\<lambda>i. (1, 1 + Suc i)) [0..<i] @ [(1, i + 1)]"
+
+lemma length_esK1: "length (esK1 n m i) = i + 1"
+  by (simp add: esK1_def)
+
+lemma tmK1:
+  assumes "proper_symbols zs" and "i < m"
+  shows "traces tmK1 (tpsK0 zs m i) (esK1 (length zs) m i) (tpsK1 zs m i)"
+  unfolding tmK1_def
+proof (rule traces_tm_right_until_1I[where ?n=i])
+  show "1 < length (tpsK0 zs m i)"
+    using tpsK0_def by simp
+  show "rneigh (tpsK0 zs m i ! 1) {\<one>, \<bar>} i"
+    using tpsK0_def rneigh_def assms(2) by simp
+  show "esK1 (length zs) m i =
+      map (\<lambda>j. (tpsK0 zs m i :#: 0, tpsK0 zs m i :#: 1 + Suc j)) [0..<i] @
+      [(tpsK0 zs m i :#: 0, tpsK0 zs m i :#: 1 + i)]"
+    by (simp add: esK1_def tpsK0_def)
+  show "tpsK1 zs m i = (tpsK0 zs m i)[1 := tpsK0 zs m i ! 1 |+| i]"
+    by (simp add: tpsK1_def tpsK0_def)
+qed
+
+definition tpsL1 :: "symbol list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tape list" where
+ "tpsL1 zs m i \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> i + 1 then \<zero>
+           else if x \<le> m then \<one>
+           else if x = m + 1 then \<bar>
+           else if x \<le> m + 1 + i * length zs then \<one>
+           else 0,
+      i + 1)]"
+
+definition esL1 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esL1 n m i \<equiv> [(1, i + 1)]"
+
+lemma tmL1:
+  assumes "proper_symbols zs"
+  shows "traces tmL1 (tpsK1 zs m i) (esL1 (length zs) m i) (tpsL1 zs m i)"
+  unfolding tmL1_def using G
+  by (intro traces_tm_write_1I) (auto simp add: tpsL1_def tpsK1_def esL1_def)
+
+definition tpsL2 :: "symbol list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsL2 zs m i \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> i + 1 then \<zero>
+           else if x \<le> m then \<one>
+           else if x = m + 1 then \<bar>
+           else if x \<le> m + 1 + i * length zs then \<one>
+           else 0,
+      m + 2 + i * length zs)]"
+
+definition esL12 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esL12 n m i \<equiv>
+    map (\<lambda>j. (1, i + 1 + Suc j)) [0..<m + 2 + i * n - (i + 1)] @
+    [(1, i + 1 + (m + 2 + i * n - (i + 1)))]"
+
+definition esL2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esL2 n m i \<equiv> esL1 n m i @ esL12 n m i"
+
+lemma length_esL2: "i < m \<Longrightarrow> length (esL2 n m i) = 3 + m - i + i * n"
+  by (auto simp add: esL2_def esL12_def esL1_def)
+
+text \<open>
+A simplified upper bound for the running time:
+\<close>
+
+corollary length_esL2': "i < m \<Longrightarrow> length (esL2 n m i) \<le> 3 + m + i * n"
+  by (simp add: length_esL2)
+
+lemma tmL2:
+  assumes "proper_symbols zs" and "i < m"
+  shows "traces tmL2 (tpsK1 zs m i) (esL2 (length zs) m i) (tpsL2 zs m i)"
+  unfolding tmL2_def esL2_def
+proof (rule traces_sequential[OF tmL1])
+  show "proper_symbols zs"
+    using assms(1) .
+  show "traces (tm_right_until 1 {0}) (tpsL1 zs m i) (esL12 (length zs) m i) (tpsL2 zs m i)"
+  proof (rule traces_tm_right_until_1I)
+    show "1 < length (tpsL1 zs m i)"
+      using tpsL1_def by simp
+    show "rneigh (tpsL1 zs m i ! 1) {0} (m + 2 + i * length zs - (i + 1))"
+      using rneigh_def assms(2) by (auto simp add: tpsL1_def)
+    show "esL12 (length zs) m i =
+        map (\<lambda>j. (tpsL1 zs m i :#: 0, tpsL1 zs m i :#: 1 + Suc j))
+        [0..<m + 2 + i * length zs - (i + 1)] @
+        [(tpsL1 zs m i :#: 0,
+          tpsL1 zs m i :#: 1 + (m + 2 + i * length zs - (i + 1)))]"
+      using assms(2) by (simp add: tpsL1_def esL12_def)
+    show "tpsL2 zs m i = (tpsL1 zs m i) [1 := tpsL1 zs m i ! 1 |+| m + 2 + i * length zs - (i + 1)]"
+      using assms(2) by (simp add: tpsL1_def tpsL2_def)
+  qed
+qed
+
+definition tpsL3 :: "symbol list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsL3 zs m i \<equiv>
+    [(\<lfloor>zs\<rfloor>, length zs + 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> i + 1 then \<zero>
+           else if x \<le> m then \<one>
+           else if x = m + 1 then \<bar>
+           else if x \<le> m + 1 + (i + 1) * length zs then \<one>
+           else 0,
+      m + 2 + (i + 1) * length zs)]"
+
+definition esL23 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esL23 n m i \<equiv>
+    map (\<lambda>j. (1 + Suc j, m + 2 + i * n + Suc j)) [0..<n] @ [(1 + n, m + 2 + i * n + n)]"
+
+definition esL3 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esL3 n m i \<equiv> esL2 n m i @ esL23 n m i"
+
+lemma length_esL3: "i < m \<Longrightarrow> length (esL3 n m i) \<le> 4 + m + (i + 1) * n"
+  by (auto simp add: esL3_def esL23_def) (metis group_cancel.add1 length_esL2')
+
+lemma tmL3:
+  assumes "proper_symbols zs" and "i < m"
+  shows "traces tmL3 (tpsK1 zs m i) (esL3 (length zs) m i) (tpsL3 zs m i)"
+  unfolding tmL3_def esL3_def
+proof (rule traces_sequential[OF tmL2])
+  show "proper_symbols zs" and "i < m"
+    using assms .
+  show "traces (tm_const_until 0 1 {\<box>} \<one>) (tpsL2 zs m i) (esL23 (length zs) m i) (tpsL3 zs m i)"
+  proof (rule traces_tm_const_until_01I)
+    show "1 < length (tpsL2 zs m i)"
+      using tpsL2_def by simp
+    show "rneigh (tpsL2 zs m i ! 0) {0} (length zs)"
+      using assms(1) rneigh_def contents_def by (auto simp add: tpsL2_def)
+    show "esL23 (length zs) m i =
+      map (\<lambda>j. (tpsL2 zs m i :#: 0 + Suc j, tpsL2 zs m i :#: 1 + Suc j)) [0..<length zs] @
+      [(tpsL2 zs m i :#: 0 + length zs, tpsL2 zs m i :#: 1 + length zs)]"
+      using assms by (simp add: esL23_def tpsL2_def)
+    show "tpsL3 zs m i = (tpsL2 zs m i)
+      [0 := tpsL2 zs m i ! 0 |+| length zs,
+       1 := constplant (tpsL2 zs m i ! 1) \<one> (length zs)]"
+      using constplant assms by (auto simp add: tpsL2_def tpsL3_def)
+  qed
+qed
+
+definition tpsL4 :: "symbol list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsL4 zs m i \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> i + 1 then \<zero>
+           else if x \<le> m then \<one>
+           else if x = m + 1 then \<bar>
+           else if x \<le> m + 1 + (i + 1) * length zs then \<one>
+           else 0,
+      m + 2 + (i + 1) * length zs)]"
+
+definition esL34 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esL34 n m i \<equiv>
+    map (\<lambda>j. (j, m + 2 + (i + 1) * n)) (rev [0..<n + 1]) @ [(0, m + 2 + (i + 1) * n), (1, m + 2 + (i + 1) * n)]"
+
+lemma length_esL34: "i < m \<Longrightarrow> length (esL34 n m i) = n + 3"
+  unfolding esL34_def by simp
+
+definition esL4 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esL4 n m i \<equiv> esL3 n m i @ esL34 n m i"
+
+lemma length_esL4: "i < m \<Longrightarrow> length (esL4 n m i) \<le> 7 + m + (i + 2) * n"
+  using length_esL3 length_esL34
+  by (auto simp add: esL4_def) (metis ab_semigroup_add_class.add_ac(1) group_cancel.add2)
+
+lemma tmL4:
+  assumes "proper_symbols zs" and "i < m"
+  shows "traces tmL4 (tpsK1 zs m i) (esL4 (length zs) m i) (tpsL4 zs m i)"
+  unfolding tmL4_def esL4_def
+proof (rule traces_sequential[OF tmL3])
+  show "proper_symbols zs" "i < m"
+    using assms .
+  show "traces (tm_cr 0) (tpsL3 zs m i) (esL34 (length zs) m i) (tpsL4 zs m i)"
+  proof (rule traces_tm_cr_0I)
+    show "1 < length (tpsL3 zs m i)"
+      using tpsL3_def by simp
+    show "clean_tape (tpsL3 zs m i ! 0)"
+      using tpsL3_def assms(1) by simp
+    show "esL34 (length zs) m i =
+        map (\<lambda>j. (j, tpsL3 zs m i :#: 1)) (rev [0..<tpsL3 zs m i :#: 0]) @
+        [(0, tpsL3 zs m i :#: 1), (1, tpsL3 zs m i :#: 1)]"
+      by (simp add: esL34_def tpsL3_def)
+    show "tpsL4 zs m i = (tpsL3 zs m i)[0 := tpsL3 zs m i ! 0 |#=| 1]"
+      by (simp add: tpsL4_def tpsL3_def)
+  qed
+qed
+
+definition tpsL5 :: "symbol list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsL5 zs m i \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> i + 1 then \<zero>
+           else if x \<le> m then \<one>
+           else if x = m + 1 then \<bar>
+           else if x \<le> m + 1 + (i + 1) * length zs then \<one>
+           else 0,
+      1)]"
+
+definition esL45 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esL45 n m i \<equiv> map (Pair 1) (rev [0..<m + 2 + (i + 1) * n]) @ [(1, 0), (1, 1)]"
+
+definition esL5 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esL5 n m i \<equiv> esL4 n m i @ esL45 n m i"
+
+lemma length_esL5: "i < m \<Longrightarrow> length (esL5 n m i) \<le> 11 + 2 * m + (2 * i + 3) * n"
+proof -
+  assume a: "i < m"
+  have "length (esL5 n m i) = length (esL4 n m i) + length (esL45 n m i)"
+    using esL5_def by simp
+  also have "... \<le> 7 + m + (i + 2) * n + length (esL45 n m i)"
+    using length_esL4[OF a] by simp
+  also have "... = 7 + m + (i + 2) * n + (m + 2 + (i + 1) * n + 2)"
+    using esL45_def by simp
+  also have "... = 11 + 2 * m + (2 * i + 3) * n"
+    by algebra
+  finally show ?thesis .
+qed
+
+lemma tmL5:
+  assumes "proper_symbols zs" and "i < m"
+  shows "traces tmL5 (tpsK1 zs m i) (esL5 (length zs) m i) (tpsL5 zs m i)"
+  unfolding tmL5_def esL5_def
+proof (rule traces_sequential[OF tmL4])
+  show "proper_symbols zs" "i < m"
+    using assms .
+  show "traces (tm_cr 1) (tpsL4 zs m i) (esL45 (length zs) m i) (tpsL5 zs m i)"
+  proof (rule traces_tm_cr_1I)
+    show "1 < length (tpsL4 zs m i)"
+      using tpsL4_def by simp
+    show "clean_tape (tpsL4 zs m i ! 1)"
+      using tpsL4_def assms clean_tapeI by simp
+    show "esL45 (length zs) m i =
+        map (Pair (tpsL4 zs m i :#: 0)) (rev [0..<tpsL4 zs m i :#: 1]) @
+        [(tpsL4 zs m i :#: 0, 0), (tpsL4 zs m i :#: 0, 1)]"
+      by (simp add: esL45_def tpsL4_def)
+    show "tpsL5 zs m i = (tpsL4 zs m i)[1 := tpsL4 zs m i ! 1 |#=| 1]"
+      by (simp add: tpsL4_def tpsL5_def)
+  qed
+qed
+
+definition esLoop_do :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esLoop_do n m i \<equiv> esK1 n m i @ [(1, i + 1)] @ esL5 n m i @ [(1, 1)]"
+
+text \<open>
+Using $i < m$ we get this upper bound for the running time of an iteration
+independent of $i$.
+\<close>
+
+lemma length_esLoop_do: "i < m \<Longrightarrow> length (esLoop_do n m i) \<le> 14 + 3 * m + (2 * m + 3) * n"
+proof -
+  assume "i < m"
+  have "length (esLoop_do n m i) = length (esK1 n m i) + length (esL5 n m i) + 2"
+    unfolding esLoop_do_def by simp
+  also have "... = i + 3 + (length (esL5 n m i))"
+    using length_esK1 by simp
+  also have "... \<le> i + 14 + 2 * m + (2 * i + 3) * n"
+    using length_esL5[OF `i < m`] by (simp add: add.assoc)
+  also have "... \<le> 14 + 3 * m + (2 * i + 3) * n"
+    using `i < m` by simp
+  also have "... \<le> 14 + 3 * m + (2 * m + 3) * n"
+    using `i < m` by simp
+  finally show ?thesis .
+qed
+
+lemma tmLoop_do:
+  assumes "proper_symbols zs" and "i < m"
+  shows "trace tmLoop (0, tpsK0 zs m i) (esLoop_do (length zs) m i) (0, tpsL5 zs m i)"
+  unfolding tmLoop_def
+proof (rule tm_loop_sem_true_tracesI[OF tmK1 tmL5])
+  show "proper_symbols zs" "proper_symbols zs" "i < m" "i < m"
+    using assms by simp_all
+  show "read (tpsK1 zs m i) ! 1 = \<one>"
+    using tpsK1_def assms(2) read_def by simp
+  show "esLoop_do (length zs) m i =
+      esK1 (length zs) m i @
+      [(tpsK1 zs m i :#: 0, tpsK1 zs m i :#: 1)] @
+      esL5 (length zs) m i @ [(tpsL5 zs m i :#: 0, tpsL5 zs m i :#: 1)]"
+    by (simp add: esLoop_do_def esK1_def tpsK1_def esL5_def tpsL5_def)
+qed
+
+lemma tpsL5_eq_tpsK0:
+  assumes "proper_symbols zs" and "i < m"
+  shows "tpsL5 zs m i = tpsK0 zs m (Suc i)"
+  using assms tpsL5_def tpsK0_def by auto
+
+lemma tmLoop_iteration:
+  assumes "proper_symbols zs" and "i < m"
+  shows "trace tmLoop (0, tpsK0 zs m i) (esLoop_do (length zs) m i) (0, tpsK0 zs m (Suc i))"
+  using assms tmLoop_do tpsL5_eq_tpsK0 by simp
+
+definition esLoop_done :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esLoop_done n m \<equiv> concat (map (esLoop_do n m) [0..<m])"
+
+lemma tmLoop_done:
+  assumes "proper_symbols zs"
+  shows "trace tmLoop (0, tpsK0 zs m 0) (esLoop_done (length zs) m) (0, tpsK0 zs m m)"
+  using assms tm_loop_trace_simple by (simp add: tmLoop_iteration esLoop_done_def)
+
+lemma length_esLoop_done: "length (esLoop_done n m) \<le> m * (14 + 3 * m + (2 * m + 3) * n)"
+  using length_concat_le[OF length_esLoop_do] esLoop_done_def by simp
+
+definition tpsK_break :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsK_break zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> m then \<zero>
+           else if x = m + 1 then \<bar>
+           else if x \<le> m + 1 + m * length zs then \<one>
+           else 0,
+      m + 1)]"
+
+definition esK_break :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esK_break n m \<equiv> map (\<lambda>i. (1, 1 + Suc i)) [0..<m] @ [(1, 1 + m)]"
+
+lemma length_esK_break: "length (esK_break n m) = m + 1"
+  unfolding esK_break_def by simp
+
+lemma tmK1_break:
+  assumes "proper_symbols zs"
+  shows "traces tmK1 (tpsK0 zs m m) (esK_break (length zs) m) (tpsK_break zs m)"
+  unfolding tmK1_def
+proof (rule traces_tm_right_until_1I[where ?n=m])
+  show "1 < length (tpsK0 zs m m)"
+    using tpsK0_def by simp
+  show "rneigh (tpsK0 zs m m ! 1) {\<one>, \<bar>} m"
+    using rneigh_def by (simp add: tpsK0_def)
+  show "esK_break (length zs) m =
+      map (\<lambda>j. (tpsK0 zs m m :#: 0, tpsK0 zs m m :#: 1 + Suc j)) [0..<m] @
+      [(tpsK0 zs m m :#: 0, tpsK0 zs m m :#: 1 + m)]"
+    by (simp add: esK_break_def tpsK0_def)
+  show "tpsK_break zs m = (tpsK0 zs m m)[1 := tpsK0 zs m m ! 1 |+| m]"
+    by (auto simp add: tpsK_break_def tpsK0_def)
+qed
+
+definition esLoop_break :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esLoop_break n m \<equiv> esK_break n m @ [(1, m + 1)]"
+
+lemma length_esLoop_break: "length (esLoop_break n m) = m + 2"
+  unfolding esLoop_break_def using length_esK_break by simp
+
+lemma tmLoop_break:
+  assumes "proper_symbols zs"
+  shows "traces tmLoop (tpsK0 zs m m) (esLoop_break (length zs) m) (tpsK_break zs m)"
+  unfolding tmLoop_def esLoop_break_def
+proof (rule tm_loop_sem_false_traces[OF tmK1_break])
+  show "proper_symbols zs"
+    using assms .
+  show "read (tpsK_break zs m) ! 1 \<noteq> \<one>"
+    using tpsK_break_def read_def by simp
+  show "esK_break (length zs) m @ [(1, m + 1)] =
+      esK_break (length zs) m @ [(tpsK_break zs m :#: 0, tpsK_break zs m :#: 1)]"
+    by (simp add: esK_break_def tpsK_break_def)
+qed
+
+definition esLoop :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esLoop n m \<equiv> esLoop_done n m @ esLoop_break n m"
+
+lemma length_esLoop: "length (esLoop n m) \<le> m * (14 + 3 * m + (2 * m + 3) * n) + m + 2"
+  unfolding esLoop_def using length_esLoop_done by (simp add: length_esLoop_break)
+
+lemma length_esLoop': "length (esLoop n m) \<le> 2 + 18 * m * m + 5 * m * m * n"
+proof -
+  have "length (esLoop n m) \<le> m * (14 + 3 * m + (2 * m + 3) * n) + m + 2"
+    using length_esLoop .
+  also have "... = 14 * m + 3 * m * m + (2 * m * m + 3 * m) * n + m + 2"
+    by algebra
+  also have "... \<le> 15 * m * m + 3 * m * m + (2 * m * m + 3 * m) * n + 2"
+    by simp
+  also have "... \<le> 2 + 18 * m * m + 5 * m * m * n"
+    by simp
+  finally show ?thesis .
+qed
+
+lemma tmLoop:
+  assumes "proper_symbols zs"
+  shows "traces tmLoop (tpsK0 zs m 0) (esLoop (length zs) m) (tpsK_break zs m)"
+  unfolding esLoop_def using assms by (intro traces_additive[OF tmLoop_done tmLoop_break])
+
+lemma tmLoop':
+  assumes "proper_symbols zs"
+  shows "traces tmLoop (tpsB3 zs m) (esLoop (length zs) m) (tpsK_break zs m)"
+  using assms tmLoop tpsK0_eq_tpsB3 by simp
+
+definition esB4 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB4 n m \<equiv> esB3 n m @ esLoop n m"
+
+lemma length_esB4: "length (esB4 n m) \<le> 7 + 20 * m * m + 5 * m * m * n"
+proof -
+  have "length (esB4 n m) \<le> 2 * m + 5 + m * (14 + 3 * m + (2 * m + 3) * n) + m + 2"
+    unfolding esB4_def
+    using length_esB3 length_esLoop
+    by (smt ab_semigroup_add_class.add_ac(1) add_less_cancel_left le_eq_less_or_eq length_append)
+  also have "... = 2 * m + 5 + (14 * m + 3 * m * m + (2 * m * m + 3 * m) * n) + m + 2"
+    by algebra
+  also have "... = 7 + 17 * m + 3 * m * m + (2 * m * m + 3 * m) * n"
+    by simp
+  also have "... \<le> 7 + 17 * m + 3 * m * m + 5 * m * m * n"
+    by simp
+  also have "... \<le> 7 + 20 * m * m + 5 * m * m * n"
+    by simp
+  finally show ?thesis .
+qed
+
+lemma tmB4:
+  assumes "proper_symbols zs"
+  shows "traces tmB4 (tps_ones zs m) (esB4 (length zs) m) (tpsK_break zs m)"
+  unfolding tmB4_def esB4_def
+  using assms by (intro traces_sequential[OF tmB3 tmLoop'])
+
+definition tpsB5 :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsB5 zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> m then \<zero>
+           else if x \<le> m + 1 + m * length zs then \<one>
+           else 0,
+      m + 1)]"
+
+definition esB5 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB5 n m \<equiv> esB4 n m @ [(1, m + 1)]"
+
+lemma length_esB5: "length (esB5 n m) \<le> 8 + 20 * m * m + 5 * m * m * n"
+  unfolding esB5_def
+  using length_esB4
+  by (metis Suc_le_mono length_append_singleton one_plus_numeral plus_1_eq_Suc plus_nat.simps(2)
+    semiring_norm(2) semiring_norm(4) semiring_norm(8))
+
+lemma tmB5:
+  assumes "proper_symbols zs"
+  shows "traces tmB5 (tps_ones zs m) (esB5 (length zs) m) (tpsB5 zs m)"
+  unfolding tmB5_def esB5_def
+proof (rule traces_sequential[OF tmB4])
+  show "proper_symbols zs"
+    using assms .
+  show "traces (tm_write 1 \<one>) (tpsK_break zs m) [(1, m + 1)] (tpsB5 zs m)"
+  proof (rule traces_tm_write_1I)
+    show "1 < length (tpsK_break zs m)"
+      using tpsK_break_def by simp_all
+    show "[(1, m + 1)] = [(tpsK_break zs m :#: 0, tpsK_break zs m :#: 1)]"
+      using tpsK_break_def by simp
+    show "tpsB5 zs m = (tpsK_break zs m)[1 := tpsK_break zs m ! 1 |:=| \<one>]"
+      by (auto simp add: tpsK_break_def tpsB5_def)
+  qed
+qed
+
+definition tpsB6 :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsB6 zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> m then \<zero>
+           else if x \<le> m + 1 + m * length zs then \<one>
+           else 0,
+      1)]"
+
+definition esB56 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB56 n m \<equiv> map (Pair 1) (rev [0..<m + 1]) @ [(1, 0), (1, 1)]"
+
+definition esB6 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB6 n m \<equiv> esB5 n m @ esB56 n m"
+
+lemma length_esB6: "length (esB6 n m) \<le> 11 + 21 * m * m + 5 * m * m * n"
+proof -
+  have "length (esB6 n m) \<le> 8 + 20 * m * m + 5 * m * m * n + m + 3"
+    unfolding esB6_def esB56_def using length_esB5 by (simp add: ab_semigroup_add_class.add_ac(1))
+  also have "... = 11 + 20 * m * m + 5 * m * m * n + m"
+    by simp
+  also have "... \<le> 11 + 21 * m * m + 5 * m * m * n"
+    by simp
+  finally show ?thesis .
+qed
+
+lemma tmB6:
+  assumes "proper_symbols zs"
+  shows "traces tmB6 (tps_ones zs m) (esB6 (length zs) m) (tpsB6 zs m)"
+  unfolding tmB6_def esB6_def
+proof (rule traces_sequential[OF tmB5])
+  show "proper_symbols zs"
+    using assms .
+  show "traces (tm_cr 1) (tpsB5 zs m) (esB56 (length zs) m) (tpsB6 zs m)"
+  proof (rule traces_tm_cr_1I)
+    show "1 < length (tpsB5 zs m)"
+      using tpsB5_def by simp
+    show "clean_tape (tpsB5 zs m ! 1)"
+      using tpsB5_def clean_tape_def by simp
+    show "esB56 (length zs) m =
+        map (Pair (tpsB5 zs m :#: 0)) (rev [0..<tpsB5 zs m :#: 1]) @
+        [(tpsB5 zs m :#: 0, 0), (tpsB5 zs m :#: 0, 1)]"
+      by (simp add: esB56_def tpsB5_def)
+    show "tpsB6 zs m = (tpsB5 zs m)[1 := tpsB5 zs m ! 1 |#=| 1]"
+      by (simp add: tpsB6_def tpsB5_def)
+  qed
+qed
+
+definition tpsB7 :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsB7 zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> m + 1 + m * length zs then \<one>
+           else 0,
+      m + 1)]"
+
+definition esB67 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB67 n m \<equiv> map (\<lambda>i. (1, 1 + Suc i)) [0..<m] @ [(1, 1 + m)]"
+
+definition esB7 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB7 n m \<equiv> esB6 n m @ esB67 n m"
+
+lemma length_esB7: "length (esB7 n m) \<le> 12 + 22 * m * m + 5 * m * m * n"
+proof -
+  have "length (esB7 n m) \<le> 11 + 21 * m * m + 5 * m * m * n + m + 1"
+    unfolding esB7_def esB67_def
+    using length_esB6
+    by (smt add.commute add_Suc_right add_le_cancel_right length_append length_append_singleton
+      length_map length_upt minus_nat.diff_0 plus_1_eq_Suc)
+  also have "... \<le> 12 + 22 * m * m + 5 * m * m * n"
+    by simp
+  finally show ?thesis .
+qed
+
+lemma tmB7:
+  assumes "proper_symbols zs"
+  shows "traces tmB7 (tps_ones zs m) (esB7 (length zs) m) (tpsB7 zs m)"
+  unfolding tmB7_def esB7_def
+proof (rule traces_sequential[OF tmB6])
+  show "proper_symbols zs"
+    using assms .
+  show "traces (tm_const_until 1 1 {\<one>} \<one>) (tpsB6 zs m) (esB67 (length zs) m) (tpsB7 zs m)"
+  proof (rule traces_tm_const_until_11I)
+    show "1 < length (tpsB6 zs m)" "3 < G"
+      using tpsB6_def G G_ge4 by simp_all
+    show "rneigh (tpsB6 zs m ! 1) {\<one>} m"
+      using tpsB6_def by (intro rneighI) auto
+    show "esB67 (length zs) m =
+        map (\<lambda>i. (tpsB6 zs m :#: 0, tpsB6 zs m :#: 1 + Suc i)) [0..<m] @
+        [(tpsB6 zs m :#: 0, tpsB6 zs m :#: 1 + m)]"
+      by (simp add: tpsB6_def esB67_def)
+    show "tpsB7 zs m = (tpsB6 zs m) [1 := constplant (tpsB6 zs m ! 1) \<one> m]"
+      using constplant by (auto simp add: tpsB7_def tpsB6_def)
+  qed
+qed
+
+definition tpsB8 :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsB8 zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> m + 1 + m * length zs then \<one>
+           else 0,
+      1)]"
+
+definition esB78 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB78 n m \<equiv> map (Pair 1) (rev [0..<m + 1]) @ [(1, 0), (1, 1)]"
+
+definition esB8 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esB8 n m \<equiv> esB7 n m @ esB78 n m"
+
+lemma length_esB8: "length (esB8 n m) \<le> 15 + 23 * m * m + 5 * m * m * n"
+proof -
+  have "length (esB8 n m) \<le> 12 + 22 * m * m + 5 * m * m * n + m + 3"
+    unfolding esB8_def esB78_def using length_esB7 by (simp add: ab_semigroup_add_class.add_ac(1))
+  also have "... \<le> 15 + 23 * m * m + 5 * m * m * n"
+    by simp
+  finally show ?thesis .
+qed
+
+lemma tmB8:
+  assumes "proper_symbols zs"
+  shows "traces tmB8 (tps_ones zs m) (esB8 (length zs) m) (tpsB8 zs m)"
+  unfolding tmB8_def esB8_def
+proof (rule traces_sequential[OF tmB7])
+  show "proper_symbols zs"
+    using assms .
+  show "traces (tm_cr 1) (tpsB7 zs m) (esB78 (length zs) m) (tpsB8 zs m)"
+  proof (rule traces_tm_cr_1I)
+    show "1 < length (tpsB7 zs m)"
+      using tpsB7_def by simp
+    show "clean_tape (tpsB7 zs m ! 1)"
+      using tpsB7_def clean_tape_def by simp
+    show "esB78 (length zs) m =
+        map (Pair (tpsB7 zs m :#: 0)) (rev [0..<tpsB7 zs m :#: 1]) @
+        [(tpsB7 zs m :#: 0, 0), (tpsB7 zs m :#: 0, 1)]"
+      by (simp add: esB78_def tpsB7_def)
+    show "tpsB8 zs m = (tpsB7 zs m)[1 := tpsB7 zs m ! 1 |#=| 1]"
+      by (simp add: tpsB8_def tpsB7_def)
+  qed
+qed
+
+lemma tps_ones_eq_tpsB8: "tpsB8 zs m = tps_ones zs (1 + m * (length zs + 1))"
+  using tpsB8_def by auto
+
+lemma tmB:
+  assumes "proper_symbols zs"
+  shows "traces tmB (tps_ones zs m) (esB8 (length zs) m) (tps_ones zs (1 + m * (length zs + 1)))"
+  using assms tps_ones_eq_tpsB8 tmB8 tmB_eq_tmB8 by simp
+
+
+subsection \<open>Appending a fixed number of symbols\<close>
+
+text \<open>
+The next Turing machine appends a constant number $c$ of \textbf{1} symbols to
+the output tape.
+\<close>
+
+definition tmC :: "nat \<Rightarrow> machine" where
+  "tmC c \<equiv>
+    tm_right_until 1 {\<box>} ;;
+    tm_write_repeat 1 \<one> c ;;
+    tm_cr 1"
+
+lemma tmC_tm: "turing_machine 2 G (tmC c)"
+  unfolding tmC_def using tm_right_until_tm tm_write_repeat_tm tm_cr_tm G
+  by simp
+
+definition "tmC1 \<equiv> tm_right_until 1 {\<box>}"
+definition "tmC2 c \<equiv> tmC1 ;; tm_write_repeat 1 \<one> c"
+definition "tmC3 c \<equiv> tmC2 c ;; tm_cr 1"
+
+definition tpsC1 :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsC1 zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> m then \<one>
+           else 0,
+      m + 1)]"
+
+definition esC1 :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esC1 n m \<equiv> map (\<lambda>i. (1, 1 + Suc i)) [0..<m] @ [(1, 1 + m)]"
+
+lemma length_esC1: "length (esC1 n m) = m + 1"
+  unfolding esC1_def by simp
+
+lemma tmC1:
+  assumes "proper_symbols zs"
+  shows "traces tmC1 (tps5 zs m) (esC1 (length zs) m) (tpsC1 zs m)"
+  unfolding tmC1_def
+proof (rule traces_tm_right_until_1I[where ?n=m])
+  show "1 < length (tps5 zs m)"
+    using tps5_def by simp
+  show "rneigh (tps5 zs m ! 1) {0} m"
+    using rneigh_def tps5_def by simp
+  show "esC1 (length zs) m =
+      map (\<lambda>i. (tps5 zs m :#: 0, tps5 zs m :#: 1 + Suc i)) [0..<m] @
+      [(tps5 zs m :#: 0, tps5 zs m :#: 1 + m)]"
+    by (simp add: tps5_def esC1_def)
+  show "tpsC1 zs m = (tps5 zs m)[1 := tps5 zs m ! 1 |+| m]"
+    by (simp add: tps5_def tpsC1_def)
+qed
+
+definition tpsC2 :: "symbol list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsC2 zs m c \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> m + c then \<one>
+           else 0,
+      m + 1 + c)]"
+
+definition esC12 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esC12 n m c \<equiv> map (\<lambda>i. (1, m + 1 + Suc i)) [0..<c]"
+
+definition esC2 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esC2 n m c \<equiv> esC1 n m @ esC12 n m c"
+
+lemma length_esC2: "length (esC2 n m c) = m + 1 + c"
+  unfolding esC2_def by (simp add: length_esC1 esC12_def)
+
+lemma tmC2:
+  assumes "proper_symbols zs"
+  shows "traces (tmC2 c) (tps5 zs m) (esC2 (length zs) m c) (tpsC2 zs m c)"
+  unfolding tmC2_def esC2_def
+proof (rule traces_sequential[OF tmC1])
+  show "proper_symbols zs"
+    using assms .
+  show "traces (tm_write_repeat 1 \<one> c) (tpsC1 zs m) (esC12 (length zs) m c) (tpsC2 zs m c)"
+  proof (rule traces_tm_write_repeat_1I)
+    show "1 < length (tpsC1 zs m)"
+      using tpsC1_def by simp
+    show "esC12 (length zs) m c =
+        map (\<lambda>i. (tpsC1 zs m :#: 0, tpsC1 zs m :#: 1 + Suc i)) [0..<c]"
+      by (simp add: esC12_def tpsC1_def)
+    show "tpsC2 zs m c = (tpsC1 zs m)[1 := overwrite (tpsC1 zs m ! 1) \<one> c]"
+      by (auto simp add: tpsC2_def tpsC1_def overwrite_def)
+  qed
+qed
+
+definition tpsC3 :: "symbol list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tape list" where
+  "tpsC3 zs m c \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lambda>x. if x = 0 then \<triangleright>
+           else if x \<le> m + c then \<one>
+           else 0,
+      1)]"
+
+definition esC23 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esC23 n m c \<equiv> map (Pair 1) (rev [0..<m + 1 + c]) @ [(1, 0), (1, 1)]"
+
+definition esC3 :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "esC3 n m c \<equiv> esC2 n m c @ esC23 n m c"
+
+lemma length_esC3: "length (esC3 n m c) = 2 * m + 2 * c + 4"
+  unfolding esC3_def by (simp add: length_esC2 esC23_def)
+
+lemma tmC3:
+  assumes "proper_symbols zs"
+  shows "traces (tmC3 c) (tps5 zs m) (esC3 (length zs) m c) (tpsC3 zs m c)"
+  unfolding tmC3_def esC3_def
+proof (rule traces_sequential[OF tmC2])
+  show "proper_symbols zs"
+    using assms .
+  show "traces (tm_cr 1) (tpsC2 zs m c) (esC23 (length zs) m c) (tpsC3 zs m c)"
+  proof (rule traces_tm_cr_1I)
+    show "1 < length (tpsC2 zs m c)"
+      using tpsC2_def by simp
+    show "clean_tape (tpsC2 zs m c ! 1)"
+      using tpsC2_def clean_tape_def by simp
+    show "esC23 (length zs) m c =
+        map (Pair (tpsC2 zs m c :#: 0)) (rev [0..<tpsC2 zs m c :#: 1]) @
+        [(tpsC2 zs m c :#: 0, 0), (tpsC2 zs m c :#: 0, 1)]"
+      by (simp add: tpsC2_def esC23_def)
+    show "tpsC3 zs m c = (tpsC2 zs m c)[1 := tpsC2 zs m c ! 1 |#=| 1]"
+      by (simp add: tpsC2_def tpsC3_def)
+  qed
+qed
+
+lemma tpsC3_eq_tps5: "tpsC3 zs m c = tps5 zs (m + c)"
+  by (simp add: tpsC3_def tps5_def)
+
+lemma tmC3_eq_tmC: "tmC3 = tmC"
+  unfolding tmC_def tmC3_def tmC2_def tmC1_def by simp
+
+lemma tmC:
+  assumes "proper_symbols zs"
+  shows "traces (tmC c) (tps_ones zs m) (esC3 (length zs) m c) (tps_ones zs (m + c))"
+  using tmC3[OF assms] tmC3_eq_tmC tpsC3_eq_tps5 tps5_def by simp
+
+
+subsection \<open>Polynomials of higher degree\<close>
+
+text \<open>
+In order to construct polynomials of arbitrary degree, we repeat the TM @{term
+tmB}.
+\<close>
+
+fun tm_degree :: "nat \<Rightarrow> machine" where
+  "tm_degree 0 = []" |
+  "tm_degree (Suc d) = tm_degree d ;; tmB"
+
+lemma tm_degree_tm: "turing_machine 2 G (tm_degree d)"
+proof (induction d)
+  case 0
+  then show ?case
+    by (simp add: turing_machine_def)
+next
+  case (Suc d)
+  then show ?case
+    using turing_machine_def tmB_tm
+    by (metis tm_degree.simps(2) turing_machine_sequential_turing_machine)
+qed
+
+text \<open>
+The number of \textbf{1} symbols the TM @{term "tm_degree d"} outputs on an
+input of length $n$:
+\<close>
+
+fun m_degree :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
+  "m_degree n 0 = n" |
+  "m_degree n (Suc d) = 1 + m_degree n d * (n + 1)"
+
+fun es_degree :: "nat \<Rightarrow> nat \<Rightarrow> (nat * nat) list" where
+  "es_degree n 0 = []" |
+  "es_degree n (Suc d) = es_degree n d @ esB8 n (m_degree n d)"
+
+lemma tm_degree:
+  assumes "proper_symbols zs"
+  shows "traces
+    (tm_degree d)
+    (tps_ones zs (length zs))
+    (es_degree (length zs) d)
+    (tps_ones zs (m_degree (length zs) d))"
+proof (induction d)
+  case 0
+  then show ?case
+    by fastforce
+next
+  case (Suc d)
+  have "traces (tm_degree d ;; tmB)
+    (tps_ones zs (length zs))
+    (es_degree (length zs) d @ esB8 (length zs) (m_degree (length zs) d))
+    (tps_ones zs (m_degree (length zs) (Suc d)))"
+  proof (rule traces_sequential[OF Suc.IH])
+   show "traces tmB (tps_ones zs (m_degree (length zs) d))
+      (esB8 (length zs) (m_degree (length zs) d))
+      (tps_ones zs (m_degree (length zs) (Suc d)))"
+    using tmB[OF assms, of "m_degree (length zs) d"] m_degree.simps(2) by presburger
+  qed
+  then show ?case
+    by simp
+qed
+
+text \<open>
+A lower bound for the number of \textbf{1} symbols the TM @{term "tm_degree d"}
+outputs:
+\<close>
+
+lemma m_degree_ge_pow: "m_degree n d \<ge> n ^ (Suc d)"
+proof (induction d)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc d)
+  have "m_degree n (Suc d) = 1 + m_degree n d * (n + 1)"
+    by simp
+  then have "m_degree n (Suc d) \<ge> 1 + n ^ Suc d * (n + 1)"
+    using Suc by (simp add: add_mono_thms_linordered_semiring(1))
+  then have "m_degree n (Suc d) \<ge> 1 + n ^ Suc d * n + n ^ Suc d"
+    by simp
+  then have "m_degree n (Suc d) \<ge> 1 + n ^ (Suc (Suc d)) + n ^ Suc d"
+    by (metis power_Suc2)
+  then show ?case
+    by simp
+qed
+
+text \<open>
+An upper bound for the number of \textbf{1} symbols the TM @{term "tm_degree d"}
+outputs:
+\<close>
+
+lemma m_degree_poly: "big_oh_poly (\<lambda>n. m_degree n d)"
+proof (induction d)
+  case 0
+  have "(\<lambda>n. m_degree n 0) = (\<lambda>n. n)"
+    by simp
+  then show ?case
+    using big_oh_poly_poly[of 1] by simp
+next
+  case (Suc d)
+  have "big_oh_poly (\<lambda>n. n + 1)"
+    using big_oh_poly_sum[OF big_oh_poly_poly[of 1] big_oh_poly_const[of 1]]
+    by simp
+  then have "big_oh_poly (\<lambda>n. m_degree n d * (n + 1))"
+    using big_oh_poly_prod[OF Suc] by blast
+  then have "big_oh_poly (\<lambda>n. 1 + m_degree n d * (n + 1))"
+    using big_oh_poly_sum[OF big_oh_poly_const[of 1]] by simp
+  then show ?case
+    by simp
+qed
+
+corollary m_degree_plus_const_poly: "big_oh_poly (\<lambda>n. m_degree n d + c)"
+  using m_degree_poly big_oh_poly_sum big_oh_poly_const by simp
+
+lemma length_es_degree: "big_oh_poly (\<lambda>n. length (es_degree n d))"
+proof (induction d)
+  case 0
+  then show ?case
+    using big_oh_poly_const by simp
+next
+  case (Suc d)
+  have "big_oh_poly (\<lambda>n. length (esB8 n (m_degree n d)))"
+  proof -
+    let ?m = "\<lambda>n. m_degree n d"
+    have "big_oh_poly ?m"
+      using m_degree_poly by simp
+    then have "big_oh_poly (\<lambda>n. 15 + 23 * ?m n * ?m n + 5 * ?m n * ?m n * n)"
+      using big_oh_poly_sum big_oh_poly_const big_oh_poly_prod big_oh_poly_poly[of 1]
+      by simp
+    then show ?thesis
+      using length_esB8 big_oh_poly_le by simp
+  qed
+  then show ?case
+    using Suc big_oh_poly_sum by simp
+qed
+
+text \<open>
+Putting together the TM @{const tmA}, the TM @{term "tm_degree d"} for some $d$,
+and the TM @{term "tmC c"} for some $c$, we get a family of TMs parameterized by
+$d$ and $c$. These TMs construct all the polynomials we need.
+\<close>
+
+definition tm_poly :: "nat \<Rightarrow> nat \<Rightarrow> machine" where
+  "tm_poly d c \<equiv> tmA ;; (tm_degree d ;; tmC c)"
+
+lemma tm_poly_tm: "turing_machine 2 G (tm_poly d c)"
+  unfolding tm_poly_def using tmA_tm tm_degree_tm tmC_tm by simp
+
+definition es_poly :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) list" where
+  "es_poly n d c \<equiv> es5 n @ es_degree n d @ esC3 n (m_degree n d) c"
+
+text \<open>
+On an input of length $n$ the Turing machine @{term "tm_poly d c"} outputs
+@{term "m_degree n d + c"} symbols~@{text \<one>}.
+\<close>
+
+lemma tm_poly:
+  assumes "proper_symbols zs"
+  shows "traces
+    (tm_poly d c)
+    (tps0 zs)
+    (es_poly (length zs) d c)
+    (tps_ones zs (m_degree (length zs) d + c))"
+  unfolding tm_poly_def es_poly_def
+  using assms traces_sequential[OF tmA] traces_sequential[OF tm_degree] tmC
+  by simp
+
+text \<open>
+The Turing machines run in polynomial time because their traces have polynomial
+length:
+\<close>
+
+lemma length_es_poly: "big_oh_poly (\<lambda>n. length (es_poly n d c))"
+proof -
+  have "big_oh_poly (\<lambda>n. length (es5 n))"
+    using length_es5 big_oh_poly_const big_oh_poly_prod big_oh_poly_sum big_oh_poly_poly[of 1]
+    by simp
+  moreover have "big_oh_poly (\<lambda>n. length (esC3 n (m_degree n d) c))"
+  proof -
+    have *: "(\<lambda>n. length (esC3 n (m_degree n d) c)) = (\<lambda>n. 2 * (m_degree n d) + 2 * c + 4)"
+      using length_esC3 by fast
+    have "big_oh_poly (\<lambda>n. 2 * (m_degree n d) + 2 * c + 4)"
+      using m_degree_poly big_oh_poly_const big_oh_poly_prod big_oh_poly_sum by simp
+    then show ?thesis
+      by (simp add: *)
+  qed
+  ultimately have "big_oh_poly (\<lambda>n. length (es5 n) + length (es_degree n d) + length (esC3 n (m_degree n d) c))"
+    using length_es_degree big_oh_poly_sum by blast
+  then show ?thesis
+    by (simp add: es_poly_def add.assoc)
+qed
+
+text \<open>
+The Turing machine @{term "tm_poly d c"} outputs @{term "m_degree n c + c"} many
+@{text \<one>} symbols on an input of length $n$. Hence for every polynomially
+bounded function $f$ there is such a Turing machine outputting at least $f(n)$
+symbols @{text \<one>}.
+\<close>
+
+lemma m_degree_plus_const:
+  assumes "big_oh_poly f"
+  obtains d c where "\<forall>n. f n \<le> m_degree n d + c"
+proof -
+  obtain c m d where f: "\<forall>n>m. f n \<le> c * n ^ d"
+    using assms big_oh_poly by auto
+  let ?d = "Suc d"
+  let ?k = "max c m"
+  have "n ^ ?d \<ge> c * n ^ d" if "n > ?k" for n
+    using that by simp
+  moreover have "f n \<le> c * n ^ d" if "n > ?k" for n
+    using f that by simp
+  ultimately have 1: "f n \<le> n ^ ?d" if "n > ?k" for n
+    using that using order_trans by blast
+  define c' where "c' = Max {f n| n. n \<le> ?k}"
+  moreover have "finite {f n| n. n \<le> ?k}"
+    by simp
+  ultimately have "c' \<ge> f n" if "n \<le> ?k" for n
+    using that Max.bounded_iff by blast
+  then have "f n \<le> n ^ ?d + c'" if "n \<le> ?k" for n
+    by (simp add: that trans_le_add2)
+  moreover have "f n \<le> n ^ ?d + c'" if "n > ?k" for n
+    using that 1 by fastforce
+  ultimately have "f n \<le> n ^ ?d + c'" for n
+    using leI by blast
+  then have "f n \<le> m_degree n d + c'" for n
+    using m_degree_ge_pow by (meson le_diff_conv less_le_trans not_le)
+  then show ?thesis
+    using that by auto
+qed
+
+text \<open>
+The Turing machines are oblivious.
+\<close>
+
+lemma tm_poly_oblivious: "oblivious (tm_poly d c)"
+proof -
+  have tm: "turing_machine 2 G (tm_poly d c)"
+    using tm_poly_tm by simp
+  have init: "(0, tps0 zs) = start_config 2 zs" for zs
+    using tps0_def start_config_def contents_def by auto
+  {
+    fix zs
+    assume "bit_symbols zs"
+    then have proper: "proper_symbols zs"
+      by auto
+    define tps where "tps = tps_ones zs (m_degree (length zs) d + c)"
+    moreover define e where "e = (\<lambda>n. es_poly n d c)"
+    ultimately have "trace (tm_poly d c) (start_config 2 zs) (e (length zs)) (length (tm_poly d c), tps)"
+      using tm_poly init proper by (simp add: traces_def)
+  }
+  then show ?thesis
+    using tm oblivious_def by fast
+qed
+
+end  (* locale turing_machine_poly *)
+
+definition start_tapes_2 :: "symbol list \<Rightarrow> tape list" where
+  "start_tapes_2 zs \<equiv>
+    [(\<lfloor>zs\<rfloor>, 0),
+     (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)]"
+
+definition one_tapes_2 :: "symbol list \<Rightarrow> nat \<Rightarrow> tape list" where
+  "one_tapes_2 zs m \<equiv>
+    [(\<lfloor>zs\<rfloor>, 1),
+     (\<lfloor>replicate m \<one>\<rfloor>, 1)]"
+
+text \<open>
+The main result of this chapter. For every polynomially bounded function $g$
+there is a polynomial-time two-tape oblivious Turing machine that outputs at
+least $g(n)$ symbols~@{text \<one>} for every input length $n$.
+\<close>
+
+lemma polystructor:
+  assumes "big_oh_poly g" and "G \<ge> 5"
+  shows "\<exists>M es f.
+    turing_machine 2 G M \<and>
+    big_oh_poly (\<lambda>n. length (es n)) \<and>
+    big_oh_poly f \<and>
+    (\<forall>n. g n \<le> f n) \<and>
+    (\<forall>zs. proper_symbols zs \<longrightarrow> traces M (start_tapes_2 zs) (es (length zs)) (one_tapes_2 zs (f (length zs))))"
+proof -
+  interpret turing_machine_poly G
+    using assms(2) by (simp add: turing_machine_poly_def)
+  obtain d c where dc: "\<forall>n. g n \<le> m_degree n d + c"
+    using assms(1) m_degree_plus_const by auto
+  define M where "M = tm_poly d c"
+  define es where "es = (\<lambda>n. es_poly n d c)"
+  define f where "f = (\<lambda>n. m_degree n d + c)"
+  have "turing_machine 2 G M"
+    using M_def tm_poly_tm assms(2) by simp
+  moreover have "big_oh_poly (\<lambda>n. length (es n))"
+    using es_def length_es_poly by simp
+  moreover have "\<forall>n. g n \<le> f n"
+    using f_def dc by simp
+  moreover have "big_oh_poly f"
+    using f_def m_degree_plus_const_poly by simp
+  moreover have
+    "\<forall>zs. proper_symbols zs \<longrightarrow> traces M (start_tapes_2 zs) (es (length zs)) (one_tapes_2 zs (f (length zs)))"
+  proof (standard, standard)
+    fix zs
+    assume zs: "proper_symbols zs"
+    have "traces M (tps0 zs) (es (length zs)) (tps_ones zs (f (length zs)))"
+      unfolding M_def es_def f_def using tm_poly[OF zs, of d c] by simp
+    moreover have "tps0 = start_tapes_2"
+      using tps0_def start_tapes_2_def by presburger
+    ultimately have "traces M (start_tapes_2 zs) (es (length zs)) (tps_ones zs (f (length zs)))"
+      by simp
+    moreover have "one_tapes_2 = tps_ones"
+      using one_tapes_2_def contents_def by fastforce
+    ultimately show "traces M (start_tapes_2 zs) (es (length zs)) (one_tapes_2 zs (f (length zs)))"
+      by metis
+  qed
+  ultimately show ?thesis
+    by auto
+qed
+
+end
\ No newline at end of file
diff --git a/thys/Cook_Levin/ROOT b/thys/Cook_Levin/ROOT
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/ROOT
@@ -0,0 +1,29 @@
+chapter AFP
+
+session Cook_Levin (AFP) = "HOL-Analysis" +
+  options [timeout = 1800]
+  sessions
+    "HOL-Eisbach"
+  theories
+    Basics
+    Combinations
+    Elementary
+    Memorizing
+    Composing
+    Arithmetic
+    Lists_Lists
+    Two_Four_Symbols
+    Symbol_Ops
+    Wellformed
+    NP
+    Satisfiability
+    Oblivious
+    Oblivious_Polynomial
+    Oblivious_2_Tape
+    Reducing
+    Aux_TM_Reducing
+    Sat_TM_CNF
+    Reduction_TM
+  document_files
+    "root.tex"
+    "root.bib"
diff --git a/thys/Cook_Levin/Reducing.thy b/thys/Cook_Levin/Reducing.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Reducing.thy
@@ -0,0 +1,3276 @@
+chapter \<open>Reducing $\NP$ languages to \SAT{}\label{s:Reducing}\<close>
+
+theory Reducing
+  imports Satisfiability Oblivious
+begin
+
+text \<open>
+We have already shown that \SAT{} is in $\NP$. It remains to show that \SAT{} is
+$\NP$-hard, that is, that every language $L \in \NP$ can be polynomial-time
+reduced to \SAT{}. This, in turn, can be split in two parts. First, showing that
+for every $x$ there is a CNF formula $\Phi$ such that $x\in L$ iff.\ $\Phi$ is
+satisfiable. Second, that $\Phi$ can be computed from $x$ in polynomial time.
+This chapter is devoted to the first part, which is the core of the proof. In
+the subsequent two chapters we painstakingly construct a polynomial-time Turing
+machine computing $\Phi$ from $x$ in order to show something that is usually
+considered ``obvious''.
+
+The proof corresponds to lemma~2.11 from the textbook~\cite{ccama}. Of course we
+have to be much more explicit than the textbook, and the first section describes
+in some detail how we derive the formula $\Phi$.
+\<close>
+
+
+section \<open>Introduction\<close>
+
+text \<open>
+Let $L \in \NP$. In order to reduce $L$ to \SAT{}, we need to construct for
+every string $x\in\bbOI^*$ a CNF formula $\Phi$ such that $x\in L$ iff.\ $\Phi$
+is satisfiable. In this section we describe how $\Phi$ looks like.
+
+
+\subsection{Preliminaries}
+
+We denote the length of a string $s\in\bbOI^*$ by $|s|$. We define
+\[
+    num(s) = \left\{\begin{array}{ll}
+        k       & \text{if } s = \bbbI^k\bbbO^{|s|-k},\\
+        |s| + 1 & \text{otherwise.}
+    \end{array}\right.
+\]
+Essentially $num$ interprets some strings as unary codes of numbers. All other
+strings are interpreted as an ``error value''.
+
+For a string $s$ and a sequence $w\in\nat^n$ of numbers we write $s(w)$ for
+$num(s_{w_0}\dots s_{w_{n-1}})$. Likewise for an assignment $\alpha\colon \nat
+\to \bbOI$ we write $\alpha(w) = num(\alpha(w_0)\dots\alpha(w_{n-1}))$.
+
+We define two families of CNF formulas. Variables are written $v_0, v_1, v_2,
+\dots$, and negated variables are written $\bar v_0, \bar v_1, \bar v_2, \dots$
+Let $w\in\nat^n$ be a list of numbers. For $k \leq n$ define
+\[
+    \Psi(w, k) = \bigwedge_{i=0}^{k-1} v_{w_i} \land \bigwedge_{i=k}^{n - 1}
+    \bar v_{w_i}.
+\]
+This formula is satisfied by an assignment $\alpha$ iff.\ $\alpha(w) = k$.  In a
+similar fashion we define for $n > 2$,
+\[
+    \Upsilon(w) = v_{w_0} \land v_{w_1} \land \bigwedge_{i=3}^{n - 1} \bar v_{w_i},
+\]
+which is satisfied by an assignment $\alpha$ iff.\ $\alpha(w) \in \{2, 3\} =
+\{\mathbf{0}, \mathbf{1}\}$, where as usual the boldface $\mathbf{0}$ and
+$\mathbf{1}$ refer to the symbols represented by the numbers~2 and~3.
+
+For $a \leq b$ we write $[a:b]$ for the interval $[a, \dots, b - 1] \in \nat^{b
+- a}$. For intervals the CNF formulas become:
+\[
+    \Psi([a:b], k) = \bigwedge_{i=a}^{a+k-1} v_i \land \bigwedge_{i=a+k}^{b - 1}
+    \bar v_i
+\qquad \text{and} \qquad
+    \Upsilon([a:b]) = v_a \land v_{a+1} \land \bigwedge_{i=a+3}^{b - 1} \bar v_i.
+\]
+
+Let $\phi$ be a CNF formula and let $\sigma\in\nat^*$ be a sequence of variable
+indices such that for all variables $v_i$ occurring in $\phi$ we have $i <
+|\sigma|$. Then we define the CNF formula $\sigma(\phi)$ as the formula
+resulting from replacing every variable $v_i$ in $\phi$ by the variable
+$v_{\sigma_i}$. This corresponds to our function @{const relabel}.
+
+
+\subsection{Construction of the CNF formula}
+
+Let $M$ be the two-tape oblivious verifier Turing machine for $L$ from
+lemma~@{text NP_imp_oblivious_2tape}. Let $p$ be the polynomial function for the
+length of the certificates, and let $T\colon \nat \to \nat$ be the polynomial
+running-time bound. Let $G$ be $M$'s alphabet size.
+
+Let $x\in\bbOI^n$ be fixed thoughout the rest of this section. We seek a CNF
+formula $\Phi$ that is satisfiable iff.\ $x\in L$. We are going to transform
+``$x\in L$'' via several equivalent statements to the statement ``$\Phi$ is
+satisfiable'' for a suitable $\Phi$ defined along the way.  The Isabelle
+formalization later in this chapter does not prove these equivalences
+explicitly.  They are only meant to explain the shape of $\Phi$.
+
+
+\subsubsection{1st equivalence}
+
+From lemma~@{text NP_imp_oblivious_2tape} about $M$ we get the first equivalent
+statement: There exists a certificate $u \in \bbOI^{p(n)}$
+such that $M$ on input $\langle x, u\rangle$ halts with the symbol \textbf{1}
+under its output tape head.  The running time of $M$ is bounded by $T(|\langle
+x, u\rangle|) = T(2n+2+2p(n))$. We abbreviate $|\langle x, u\rangle| = 2n+2+2p(n)$
+by $m$.
+
+
+\subsubsection{2nd equivalence}
+
+For the second equivalent statement, we define what the textbook calls
+``snapshots''.  For every $u\in\{\bbbO,\bbbI\}^{p(n)}$ let $z_0^u(t)$ be the
+symbol under the input tape head of $M$ on input $\langle x, u\rangle$ at step
+$t$. Similarly we define $z_1^u(t)$ as the symbol under the output tape head of
+$M$ at step $t$ and $z_2^u(t)$ as the state $M$ is in at step $t$.  A triple
+$z^u(t) = (z^u_0(t), z^u_1(t), z^u_2(t))$ is called a snapshot. For the initial
+snapshot we have:
+\begin{equation}
+    z_0^u(0) = z_1^u(0) = \triangleright\qquad\text{and}\qquad z_2^u(0) = 0.
+    \tag{Z0}
+\end{equation}
+
+The crucial idea is that the snapshots for $t > 0$ can be characterized
+recursively using two auxiliary functions $\inputpos$ and $\prev$.
+
+Since $M$ is oblivious, the positions of the tape heads on input $\langle x,
+u\rangle$ after $t$ steps are the same for all $u$ of length $p(n)$. We denote
+the input head positions by $\inputpos(t)$.
+
+For every $t$ we denote by $\prev(t)$ the last step before $t$ in which the
+output tape head of $M$ was in the same cell as in step $t$. Due to $M$'s
+obliviousness this is again the same for all $u$ of length $p(n)$. If there is
+no such previous step, because $t$ is the first time the cell is reached, we set
+$\prev(t) = t$. (This deviates from the textbook, which sets $\prev(t) = 1$.) In
+the other case we have $\prev(t) < t$.
+
+Also due to $M$'s obliviousness, the halting time on input $\langle x, u\rangle$
+is the same for all $u$ of length $p(n)$, and we denote it by $T' \le T(|\langle
+x, u\rangle|)$.  Thus we have $\inputpos(t) \le T'$ for all $t$. If we define
+the symbol sequence $y(u) = \triangleright \langle x, u\rangle \Box^{T'}$, the
+first component of the snapshots is, for arbitrary $t$:
+\begin{equation}
+    z_0^u(t) = y(u)_{\inputpos(t)}.
+    \tag{Z1}
+\end{equation}
+
+Next we consider the snapshot components $z_1^u(t)$ for $t > 0$. First consider
+the case $\prev(t) < t$; that is, the last time before $t$ when $M$'s output
+tape head was in the same cell as in step $t$ was in step $\prev(t)$. The
+snapshot for step $\prev(t)$ has exactly the information needed to calculate the
+actions of $M$ at step $t$: the symbols read from both tapes and the state which
+$M$ is in. In some sort of hybrid notation:
+\begin{equation}
+    z_1^u(t) = (M\ !\ z_2^u(\prev(t)))\ [z_0^u(\prev(t)), z_1^u(\prev(t))]\ [.]\ 1.
+    \tag{Z2}
+\end{equation}
+In the other case, $\prev(t) = t$, the output tape head has not been in this
+cell before and is thus reading a blank. It cannot be reading the start symbol
+because the output tape head was in cell zero at step $t = 0$ already. Formally:
+\begin{equation}
+    z_1^u(t) = \Box.
+    \tag{Z3}
+\end{equation}
+
+The state $z_2^u(t)$ for $t > 0$ can be computed from the state $z_2^u(t-1)$ in
+the previous step and the symbols $z_0^u(t-1)$ and $z_1^u(t-1)$ read in the
+previous step:
+\begin{equation}
+    z_2^u(t) = \mathit{fst}\ ((M\ !\ z_2^u(t - 1))\ [z_0^u(t - 1), z_1^u(t - 1)]).
+    \tag{Z4}
+\end{equation}
+
+For a string $u\in\bbOI^{p(n)}$ the equations (Z0) -- (Z4) uniquely determine
+all the $z^u(0), \dots, z^u(T')$. Conversely, the snapshots for $u$ satisfy all
+the equations. Therefore the equations characterize the sequence of snapshots.
+
+The condition that $M$ halts with the output tape head on \textbf{1} can be
+expressed with snapshots:
+\begin{equation}
+    z_1^{u}(T') = \mathbf{1}.
+    \tag{Z5}
+\end{equation}
+
+This yields our second equivalent statement: $x\in L$ iff.\ there is a
+$u\in\{\bbbO,\bbbI\}^{p(n)}$ and a sequence $z^u(0), \dots, z^u(T')$ satisfying
+the equations (Z0) -- (Z5).
+
+
+\subsubsection{3rd equivalence}
+
+The length of $y(u)$ is $m' := m + 1 + T' = 3 + 2n + 2p(n) + T'$ because
+$|\langle x, u\rangle| = m$ plus the start symbol plus the $T'$ blanks.
+
+For the next equivalence we observe that the strings $y(u)$ for
+$u\in\{\bbbO,\bbbI\}^{p(n)}$ can be characterized as follows. Consider
+a predicate on strings $y$:
+\begin{itemize}
+    \item[(Y0)] $|y| = m'$;
+    \item[(Y1)] $y_0 = \triangleright$ (the start symbol);
+    \item[(Y2)] $y_{2n+1} = y_{2n+2} = \mathbf{1}$
+        (the separator in the pair encoding);
+    \item[(Y3)] $y_{2i+1} = \mathbf{0}$ for $i=0,\dots,n-1$ (the zeros
+        before $x$);
+    \item[(Y4)] $y_{2n+2+2i+1} = \mathbf{0}$ for $i=0, \dots, p(n)-1$ (the
+        zeros before $u$);
+    \item[(Y5)] $y_{2n+2p(n)+3+i} = \Box$ for $i=0, \dots, T' - 1$ (the
+        blanks after the input proper);
+    \item[(Y6)] $y_{2i+2} = \left\{\begin{array}{ll}
+        \mathbf{0} & \text{if } x_i = \bbbO,\\
+        \mathbf{1} & \text{otherwise}
+      \end{array}\right.$ for $i = 0, \dots, n - 1$ (the bits of $x$);
+    \item[(Y7)] $y_{2n+4+2i} \in \{\mathbf{0}, \mathbf{1}\}$ for $i=0,\dots,p(n)-1$
+        (the bits of $u$).
+\end{itemize}
+Every $y(u)$ for some $u$ of length $p(n)$ satisfies this predicate. Conversely,
+from a $y$ satisfying the predicate, a $u$ of length $p(n)$ can be extracted
+such that $y = y(u)$.
+
+From that we get the third equivalent statement: $x \in L$ iff.\ there is a $y
+\in \{0, \dots, G - 1\}^{m'}$ with (Y0) -- (Y7) and a sequence $z^u(0), \dots,
+z^u(T')$ with (Z0) -- (Z5).
+
+
+\subsubsection{4th equivalence}
+
+Each element of $y$ is a symbol from $M$'s alphabet, that is, a number less than
+$G$. The same goes for the first two elements of each snapshot, $z_0^u(t)$ and
+$z_1^u(t)$.  The third element, $z_2^u(t)$, is a number less than or equal to
+the number of states of $M$. Let $H$ be the maximum of $G$ and the number of
+states.  Every element of $y$ and of the snapshots can then be represented by a
+bit string of length $H$ using $num$ (the textbook uses binary, but unary is
+simpler for us).  So we use $3H$ bits to represent one snapshot. There are $T' +
+1$ snapshots until $M$ halts. Thus all elements of all snapshots can be
+represented by a string of length $3H\cdot(T'+1)$. Together with the string of
+length $N := H\cdot m'$ for the input tape contents $y$, we have a total length
+of $N + 3H\cdot(T'+1)$.
+
+The equivalence can thus be stated as $x \in L$ iff.\ there is a string $s\in
+\{\bbbO,\bbbI\}^{N + 3H\cdot(T'+1)}$ with certain properties. To write these
+properties we introduce some intervals:
+\begin{itemize}
+    \item $\gamma_i = [iH : (i+1)H]$ for $i < m'$,
+    \item $\zeta_0(t) = [N + 3Ht : N+3Ht + H]$ for $t \leq T'$,
+    \item $\zeta_1(t) = [N + 3Ht + H : N+3Ht + 2H]$ for $t \leq T'$,
+    \item $\zeta_2(t) = [N + 3Ht + 2H : N+3H(t + 1)]$ for $t \leq T'$.
+\end{itemize}
+These intervals slice the string $s$ in intervals of length $H$.  The string $s$
+must satisfy properties analogous to (Y0) -- (Y7), which we express using the
+intervals $\gamma_i$:
+
+\begin{itemize}
+    \item[(Y0)] $|s| = N + 3H(T' + 1)$
+    \item[(Y1)] $s(\gamma_0) = \triangleright$ (the start symbol);
+    \item[(Y2)] $s(\gamma_{2n+1}) = s(\gamma_{2n+2}) = \mathbf{1}$
+        (the separator in the pair encoding);
+    \item[(Y3)] $s(\gamma_{2i+1}) = \mathbf{0}$ for $i=0,\dots,n-1$ (the zeros
+        before $x$);
+    \item[(Y4)] $s(\gamma_{2n+2+2i+1}) = \mathbf{0}$ for $i=0,\dots,p(n)-1$ (the
+        zeros before $u$);
+    \item[(Y5)] $s(\gamma_{2n+2p(n)+3+i}) = \Box$ for $i=0,\dots,T' - 1$ (the
+        blanks after the input proper);
+    \item[(Y6)] $s(\gamma_{2i+2}) = \left\{\begin{array}{ll}
+        \mathbf{0} & \text{if } x_i = \bbbO,\\
+        \mathbf{1} & \text{otherwise}
+      \end{array}\right.$ for $i = 0, \dots, n - 1$ (the bits of $x$);
+    \item[(Y7)] $s(\gamma_{2n+4+2i}) \in \{\mathbf{0}, \mathbf{1}\}$ for $i=0,\dots,p(n)-1$
+        (the bits of $u$).
+\end{itemize}
+
+Moreover the string $s$ must satisfy (Z0) -- (Z5).  For these properties we use
+the $\zeta$ intervals.
+\begin{itemize}
+    \item[(Z0)] $s(\zeta_0(0)) = s(\zeta_1(0)) = \triangleright$ and $s(\zeta_2(0)) = 0$,
+    \item[(Z1)] $s(\zeta_0(t)) = s(\gamma_{\inputpos(t)})$ for $t = 1, \dots, T'$,
+    \item[(Z2)] $s(\zeta_1(t)) = (M\ !\ s(\zeta_2(\prev(t)))\ [s(\zeta_0(\prev(t))), s(\zeta_1(\prev(t)))]\ [.]\ 1$
+        for $t = 1, \dots, T'$ with $\prev(t) < t$,
+    \item[(Z3)] $s(\zeta_1(t)) = \Box$ for $t = 1, \dots, T'$ with $\prev(t) = t$,
+    \item[(Z4)] $s(\zeta_2(t)) = \mathit{fst}\ ((M\ !\ s(\zeta_2(t - 1))\ [s(\zeta_0(t - 1), s(\zeta_1(t - 1)])$
+        for $t = 1, \dots, T'$,
+    \item[(Z5)] $s(\zeta_1(T')) = \mathbf{1}$.
+\end{itemize}
+
+
+\subsubsection{5th equivalence}
+
+An assignment is an infinite bit string. For formulas over variables with
+indices in the interval $[0 : N+3H(T'+1)]$, only the initial $N+3H(T'+1)$ bits of
+the assignment are relevant. If we had a CNF formula $\Phi$ over these variables
+that is satisfied exactly by the assignments $\alpha$ for which there is an $s$
+with the above properties and $\alpha(i) = s_i$ for all $i < |s|$, then the
+existence of such an $s$ would be equivalent to $\Phi$ being satisfiable.
+
+Next we construct such a CNF formula.
+
+Most properties are easy to translate using the formulas $\Psi$ and $\Upsilon$.
+For example, $s(\gamma_0) = \triangleright$ corresponds to $\alpha(\gamma_0) =
+\triangleright$.  A formula that is satisfied exactly by assignments with this
+property is $\Psi(\gamma_0, 1)$. Likewise the property
+$s(\gamma_{2n+4+2i})\in\{\mathbf{0}, \mathbf{1}\}$ corresponds to the CNF
+formula $\Upsilon(\gamma_{2n+4+2i})$.
+
+Property (Y0) corresponds to $\Phi$ having only variables $0, \dots, N+3H(T'+1)
+- 1$. The other (Y$\cdot$) properties become:
+\begin{itemize}
+    \item[(Y1)] $\Phi_1 := \Psi(\gamma_0, 1)$,
+    \item[(Y2)] $\Phi_2 := \Psi(\gamma_{2n+1}, 3) \land \Psi(\gamma_{2n+2}, 3)$,
+    \item[(Y3)] $\Phi_3 := \bigwedge_{i=0}^{n-1}\Psi(\gamma_{2i+1}, 2)$,
+    \item[(Y4)] $\Phi_4 := \bigwedge_{i=0}^{p(n) - 1}\Psi(\gamma_{2n+2+2i+1}, 2)$,
+    \item[(Y5)] $\Phi_5 := \bigwedge_{i=0}^{T' - 1}\Psi(\gamma_{2n+2p(n)+3+i}, 0)$,
+    \item[(Y6)] $\Phi_6 := \bigwedge_{i=0}^{n - 1}\Psi(\gamma_{2i+2}, x_i + 2)$,
+    \item[(Y7)] $\Phi_7 := \bigwedge_{i=0}^{p(n) - 1}\Upsilon(\gamma_{2n+4+2i})$.
+\end{itemize}
+
+Property~(Z0) and property~(Z5) become these formulas:
+\begin{itemize}
+    \item[(Z0)] $\Phi_0 := \Psi(\zeta_0(0), 1) \land \Psi(\zeta_1(0), 1) \land \Psi(\zeta_2(0), 0)$,
+    \item[(Z5)] $\Phi_8 := \Psi(\zeta_1(T'), 3)$.
+\end{itemize}
+
+The remaining properties (Z1) -- (Z4) are more complex. They apply to $t = 1,
+\dots T'$. Let us first consider the case $\prev(t) < t$. With $\alpha$ for $s$
+the properties become:
+\begin{itemize}
+    \item[(Z1)] $\alpha(\zeta_0(t)) = \alpha(\gamma_{\inputpos(t)})$,
+    \item[(Z2)] $\alpha(\zeta_1(t)) =
+        ((M\ !\ \alpha(\zeta_2(\prev(t))))\ [\alpha(\zeta_0(\prev(t))), \alpha(\zeta_1(\prev(t)))])\ [.]\ 1$,
+    \item[(Z4)] $\alpha(\zeta_2(t)) =
+        \mathit{fst}\ ((M\ !\ \alpha(\zeta_2(t-1)))\ [\alpha(\zeta_0(t-1)), \alpha(\zeta_1(t-1))])$.
+\end{itemize}
+
+For any $t$ the properties (Z1), (Z2), (Z4) use at most $10H$ variable indices,
+namely all the variable indices in the nine $\zeta$'s and in
+$\gamma_{\inputpos(t)}$, each of which have $H$ indices.
+
+Now if the set of all these variable indices was $\{0, \dots, 10H - 1\}$ we
+could apply lemma~@{thm [source] depon_ex_formula} to get a CNF formula $\psi$
+over these variables that ``captures the spirit'' of the properties. We would
+then merely have to relabel the formula with the actual variable indices we need
+for each $t$.  More precisely, let $w_i = [iH : (i+1)H]$ for $i = 0, \dots, 9$
+and consider the following criterion for $\alpha$ on the variable indices $\{0,
+\dots 10H - 1\}$:
+\begin{itemize}
+    \item[($\mathrm{F}_1$)] $\alpha(w_6) = \alpha(w_9)$,
+    \item[($\mathrm{F}_2$)] $\alpha(w_7) =
+        ((M\ !\ \alpha(w_5))\ [\alpha(w_3), \alpha(w_4)])\ [.]\ 1,$
+    \item[($\mathrm{F}_3$)] $\alpha(w_8) =
+        \mathit{fst}\ ((M\ !\ \alpha(w_2))\ [\alpha(w_0), \alpha(w_1)]).$
+\end{itemize}
+Lemma~@{thm [source] depon_ex_formula} gives us a formula $\psi$ satisfied
+exactly by those assignments $\alpha$ that meet the conditions ($\mathrm{F}_1$),
+($\mathrm{F}_2$), ($\mathrm{F}_3$).  From this $\psi$ we can create all the
+formulas we need for representing the properties~(Z1), (Z2), (Z4) by
+substituting (``relabeling'' in our terminology) the variables $[0,10H)$
+appropriately. The substitution for step $t$ is
+\[
+    \rho_t = \zeta_0(t-1) \circ \zeta_1(t-1) \circ \zeta_2(t-1) \circ
+    \zeta_0(\prev(t)) \circ \zeta_1(\prev(t)) \circ \zeta_2(\prev(t)) \circ \zeta_0(t)
+    \circ \zeta_1(t) \circ \zeta_2(t) \circ \gamma_{\inputpos(t)},
+\]
+where $\circ$ denotes the concatenation of lists. Then $\rho_t(\psi)$ is CNF
+formula satisfied exactly by the assignments $\alpha$ satisfying (Z1), (Z2),
+(Z4).
+
+For the case $\prev(t) = t$ we have a criterion on the variable indices
+$\{0, \dots, 7H - 1\}$:
+\begin{itemize}
+    \item[($\mathrm{F}_1'$)] $\alpha(w_3) = \alpha(w_6)$,
+    \item[($\mathrm{F}_2'$)] $\alpha(w_4) = \Box$,
+    \item[($\mathrm{F}_3'$)] $\alpha(w_5) = \mathit{fst}\ ((M\ !\ \alpha(w_2))\ [\alpha(w_0), \alpha(w_1)])$,
+\end{itemize}
+whence lemma~@{thm [source] depon_ex_formula} supplies us with a formula
+$\psi'$.  With appropriate substitutions
+\[
+    \rho'_t = \zeta_0(t-1) \circ \zeta_1(t-1) \circ \zeta_2(t-1) \circ
+    \zeta_0(t) \circ \zeta_1(t) \circ \zeta_2(t) \circ \gamma_{\inputpos(t)},
+\]
+we then define CNF formulas $\chi_t$ for all $t = 1, \dots, T'$:
+\[
+    \chi_t = \left\{\begin{array}{ll}
+        \rho_t(\psi)   &\text{if }\prev(t) < t,\\
+        \rho'_t(\psi') &\text{if }\prev(t) = t.
+    \end{array}\right.
+\]
+
+The point of all that is that we can hard-code $\psi$ and $\psi'$ in the TM
+performing the reduction (to be built in the final chapter) and for each $t$ the
+TM only needs to construct the substitution $\rho_t$ or $\rho_t'$ and perform
+the relabeling. Turing machines that perform these operations will be
+constructed in the next chapter.
+
+Since all $\chi_t$ are in CNF, so is the conjunction
+\[
+    \Phi_9 := \bigwedge_{t=1}^{T'}\chi_t\ .
+\]
+
+Finally the complete CNF formula is:
+\[
+    \Phi := \Phi_0 \land \Phi_1 \land
+     \Phi_2 \land \Phi_3 \land
+     \Phi_4 \land \Phi_5 \land
+     \Phi_6 \land \Phi_7 \land
+     \Phi_8 \land \Phi_9\ .
+\]
+\<close>
+
+
+section \<open>Auxiliary CNF formulas\<close>
+
+text \<open>
+In this section we define the CNF formula families $\Psi$ and $\Upsilon$.  In
+the introduction both families were parameterized by intervals of natural
+numbers. Here we generalize the definition to allow arbitrary sequences of
+numbers although we will not need this generalization.
+\<close>
+
+text \<open>
+The number of variables set to true in a list of variables:
+\<close>
+
+definition numtrue :: "assignment \<Rightarrow> nat list \<Rightarrow> nat" where
+  "numtrue \<alpha> vs \<equiv> length (filter \<alpha> vs)"
+
+text \<open>
+Checking whether the list of bits assigned to a list @{term vs} of variables has
+the form $\bbbI\dots\bbbI\bbbO\dots\bbbO$:
+\<close>
+
+definition blocky :: "assignment \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool" where
+  "blocky \<alpha> vs k \<equiv> \<forall>i<length vs. \<alpha> (vs ! i) \<longleftrightarrow> i < k"
+
+text \<open>
+The next function represents the notation $\alpha(\gamma)$ from the
+introduction, albeit generalized to lists that are not intervals $\gamma$.
+\<close>
+
+definition unary :: "assignment \<Rightarrow> nat list \<Rightarrow> nat" where
+  "unary \<alpha> vs \<equiv> if (\<exists>k. blocky \<alpha> vs k) then numtrue \<alpha> vs else Suc (length vs)"
+
+lemma numtrue_remap:
+  assumes "\<forall>s\<in>set seq. s < length \<sigma>"
+  shows "numtrue (remap \<sigma> \<alpha>) seq = numtrue \<alpha> (reseq \<sigma> seq)"
+proof -
+  have *: "length (filter f xs) = length (filter (f \<circ> ((!) xs)) [0..<length xs])" for f and xs :: "'a list"
+    using length_filter_map map_nth by metis
+
+  let ?s_alpha = "remap \<sigma> \<alpha>"
+  let ?s_seq = "reseq \<sigma> seq"
+  have "numtrue ?s_alpha seq = length (filter ?s_alpha seq)"
+    using numtrue_def by simp
+  then have lhs: "numtrue ?s_alpha seq = length (filter (?s_alpha \<circ> ((!) seq)) [0..<length seq])"
+    using * by auto
+
+  have "numtrue \<alpha> ?s_seq = length (filter \<alpha> ?s_seq)"
+    using numtrue_def by simp
+  then have "numtrue \<alpha> ?s_seq = length (filter (\<alpha> \<circ> ((!) ?s_seq)) [0..<length ?s_seq])"
+    using * by metis
+  then have rhs: "numtrue \<alpha> ?s_seq = length (filter (\<alpha> \<circ> ((!) ?s_seq)) [0..<length seq])"
+    using reseq_def by simp
+
+  have "(?s_alpha \<circ> ((!) seq)) i = (\<alpha> \<circ> ((!) ?s_seq)) i" if "i < length seq" for i
+    using assms remap_def reseq_def that by simp
+  then show ?thesis
+    using lhs rhs by (metis atLeastLessThan_iff filter_cong set_upt)
+qed
+
+lemma unary_remap:
+  assumes "\<forall>s\<in>set seq. s < length \<sigma>"
+  shows "unary (remap \<sigma> \<alpha>) seq = unary \<alpha> (reseq \<sigma> seq)"
+proof -
+  have *: "blocky (remap \<sigma> \<alpha>) seq k = blocky \<alpha> (reseq \<sigma> seq) k" for k
+    using blocky_def remap_def reseq_def assms by simp
+  let ?alpha = "remap \<sigma> \<alpha>" and ?seq = "reseq \<sigma> seq"
+  show ?thesis
+  proof (cases "\<exists>k. blocky ?alpha seq k")
+    case True
+    then show ?thesis
+      using * unary_def numtrue_remap assms by simp
+  next
+    case False
+    then have "unary ?alpha seq = Suc (length seq)"
+      using unary_def by simp
+    moreover have "\<not> (\<exists>k. blocky \<alpha> ?seq k)"
+      using False * assms by simp
+    ultimately show ?thesis
+      using unary_def by simp
+  qed
+qed
+
+text \<open>
+Now we define the family $\Psi$ of CNF formulas. It is parameterized by a list
+@{term vs} of variable indices and a number $k \leq |\mathit{vs}|$. The formula
+is satisfied exactly by those assignments that set to true the first $k$
+variables in $vs$ and to false the other variables. This is more general than we
+need, because for us $vs$ will always be an interval.
+\<close>
+
+definition Psi :: "nat list \<Rightarrow> nat \<Rightarrow> formula" ("\<Psi>") where
+  "\<Psi> vs k \<equiv> map (\<lambda>s. [Pos s]) (take k vs) @ map (\<lambda>s. [Neg s]) (drop k vs)"
+
+lemma Psi_unary:
+  assumes "k \<le> length vs" and "\<alpha> \<Turnstile> \<Psi> vs k"
+  shows "unary \<alpha> vs = k"
+proof -
+  have "\<alpha> \<Turnstile> map (\<lambda>s. [Pos s]) (take k vs)"
+    using satisfies_def assms Psi_def by simp
+  then have "satisfies_clause \<alpha> [Pos v]" if "v \<in> set (take k vs)" for v
+    using satisfies_def that by simp
+  then have "satisfies_literal \<alpha> (Pos v)" if "v \<in> set (take k vs)" for v
+    using satisfies_clause_def that by simp
+  then have pos: "\<alpha> v" if "v \<in> set (take k vs)" for v
+    using that by simp
+
+  have "\<alpha> \<Turnstile> map (\<lambda>s. [Neg s]) (drop k vs)"
+    using satisfies_def assms Psi_def by simp
+  then have "satisfies_clause \<alpha> [Neg v]" if "v \<in> set (drop k vs)" for v
+    using satisfies_def that by simp
+  then have "satisfies_literal \<alpha> (Neg v)" if "v \<in> set (drop k vs)" for v
+    using satisfies_clause_def that by simp
+  then have neg: "\<not> \<alpha> v" if "v \<in> set (drop k vs)" for v
+    using that by simp
+
+  have "blocky \<alpha> vs k"
+  proof -
+    have "\<alpha> (vs ! i)" if "i < k" for i
+      using pos that assms(1) by (metis in_set_conv_nth length_take min_absorb2 nth_take)
+    moreover have "\<not> \<alpha> (vs ! i)" if "i \<ge> k" "i < length vs" for i
+      using that assms(1) neg
+      by (metis Cons_nth_drop_Suc list.set_intros(1) set_drop_subset_set_drop subsetD)
+    ultimately show ?thesis
+      using blocky_def by (metis linorder_not_le)
+  qed
+  moreover have "numtrue \<alpha> vs = k"
+  proof -
+    have "filter \<alpha> vs = take k vs"
+      using pos neg
+      by (metis (mono_tags, lifting) append.right_neutral append_take_drop_id filter_True filter_append filter_empty_conv)
+    then show ?thesis
+      using numtrue_def assms(1) by simp
+  qed
+  ultimately show ?thesis
+    using unary_def by auto
+qed
+
+text \<open>
+We will only ever consider cases where $k \leq |vs|$. So we can use $blocky$ to
+show that an assignment satisfies a $\Psi$ formula.
+\<close>
+
+lemma satisfies_Psi:
+  assumes "k \<le> length vs" and "blocky \<alpha> vs k"
+  shows "\<alpha> \<Turnstile> \<Psi> vs k"
+proof -
+  have "\<alpha> \<Turnstile> map (\<lambda>s. [Pos s]) (take k vs)"
+    (is "\<alpha> \<Turnstile> ?phi")
+  proof -
+    {
+      fix c :: clause
+      assume c: "c \<in> set ?phi"
+      then obtain s where "c = [Pos s]" and "s \<in> set (take k vs)"
+        by auto
+      then obtain i where "i < k" and "s = vs ! i"
+        using assms(1)
+        by (smt (verit, best) in_set_conv_nth le_antisym le_trans nat_le_linear nat_less_le nth_take nth_take_lemma take_all_iff)
+      then have "c = [Pos (vs ! i)]"
+        using `c = [Pos s]` by simp
+      moreover have "i < length vs"
+        using assms(1) `i < k` by simp
+      ultimately have "\<alpha> (vs ! i)"
+        using assms(2) blocky_def \<open>i < k\<close> by blast
+      then have "satisfies_clause \<alpha> c"
+        using satisfies_clause_def by (simp add: \<open>c = [Pos (vs ! i)]\<close>)
+    }
+    then show ?thesis
+      using satisfies_def by simp
+  qed
+  moreover have "\<alpha> \<Turnstile> map (\<lambda>s. [Neg s]) (drop k vs)"
+    (is "\<alpha> \<Turnstile> ?phi")
+  proof -
+    {
+      fix c :: clause
+      assume c: "c \<in> set ?phi"
+      then obtain s where "c = [Neg s]" and "s \<in> set (drop k vs)"
+        by auto
+      then obtain j where "j < length vs - k" and "s = drop k vs ! j"
+        by (metis in_set_conv_nth length_drop)
+      define i where "i = j + k"
+      then have "i \<ge> k" and "s = vs ! i"
+        by (auto simp add: \<open>s = drop k vs ! j\<close> add.commute assms(1) i_def)
+      then have "c = [Neg (vs ! i)]"
+        using `c = [Neg s]` by simp
+      moreover have "i < length vs"
+        using assms(1) using \<open>j < length vs - k\<close> i_def by simp
+      ultimately have "\<not> \<alpha> (vs ! i)"
+        using assms(2) blocky_def[of \<alpha> vs k] i_def by simp
+      then have "satisfies_clause \<alpha> c"
+        using satisfies_clause_def by (simp add: \<open>c = [Neg (vs ! i)]\<close>)
+    }
+    then show ?thesis
+      using satisfies_def by simp
+  qed
+  ultimately show ?thesis
+    using satisfies_def Psi_def by auto
+qed
+
+lemma blocky_imp_unary:
+  assumes "k \<le> length vs" and "blocky \<alpha> vs k"
+  shows "unary \<alpha> vs = k"
+  using assms satisfies_Psi Psi_unary by simp
+
+text \<open>
+The family $\Upsilon$ of CNF formulas also takes as parameter a list of variable
+indices.
+\<close>
+
+definition Upsilon :: "nat list \<Rightarrow> formula" ("\<Upsilon>") where
+  "\<Upsilon> vs \<equiv> map (\<lambda>s. [Pos s]) (take 2 vs) @ map (\<lambda>s. [Neg s]) (drop 3 vs)"
+
+text \<open>
+For $|\mathit{vs}| > 2$, an assignment satisfies $\Upsilon(\mathit{vs})$ iff.\
+it satisfies $\Psi(\mathit{vs}, 2)$ or $\Psi(\mathit{vs}, 3)$.
+\<close>
+
+lemma Psi_2_imp_Upsilon:
+  fixes \<alpha> :: assignment
+  assumes "\<alpha> \<Turnstile> \<Psi> vs 2" and "length vs > 2"
+  shows "\<alpha> \<Turnstile> \<Upsilon> vs"
+proof -
+  have "\<alpha> \<Turnstile> map (\<lambda>s. [Pos s]) (take 2 vs)"
+    using assms Psi_def satisfies_def by simp
+  moreover have "\<alpha> \<Turnstile> map (\<lambda>s. [Neg s]) (drop 3 vs)"
+    using assms Psi_def satisfies_def
+    by (smt (z3) Cons_nth_drop_Suc One_nat_def Suc_1 Un_iff insert_iff list.set(2) list.simps(9)
+      numeral_3_eq_3 set_append)
+  ultimately show ?thesis
+    using Upsilon_def satisfies_def by auto
+qed
+
+lemma Psi_3_imp_Upsilon:
+  assumes "\<alpha> \<Turnstile> \<Psi> vs 3" and "length vs > 2"
+  shows "\<alpha> \<Turnstile> \<Upsilon> vs"
+proof -
+  have "\<alpha> \<Turnstile> map (\<lambda>s. [Pos s]) (take 2 vs)"
+    using assms Psi_def satisfies_def
+    by (metis eval_nat_numeral(3) map_append satisfies_append(1) take_Suc_conv_app_nth)
+  moreover have "\<alpha> \<Turnstile> map (\<lambda>s. [Neg s]) (drop 3 vs)"
+    using assms Psi_def satisfies_def by simp
+  ultimately show ?thesis
+    using Upsilon_def satisfies_def by auto
+qed
+
+lemma Upsilon_imp_Psi_2_or_3:
+  assumes "\<alpha> \<Turnstile> \<Upsilon> vs" and "length vs > 2"
+  shows "\<alpha> \<Turnstile> \<Psi> vs 2 \<or> \<alpha> \<Turnstile> \<Psi> vs 3"
+proof -
+  have "\<alpha> \<Turnstile> map (\<lambda>s. [Pos s]) (take 2 vs)"
+    using satisfies_def assms Upsilon_def by simp
+  then have "satisfies_clause \<alpha> [Pos v]" if "v \<in> set (take 2 vs)" for v
+    using satisfies_def that by simp
+  then have "satisfies_literal \<alpha> (Pos v)" if "v \<in> set (take 2 vs)" for v
+    using satisfies_clause_def that by simp
+  then have 1: "\<alpha> v" if "v \<in> set (take 2 vs)" for v
+    using that by simp
+  then have 2: "satisfies_clause \<alpha> [Pos v]" if "v \<in> set (take 2 vs)" for v
+    using that satisfies_clause_def by simp
+
+  have "\<alpha> \<Turnstile> map (\<lambda>s. [Neg s]) (drop 3 vs)"
+    using satisfies_def assms Upsilon_def by simp
+  then have "satisfies_clause \<alpha> [Neg v]" if "v \<in> set (drop 3 vs)" for v
+    using satisfies_def that by simp
+  then have "satisfies_literal \<alpha> (Neg v)" if "v \<in> set (drop 3 vs)" for v
+    using satisfies_clause_def that by simp
+  then have 3: "\<not> \<alpha> v" if "v \<in> set (drop 3 vs)" for v
+    using that by simp
+  then have 4: "satisfies_clause \<alpha> [Neg v]" if "v \<in> set (drop 3 vs)" for v
+    using that satisfies_clause_def by simp
+
+  show ?thesis
+  proof (cases "\<alpha> (vs ! 2)")
+    case True
+    then have "\<alpha> v" if "v \<in> set (take 3 vs)" for v
+      using that 1 assms(2)
+      by (metis (no_types, lifting) in_set_conv_nth le_simps(3) length_take less_imp_le_nat linorder_neqE_nat
+       min_absorb2 not_less_eq nth_take numeral_One numeral_plus_numeral plus_1_eq_Suc semiring_norm(3))
+    then have "satisfies_clause \<alpha> [Pos v]" if "v \<in> set (take 3 vs)" for v
+      using that satisfies_clause_def by simp
+    then have "\<alpha> \<Turnstile> \<Psi> vs 3"
+      using 4 Psi_def satisfies_def by auto
+    then show ?thesis
+      by simp
+  next
+    case False
+    then have "\<not> \<alpha> v" if "v \<in> set (drop 2 vs)" for v
+      using that 3 assms(2)
+      by (metis Cons_nth_drop_Suc numeral_plus_numeral numerals(1) plus_1_eq_Suc semiring_norm(3) set_ConsD)
+    then have "satisfies_clause \<alpha> [Neg v]" if "v \<in> set (drop 2 vs)" for v
+      using that satisfies_clause_def by simp
+    then have "\<alpha> \<Turnstile> \<Psi> vs 2"
+      using 2 Psi_def satisfies_def by auto
+    then show ?thesis
+      by simp
+  qed
+qed
+
+lemma Upsilon_unary:
+  assumes "\<alpha> \<Turnstile> \<Upsilon> vs" and "length vs > 2"
+  shows "unary \<alpha> vs = 2 \<or> unary \<alpha> vs = 3"
+  using assms Upsilon_imp_Psi_2_or_3 Psi_unary by fastforce
+
+
+section \<open>The functions $\inputpos$ and $\prev$\<close>
+
+text \<open>
+Sequences of the symbol~\textbf{0}:
+\<close>
+
+definition zeros :: "nat \<Rightarrow> symbol list" where
+  "zeros n \<equiv> string_to_symbols (replicate n \<bbbO>)"
+
+lemma length_zeros [simp]: "length (zeros n) = n"
+  using zeros_def by simp
+
+lemma bit_symbols_zeros: "bit_symbols (zeros n)"
+  using zeros_def by simp
+
+lemma zeros: "zeros n = replicate n \<zero>"
+  using zeros_def by simp
+
+text \<open>
+The assumptions in the following locale are the conditions that according to
+lemma~@{text NP_imp_oblivious_2tape} hold for all $\NP$ languages.  The
+construction of $\Phi$ will take place inside this locale, which in later
+chapters will be extended to contain the Turing machine outputting $\Phi$ and
+the correctness proof for this Turing machine.
+\<close>
+
+locale reduction_sat =
+  fixes L :: language
+  fixes M :: machine
+    and G :: nat
+    and T p :: "nat \<Rightarrow> nat"
+  assumes T: "big_oh_poly T"
+  assumes p: "polynomial p"
+  assumes tm_M: "turing_machine 2 G M"
+    and oblivious_M: "oblivious M"
+    and T_halt: "\<And>y. bit_symbols y \<Longrightarrow> fst (execute M (start_config 2 y) (T (length y))) = length M"
+    and cert: "\<And>x.
+     x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> execute M (start_config 2 \<langle>x; u\<rangle>) (T (length \<langle>x; u\<rangle>)) <.> 1 = \<one>)"
+begin
+
+text \<open>
+The value $H$ is an upper bound for the number of states of $M$ and the alphabet
+size of $M$.
+\<close>
+
+definition H :: nat where
+  "H \<equiv> max G (length M)"
+
+lemma H_ge_G: "H \<ge> G"
+  using H_def by simp
+
+lemma H_gr_2: "H > 2"
+  using H_def tm_M turing_machine_def by auto
+
+lemma H_ge_3: "H \<ge> 3"
+  using H_gr_2 by simp
+
+lemma H_ge_length_M: "H \<ge> length M"
+  using H_def by simp
+
+text \<open>
+The number of symbols used for encoding one snapshot is $Z = 3H$:
+\<close>
+
+definition Z :: nat where
+  "Z \<equiv> 3 * H"
+
+text \<open>
+The configuration after running $M$ on input $y$ for $t$ steps:
+\<close>
+
+abbreviation exc :: "symbol list \<Rightarrow> nat \<Rightarrow> config" where
+  "exc y t \<equiv> execute M (start_config 2 y) t"
+
+text \<open>
+The function $T$ is just some polynomial upper bound for the running time. The
+next function, $TT$, is the actual running time. Since $M$ is oblivious, its
+running time depends only on the length of the input. The argument @{term "zeros
+n"} is thus merely a placeholder for an arbitrary symbol sequence of length $n$.
+\<close>
+
+definition TT :: "nat \<Rightarrow> nat" where
+  "TT n \<equiv> LEAST t. fst (exc (zeros n) t) = length M"
+
+lemma TT: "fst (exc (zeros n) (TT n)) = length M"
+proof -
+  let ?P = "\<lambda>t. fst (exc (zeros n) t) = length M"
+  have "?P (T n)"
+    using T_halt bit_symbols_zeros length_zeros by metis
+  then show ?thesis
+  using wellorder_Least_lemma[of ?P] TT_def by simp
+qed
+
+lemma TT_le: "TT n \<le> T n"
+  using wellorder_Least_lemma length_zeros TT_def T_halt[OF bit_symbols_zeros[of n]] by fastforce
+
+lemma less_TT: "t < TT n \<Longrightarrow> fst (exc (zeros n) t) < length M"
+proof -
+  assume "t < TT n"
+  then have "fst (exc (zeros n) t) \<noteq> length M"
+    using TT_def not_less_Least by auto
+  moreover have "fst (exc (zeros n) t) \<le> length M" for t
+    using tm_M start_config_def turing_machine_execute_states by auto
+  ultimately show "fst (exc (zeros n) t) < length M"
+    using less_le by blast
+qed
+
+lemma oblivious_halt_state:
+  assumes "bit_symbols zs"
+  shows "fst (exc zs t) < length M \<longleftrightarrow> fst (exc (zeros (length zs)) t) < length M"
+proof -
+  obtain e where
+    e: "\<forall>zs. bit_symbols zs \<longrightarrow> (\<exists>tps. trace M (start_config 2 zs) (e (length zs)) (length M, tps))"
+    using oblivious_M oblivious_def by auto
+  let ?es = "e (length zs)"
+  have "\<forall>i<length ?es. fst (exc zs i) < length M"
+    using trace_def e assms by simp
+  moreover have "fst (exc zs (length ?es)) = length M"
+    using trace_def e assms by auto
+  moreover have "\<forall>i<length ?es. fst (exc (zeros (length zs)) i) < length M"
+    using length_zeros bit_symbols_zeros trace_def e by simp
+  moreover have "fst (exc (zeros (length zs)) (length ?es)) = length M"
+    using length_zeros bit_symbols_zeros trace_def e assms
+    by (smt (verit, ccfv_SIG) fst_conv)
+  ultimately show ?thesis
+    by (metis (no_types, lifting) execute_after_halting_ge le_less_linear)
+qed
+
+corollary less_TT':
+  assumes "bit_symbols zs" and "t < TT (length zs)"
+  shows "fst (exc zs t) < length M"
+  using assms oblivious_halt_state less_TT by simp
+
+corollary TT':
+  assumes "bit_symbols zs"
+  shows "fst (exc zs (TT (length zs))) = length M"
+  using assms TT oblivious_halt_state
+  by (metis (no_types, lifting) fst_conv start_config_def start_config_length less_le tm_M
+    turing_machine_execute_states zero_le zero_less_numeral)
+
+lemma exc_TT_eq_exc_T:
+  assumes "bit_symbols zs"
+  shows "exc zs (TT (length zs)) = exc zs (T (length zs))"
+  using execute_after_halting_ge[OF TT'[OF assms] TT_le] by simp
+
+text \<open>
+The position of the input tape head of $M$ depends only on the length $n$ of the
+input and the step $t$, at least as long as the input is over the alphabet
+$\{\mathbf{0}, \mathbf{1}\}$.
+\<close>
+
+definition inputpos :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
+  "inputpos n t \<equiv> exc (zeros n) t <#> 0"
+
+lemma inputpos_oblivious:
+  assumes "bit_symbols zs"
+  shows "exc zs t <#> 0 = inputpos (length zs) t"
+proof -
+  obtain e where
+    e: "(\<forall>zs. bit_symbols zs \<longrightarrow> (\<exists>tps. trace M (start_config 2 zs) (e (length zs)) (length M, tps)))"
+    using oblivious_M oblivious_def by auto
+  let ?es = "e (length zs)"
+  obtain tps where t1: "trace M (start_config 2 zs) ?es (length M, tps)"
+    using e assms by auto
+  let ?zs = "(replicate (length zs) 2)"
+  have "proper_symbols ?zs"
+    by simp
+  moreover have "length ?zs = length zs"
+    by simp
+  ultimately obtain tps0 where t0: "trace M (start_config 2 ?zs) ?es (length M, tps0)"
+    using e by fastforce
+  have le: "exc zs t <#> 0 = inputpos (length zs) t" if "t \<le> length ?es" for t
+  proof (cases "t = 0")
+    case True
+    then show ?thesis
+      by (simp add: start_config_def inputpos_def)
+  next
+    case False
+    then obtain i where i: "Suc i = t"
+      using gr0_implies_Suc by auto
+    then have "exc zs (Suc i) <#> 0 = fst (?es ! i)"
+      using t1 False that Suc_le_lessD trace_def by auto
+    moreover have "exc ?zs (Suc i) <#> 0 = fst (?es ! i)"
+      using t0 False i that Suc_le_lessD trace_def by auto
+    ultimately show ?thesis
+      using i inputpos_def zeros by simp
+  qed
+  moreover have "exc zs t <#> 0 = inputpos (length zs) t" if "t > length ?es"
+  proof -
+    have "exc ?zs (length ?es) = (length M, tps0)"
+      using t0 trace_def by simp
+    then have *: "exc ?zs t = exc ?zs (length ?es)"
+      using that by (metis execute_after_halting_ge fst_eqD less_or_eq_imp_le)
+    have "exc zs (length ?es) = (length M, tps)"
+      using t1 trace_def by simp
+    then have "exc zs t = exc zs (length ?es)"
+      using that by (metis execute_after_halting_ge fst_eqD less_or_eq_imp_le)
+    then show ?thesis
+      using * le[of "length ?es"] by (simp add: inputpos_def zeros)
+  qed
+  ultimately show ?thesis
+    by fastforce
+qed
+
+text \<open>
+The position of the tape head on the output tape of $M$ also depends only on the
+length $n$ of the input and the step $t$.
+\<close>
+
+lemma oblivious_headpos_1:
+  assumes "bit_symbols zs"
+  shows "exc zs t <#> 1 = exc (zeros (length zs)) t <#> 1"
+proof -
+  obtain e where
+    e: "(\<forall>zs. bit_symbols zs \<longrightarrow> (\<exists>tps. trace M (start_config 2 zs) (e (length zs)) (length M, tps)))"
+    using oblivious_M oblivious_def by auto
+  let ?es = "e (length zs)"
+  obtain tps where t1: "trace M (start_config 2 zs) ?es (length M, tps)"
+    using e assms by auto
+  let ?zs = "(replicate (length zs) 2)"
+  have "proper_symbols ?zs"
+    by simp
+  moreover have "length ?zs = length zs"
+    by simp
+  ultimately obtain tps0 where t0: "trace M (start_config 2 ?zs) ?es (length M, tps0)"
+    using e by fastforce
+  have le: "exc zs t <#> 1 = exc (zeros (length zs)) t <#> 1" if "t \<le> length ?es" for t
+  proof (cases "t = 0")
+    case True
+    then show ?thesis
+      by (simp add: start_config_def inputpos_def)
+  next
+    case False
+    then obtain i where i: "Suc i = t"
+      using gr0_implies_Suc by auto
+    then have "exc zs (Suc i) <#> 1 = snd (?es ! i)"
+      using t1 False that Suc_le_lessD trace_def by auto
+    moreover have "exc ?zs (Suc i) <#> 1 = snd (?es ! i)"
+      using t0 False i that Suc_le_lessD trace_def by auto
+    ultimately show ?thesis
+      using i inputpos_def zeros by simp
+  qed
+  moreover have "exc zs t <#> 1 = exc (zeros (length zs)) t <#> 1" if "t > length ?es"
+  proof -
+    have "exc ?zs (length ?es) = (length M, tps0)"
+      using t0 trace_def by simp
+    then have *: "exc ?zs t = exc ?zs (length ?es)"
+      using that by (metis execute_after_halting_ge fst_eqD less_or_eq_imp_le)
+    have "exc zs (length ?es) = (length M, tps)"
+      using t1 trace_def by simp
+    then have "exc zs t = exc zs (length ?es)"
+      using that by (metis execute_after_halting_ge fst_eqD less_or_eq_imp_le)
+    then show ?thesis
+      using * le[of "length ?es"] by (simp add: inputpos_def zeros)
+  qed
+  ultimately show ?thesis
+    using le_less_linear by blast
+qed
+
+text \<open>
+The value $\prev(t)$ is the most recent step in which $M$'s output tape head was
+in the same position as in step $t$. If no such step exists, $\prev(t)$ is set to
+$t$. Again due to $M$ being oblivious, $\prev$ depends only on the length $n$ of
+the input (and on $t$, of course).
+\<close>
+
+definition prev :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
+  "prev n t \<equiv>
+    if \<exists>t'<t. exc (zeros n) t' <#> 1 = exc (zeros n) t <#> 1
+    then GREATEST t'. t' < t \<and> exc (zeros n) t' <#> 1 = exc (zeros n) t <#> 1
+    else t"
+
+lemma oblivious_prev:
+  assumes "bit_symbols zs"
+  shows "prev (length zs) t =
+   (if \<exists>t'<t. exc zs t' <#> 1 = exc zs t <#> 1
+    then GREATEST t'. t' < t \<and> exc zs t' <#> 1 = exc zs t <#> 1
+    else t)"
+  using prev_def assms oblivious_headpos_1 by auto
+
+lemma prev_less:
+  assumes "\<exists>t'<t. exc (zeros n) t' <#> 1 = exc (zeros n) t <#> 1"
+  shows "prev n t < t \<and> exc (zeros n) (prev n t) <#> 1 = exc (zeros n) t <#> 1"
+proof -
+  let ?P = "\<lambda>t'. t' < t \<and> exc (zeros n) t' <#> 1 = exc (zeros n) t <#> 1"
+  have "prev n t = (GREATEST t'. t' < t \<and> exc (zeros n) t' <#> 1 = exc (zeros n) t <#> 1)"
+    using assms prev_def by simp
+  moreover have "\<forall>y. ?P y \<longrightarrow> y \<le> t"
+    by simp
+  ultimately show ?thesis
+    using GreatestI_ex_nat[OF assms, of t] by simp
+qed
+
+corollary prev_less':
+  assumes "bit_symbols zs"
+  assumes "\<exists>t'<t. exc zs t' <#> 1 = exc zs t <#> 1"
+  shows "prev (length zs) t < t \<and> exc zs (prev (length zs) t) <#> 1 = exc zs t <#> 1"
+  using prev_less oblivious_headpos_1 assms by simp
+
+lemma prev_greatest:
+  assumes "t' < t" and "exc (zeros n) t' <#> 1 = exc (zeros n) t <#> 1"
+  shows "t' \<le> prev n t"
+proof -
+  let ?P = "\<lambda>t'. t' < t \<and> exc (zeros n) t' <#> 1 = exc (zeros n) t <#> 1"
+  have "prev n t = (GREATEST t'. t' < t \<and> exc (zeros n) t' <#> 1 = exc (zeros n) t <#> 1)"
+    using assms prev_def by auto
+  moreover have "?P t'"
+    using assms by simp
+  moreover have "\<forall>y. ?P y \<longrightarrow> y \<le> t"
+    by simp
+  ultimately show ?thesis
+    using Greatest_le_nat[of ?P t' t] by simp
+qed
+
+corollary prev_greatest':
+  assumes "bit_symbols zs"
+  assumes "t' < t" and "exc zs t' <#> 1 = exc zs t <#> 1"
+  shows "t' \<le> prev (length zs) t"
+  using prev_greatest oblivious_headpos_1 assms by simp
+
+lemma prev_eq: "prev n t = t \<longleftrightarrow> \<not> (\<exists>t'<t. exc (zeros n) t' <#> 1 = exc (zeros n) t <#> 1)"
+  using prev_def nat_less_le prev_less by simp
+
+lemma prev_le: "prev n t \<le> t"
+  using prev_eq prev_less by (metis less_or_eq_imp_le)
+
+corollary prev_eq':
+  assumes "bit_symbols zs"
+  shows "prev (length zs) t = t \<longleftrightarrow> \<not> (\<exists>t'<t. exc zs t' <#> 1 = exc zs t <#> 1)"
+  using prev_eq oblivious_headpos_1 assms by simp
+
+lemma prev_between:
+  assumes "prev n t < t'" and "t' < t"
+  shows "exc (zeros n) t' <#> 1 \<noteq> exc (zeros n) (prev n t) <#> 1"
+  using assms by (metis (no_types, lifting) leD prev_eq prev_greatest prev_less)
+
+lemma prev_write_read:
+  assumes "bit_symbols zs" and "n = length zs"
+    and "prev n t < t" and "cfg = exc zs (prev n t)" and "t \<le> TT n"
+  shows "exc zs t <.> 1 = (M ! (fst cfg)) [cfg <.> 0, cfg <.> 1] [.] 1"
+proof -
+  let ?cfg = "exc zs (Suc (prev n t))"
+  let ?sas = "(M ! (fst cfg)) [cfg <.> 0, cfg <.> 1]"
+  let ?i = "cfg <#> 1"
+  have 1: "fst cfg < length M"
+    using assms less_TT' by simp
+  have 2: "||cfg|| = 2"
+    using assms execute_num_tapes start_config_length tm_M by auto
+  then have 3: "read (snd cfg) = [cfg <.> 0, cfg <.> 1]"
+    using read_def
+    by (smt (z3) Cons_eq_map_conv Suc_1 length_0_conv length_Suc_conv list.simps(8)
+      nth_Cons_0 nth_Cons_Suc numeral_1_eq_Suc_0 numeral_One)
+
+  have *: "(?cfg <:> 1) ?i = (M ! (fst cfg)) [cfg <.> 0, cfg <.> 1] [.] 1"
+  proof -
+    have "?cfg <!> 1 = exe M cfg <!> 1"
+      by (simp add: assms)
+    also have "... = sem (M ! (fst cfg)) cfg <!> 1"
+      using 1 exe_lt_length by simp
+    also have "... = act (snd ((M ! (fst cfg)) (read (snd cfg))) ! 1) (snd cfg ! 1)"
+      using sem_snd_tm tm_M 1 2 by (metis Suc_1 lessI prod.collapse)
+    also have "... = act (?sas [!] 1) (cfg <!> 1)"
+      using 3 by simp
+    finally have *: "?cfg <!> 1 = act (?sas [!] 1) (cfg <!> 1)" .
+
+    have "(?cfg <:> 1) ?i = fst (?cfg <!> 1) ?i"
+      by simp
+    also have ***: "... = ((fst (cfg <!> 1))(?i := (?sas [.] 1))) ?i"
+      using * act by simp
+    also have "... = ?sas [.] 1"
+      by simp
+    finally show "(?cfg <:> 1) ?i = ?sas [.] 1"
+      using *** by simp
+  qed
+
+  have "((exc zs t') <:> 1) ?i = (M ! (fst cfg)) [cfg <.> 0, cfg <.> 1] [.] 1"
+    if "Suc (prev n t) \<le> t'" and "t' \<le> t" for t'
+  using that
+  proof (induction t' rule: nat_induct_at_least)
+    case base
+    then show ?case
+      using * by simp
+  next
+    case (Suc m)
+    let ?cfg_m = "exc zs m"
+    from Suc have between: "prev n t < m" "m < t"
+      by simp_all
+    then have *: "?cfg_m <#> 1 \<noteq> ?i"
+      using prev_between assms oblivious_headpos_1 by simp
+
+    have "m < TT n"
+      using Suc assms by simp
+    then have 1: "fst ?cfg_m < length M"
+      using assms less_TT' by simp
+    have 2: "||?cfg_m|| = 2"
+      using execute_num_tapes start_config_length tm_M by auto
+
+    have "exc zs (Suc m) <!> 1 = exe M ?cfg_m <!> 1"
+      by simp
+    also have "... = sem (M ! (fst ?cfg_m)) ?cfg_m <!> 1"
+      using 1 exe_lt_length by simp
+    also have "... = act (snd ((M ! (fst ?cfg_m)) (read (snd ?cfg_m))) ! 1) (snd ?cfg_m ! 1)"
+      using sem_snd_tm tm_M 1 2 by (metis Suc_1 lessI prod.collapse)
+    finally have "exc zs (Suc m) <!> 1 = act (snd ((M ! (fst ?cfg_m)) (read (snd ?cfg_m))) ! 1) (snd ?cfg_m ! 1)" .
+    then have "(exc zs (Suc m) <:> 1) ?i = fst (snd ?cfg_m ! 1) ?i"
+      using * act_changes_at_most_pos' by simp
+    then show ?case
+      using Suc by simp
+  qed
+  then have "((exc zs t) <:> 1) ?i = (M ! (fst cfg)) [cfg <.> 0, cfg <.> 1] [.] 1"
+    using Suc_leI assms by simp
+  moreover have "?i = exc zs t <#> 1"
+    using assms(1,2,4) oblivious_headpos_1 prev_eq prev_less by (smt (z3))
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma prev_no_write:
+  assumes "bit_symbols zs" and "n = length zs"
+    and "prev n t = t" and "t \<le> TT n" and "t > 0"
+  shows "exc zs t <.> 1 = \<box>"
+proof -
+  let ?i = "exc zs t <#> 1"
+
+  have 1: "\<not> (\<exists>t'<t. exc zs t' <#> 1 = ?i)"
+    using prev_eq' assms(1,2,3) by simp
+
+  have 2: "?i > 0"
+  proof (rule ccontr)
+    assume "\<not> 0 < ?i"
+    then have eq0: "?i = 0"
+      by simp
+    moreover have "exc zs 0 <#> 1 = 0"
+      by (simp add: start_config_pos)
+    ultimately show False
+      using 1 assms(5) by auto
+  qed
+
+  have 3: "(exc zs (Suc t') <:> 1) i = (exc zs t' <:> 1) i" if "i \<noteq> exc zs t' <#> 1" for i t'
+  proof (cases "fst (exc zs t') < length M")
+    case True
+    let ?cfg = "exc zs t'"
+    have len2: "||?cfg|| = 2"
+      using execute_num_tapes start_config_length tm_M by auto
+    have "exc zs (Suc t') <!> 1 = exe M ?cfg <!> 1"
+      by simp
+    also have "... = sem (M ! (fst ?cfg)) ?cfg <!> 1"
+      using True exe_lt_length by simp
+    also have "... = act (snd ((M ! (fst ?cfg)) (read (snd ?cfg))) ! 1) (snd ?cfg ! 1)"
+      using sem_snd_tm tm_M True len2 by (metis Suc_1 lessI prod.collapse)
+    finally have "exc zs (Suc t') <!> 1 = act (snd ((M ! (fst ?cfg)) (read (snd ?cfg))) ! 1) (snd ?cfg ! 1)" .
+    then have "(exc zs (Suc t') <:> 1) i = fst (snd ?cfg ! 1) i"
+      using that act_changes_at_most_pos' by simp
+    then show ?thesis
+      by simp
+  next
+    case False
+    then show ?thesis
+      using that by (simp add: exe_def)
+  qed
+
+  have "(exc zs t' <:> 1) ?i = (exc zs 0 <:> 1) ?i" if "t' \<le> t" for t'
+    using that
+  proof (induction t')
+    case 0
+    then show ?case
+      by simp
+  next
+    case (Suc t')
+    then show ?case
+      by (metis 1 3 Suc_leD Suc_le_lessD)
+  qed
+  then have "exc zs t <.> 1 = (exc zs 0 <:> 1) ?i"
+    by simp
+  then show ?thesis
+    using 2 One_nat_def execute.simps(1) start_config1 less_2_cases_iff less_one by presburger
+qed
+
+text \<open>
+The intervals $\gamma_i$ and $w_0, \dots, w_9$ do not depend on $x$, and so can
+be defined here already.
+\<close>
+
+definition gamma :: "nat \<Rightarrow> nat list" ("\<gamma>") where
+  "\<gamma> i \<equiv> [i * H..<Suc i * H]"
+
+lemma length_gamma [simp]: "length (\<gamma> i) = H"
+  using gamma_def by simp
+
+abbreviation "w\<^sub>0 \<equiv> [0..<H]"
+abbreviation "w\<^sub>1 \<equiv> [H..<2*H]"
+abbreviation "w\<^sub>2 \<equiv> [2*H..<Z]"
+abbreviation "w\<^sub>3 \<equiv> [Z..<Z+H]"
+abbreviation "w\<^sub>4 \<equiv> [Z+H..<Z+2*H]"
+abbreviation "w\<^sub>5 \<equiv> [Z+2*H..<2*Z]"
+abbreviation "w\<^sub>6 \<equiv> [2*Z..<2*Z+H]"
+abbreviation "w\<^sub>7 \<equiv> [2*Z+H..<2*Z+2*H]"
+abbreviation "w\<^sub>8 \<equiv> [2*Z+2*H..<3*Z]"
+abbreviation "w\<^sub>9 \<equiv> [3*Z..<3*Z+H]"
+
+lemma unary_upt_eq:
+  fixes \<alpha>\<^sub>1 \<alpha>\<^sub>2 :: assignment
+    and lower upper k :: nat
+  assumes "\<forall>i<k. \<alpha>\<^sub>1 i = \<alpha>\<^sub>2 i" and "upper \<le> k"
+  shows "unary \<alpha>\<^sub>1 [lower..<upper] = unary \<alpha>\<^sub>2 [lower..<upper]"
+proof -
+  have "numtrue \<alpha>\<^sub>1 [lower..<upper] = numtrue \<alpha>\<^sub>2 [lower..<upper]"
+  proof -
+    let ?vs = "[lower..<upper]"
+    have "filter \<alpha>\<^sub>1 ?vs = filter \<alpha>\<^sub>2 ?vs"
+      using assms by (metis atLeastLessThan_iff filter_cong less_le_trans set_upt)
+    then show ?thesis
+      using numtrue_def by simp
+  qed
+  moreover have "blocky \<alpha>\<^sub>1 [lower..<upper] = blocky \<alpha>\<^sub>2 [lower..<upper]"
+    using blocky_def assms by auto
+  ultimately show ?thesis
+    using assms unary_def by simp
+qed
+
+text \<open>
+For the case @{term "prev m t < t"}, we have the following predicate on
+assignments, which corresponds to ($\mathrm{F}_1$), ($\mathrm{F}_2$),
+($\mathrm{F}_3$) from the introduction:
+\<close>
+
+definition F :: "assignment \<Rightarrow> bool" where
+  "F \<alpha> \<equiv>
+     unary \<alpha> w\<^sub>6 = unary \<alpha> w\<^sub>9 \<and>
+     unary \<alpha> w\<^sub>7 = (M ! (unary \<alpha> w\<^sub>5)) [unary \<alpha> w\<^sub>3, unary \<alpha> w\<^sub>4] [.] 1 \<and>
+     unary \<alpha> w\<^sub>8 = fst ((M ! (unary \<alpha> w\<^sub>2)) [unary \<alpha> w\<^sub>0, unary \<alpha> w\<^sub>1])"
+
+lemma depon_F: "depon (3 * Z + H) F"
+  using depon_def F_def Z_def unary_upt_eq by simp
+
+text \<open>
+There is a CNF formula $\psi$ that contains the first $3Z + H$ variables and
+is satisfied by exactly the assignments specified by $F$.
+\<close>
+
+definition psi :: formula ("\<psi>") where
+  "\<psi> \<equiv> SOME \<phi>.
+    fsize \<phi> \<le> (3 * Z + H) * 2 ^ (3 * Z + H) \<and>
+    length \<phi> \<le> 2 ^ (3 * Z + H) \<and>
+    variables \<phi> \<subseteq> {..<3 * Z + H} \<and>
+    (\<forall>\<alpha>. F \<alpha> = \<alpha> \<Turnstile> \<phi>)"
+
+lemma psi:
+  "fsize \<psi> \<le> (3 * Z + H) * 2 ^ (3*Z + H) \<and>
+   length \<psi> \<le> 2 ^ (3 * Z + H) \<and>
+   variables \<psi> \<subseteq> {..<3 * Z + H} \<and>
+   (\<forall>\<alpha>. F \<alpha> = \<alpha> \<Turnstile> \<psi>)"
+  using psi_def someI_ex[OF depon_ex_formula[OF depon_F]] by metis
+
+lemma satisfies_psi:
+  assumes "length \<sigma> = 3 * Z + H"
+  shows "\<alpha> \<Turnstile> relabel \<sigma> \<psi> = remap \<sigma> \<alpha> \<Turnstile> \<psi>"
+  using assms psi satisfies_sigma by simp
+
+lemma psi_F: "remap \<sigma> \<alpha> \<Turnstile> \<psi> = F (remap \<sigma> \<alpha>)"
+  using psi by simp
+
+corollary satisfies_F:
+  assumes "length \<sigma> = 3 * Z + H"
+  shows "\<alpha> \<Turnstile> relabel \<sigma> \<psi> = F (remap \<sigma> \<alpha>)"
+  using assms satisfies_psi psi_F by simp
+
+text \<open>
+For the case @{term "prev m t = t"}, the following predicate corresponds to
+($\mathrm{F}_1'$), ($\mathrm{F}_2'$), ($\mathrm{F}_3'$) from the introduction:
+\<close>
+
+definition F' :: "assignment \<Rightarrow> bool" where
+  "F' \<alpha> \<equiv>
+     unary \<alpha> w\<^sub>3 = unary \<alpha> w\<^sub>6 \<and>
+     unary \<alpha> w\<^sub>4 = 0 \<and>
+     unary \<alpha> w\<^sub>5 = fst ((M ! (unary \<alpha> w\<^sub>2)) [unary \<alpha> w\<^sub>0, unary \<alpha> w\<^sub>1])"
+
+lemma depon_F': "depon (2 * Z + H) F'"
+  using depon_def F'_def Z_def unary_upt_eq by simp
+
+text \<open>
+The CNF formula $\psi'$ is analogous to $\psi$ from the previous case.
+\<close>
+
+definition psi' :: formula ("\<psi>''") where
+  "\<psi>' \<equiv> SOME \<phi>.
+    fsize \<phi> \<le> (2*Z+H) * 2 ^ (2*Z+H) \<and>
+    length \<phi> \<le> 2 ^ (2*Z+H) \<and>
+    variables \<phi> \<subseteq> {..<2*Z+H} \<and>
+    (\<forall>\<alpha>. F' \<alpha> = \<alpha> \<Turnstile> \<phi>)"
+
+lemma psi':
+  "fsize \<psi>' \<le> (2*Z+H) * 2 ^ (2*Z+H) \<and>
+   length \<psi>' \<le> 2 ^ (2*Z+H) \<and>
+   variables \<psi>' \<subseteq> {..<2*Z+H} \<and>
+   (\<forall>\<alpha>. F' \<alpha> = \<alpha> \<Turnstile> \<psi>')"
+  using psi'_def someI_ex[OF depon_ex_formula[OF depon_F']] by metis
+
+lemma satisfies_psi':
+  assumes "length \<sigma> = 2*Z+H"
+  shows "\<alpha> \<Turnstile> relabel \<sigma> \<psi>' = remap \<sigma> \<alpha> \<Turnstile> \<psi>'"
+  using assms psi' satisfies_sigma by simp
+
+lemma psi'_F': "remap \<sigma> \<alpha> \<Turnstile> \<psi>' = F' (remap \<sigma> \<alpha>)"
+  using psi' by simp
+
+corollary satisfies_F':
+  assumes "length \<sigma> = 2*Z+H"
+  shows "\<alpha> \<Turnstile> relabel \<sigma> \<psi>' = F' (remap \<sigma> \<alpha>)"
+  using assms satisfies_psi' psi'_F' by simp
+
+end  (* locale reduction_sat *)
+
+
+section \<open>Snapshots\<close>
+
+text \<open>
+The snapshots and much of the rest of the construction of $\Phi$ depend on the
+string $x$. We encapsulate this in a sublocale of @{locale reduction_sat}.
+\<close>
+
+locale reduction_sat_x = reduction_sat +
+  fixes x :: string
+begin
+
+abbreviation n :: nat where
+  "n \<equiv> length x"
+
+text \<open>
+Turing machines consume the string $x$ as a sequence $xs$ of symbols:
+\<close>
+
+abbreviation xs :: "symbol list" where
+  "xs \<equiv> string_to_symbols x"
+
+lemma bs_xs: "bit_symbols xs"
+  by simp
+
+text \<open>
+For the verifier Turing machine $M$ we are only concerned with inputs of the
+form $\langle x, u\rangle$ for a string $u$ of length $p(n)$. The pair $\langle
+x, u\rangle$ has the length $m = 2n + 2p(n) + 2$.
+\<close>
+
+definition m :: nat where
+  "m \<equiv> 2 * n + 2 * p n + 2"
+
+text \<open>
+On input $\langle x, u\rangle$ the Turing machine $M$ halts after $T' = TT(m)$
+steps.
+\<close>
+
+definition T' :: nat where
+  "T' \<equiv> TT m"
+
+text \<open>
+The positions of both of $M$'s tape heads are bounded by $T'$.
+\<close>
+
+lemma inputpos_less: "inputpos m t \<le> T'"
+proof -
+  define u :: string where "u = replicate (p n) False"
+  let ?i = "inputpos m t"
+  have y: "bit_symbols \<langle>x; u\<rangle>"
+    by simp
+  have len: "length \<langle>x; u\<rangle> = m"
+    using u_def m_def length_pair by simp
+  then have "exc \<langle>x; u\<rangle> t <#> 0 \<le> T'"
+    using TT'[OF y] T'_def head_pos_le_halting_time[OF tm_M, of "\<langle>x; u\<rangle>" T' 0] by simp
+  then show ?thesis
+    using inputpos_oblivious[OF y] len by simp
+qed
+
+lemma headpos_1_less: "exc (zeros m) t <#> 1 \<le> T'"
+proof -
+  define u :: string where "u = replicate (p n) False"
+  let ?i = "inputpos m t"
+  have y: "bit_symbols \<langle>x; u\<rangle>"
+    by simp
+  have len: "length \<langle>x; u\<rangle> = m"
+    using u_def m_def length_pair by simp
+  then have "exc \<langle>x; u\<rangle> t <#> 1 \<le> T'"
+    using TT'[OF y] T'_def head_pos_le_halting_time[OF tm_M, of "\<langle>x; u\<rangle>" "T'" 1] by simp
+  then show ?thesis
+    using oblivious_headpos_1[OF y] len by simp
+qed
+
+text \<open>
+The formula $\Phi$ must contain a condition for every symbol that $M$ is reading
+from the input tape.  While $T'$ is an upper bound for the input tape head
+position of $M$, it might be that $T'$ is less than the length of the input
+$\langle x, u\rangle$.  So the portion of the input read by $M$ might be a
+prefix of the input or it might be the input followed by some blanks afterwards.
+This would make for an awkward case distinction.  We do not have to be very
+precise here and can afford to bound the portion of the input tape read by $M$
+by the number $m' = 2n + 2p(n) + 3 + T'$, which is the length of the start
+symbol followed by the input $\langle x, u\rangle$ followed by $T'$ blanks.
+This symbol sequence was called $y(u)$ in the introduction. Here we will call it
+@{term "ysymbols u"}.
+\<close>
+
+definition m' :: nat where
+  "m' \<equiv> 2 * n + 2 * p n + 3 + T'"
+
+definition ysymbols :: "string \<Rightarrow> symbol list" where
+  "ysymbols u \<equiv> 1 # \<langle>x; u\<rangle> @ replicate T' 0"
+
+lemma length_ysymbols: "length u = p n \<Longrightarrow> length (ysymbols u) = m'"
+  using ysymbols_def m'_def m_def length_pair by simp
+
+lemma ysymbols_init:
+  assumes "i < length (ysymbols u)"
+  shows "ysymbols u ! i = (start_config 2 \<langle>x; u\<rangle> <:> 0) i"
+proof -
+  let ?y = "\<langle>x; u\<rangle>"
+  have init: "start_config 2 ?y <:> 0 = (\<lambda>i. if i = 0 then 1 else if i \<le> length ?y then ?y ! (i - 1) else 0)"
+    using start_config_def by auto
+  have "i < length ?y + 1 + T'"
+    using assms ysymbols_def by simp
+  then consider "i = 0" | "i > 0 \<and> i \<le> length ?y" | "i > length ?y \<and> i < length ?y + 1 + T'"
+    by linarith
+  then show "ysymbols u ! i = (start_config 2 ?y <:> 0) i"
+  proof (cases)
+    case 1
+    then show ?thesis
+      using ysymbols_def init by simp
+  next
+    case 2
+    then have "ysymbols u ! i = \<langle>x; u\<rangle> ! (i - 1)"
+      using ysymbols_def
+      by (smt (z3) One_nat_def Suc_less_eq Suc_pred le_imp_less_Suc neq0_conv nth_Cons' nth_append)
+    then show ?thesis
+      using init 2 by simp
+  next
+    case 3
+    then have "(start_config 2 ?y <:> 0) i = 0"
+      using init by simp
+    moreover have "ysymbols u ! i = 0"
+      unfolding ysymbols_def using 3 nth_append[of "1#\<langle>x; u\<rangle>" "replicate T' 0" i] by auto
+    ultimately show ?thesis
+      by simp
+  qed
+qed
+
+lemma ysymbols_at_0: "ysymbols u ! 0 = 1"
+  using ysymbols_def by simp
+
+lemma ysymbols_first_at:
+  assumes "j < length x"
+  shows "ysymbols u ! (2*j+1) = 2"
+    and "ysymbols u ! (2*j+2) = (if x ! j then 3 else 2)"
+proof -
+  have *: "ysymbols u = (1 # \<langle>x; u\<rangle>) @ replicate T' 0"
+    using ysymbols_def by simp
+
+  let ?i = "2 * j + 1"
+  have len: "2*j < length \<langle>x, u\<rangle>"
+    using assms length_string_pair by simp
+  have "?i < length (1 # \<langle>x; u\<rangle>)"
+    using assms length_pair by simp
+  then have "ysymbols u ! ?i = (1 # \<langle>x; u\<rangle>) ! ?i"
+    using * nth_append by metis
+  also have "... = \<langle>x; u\<rangle> ! (2*j)"
+    by simp
+  also have "... = 2"
+    using string_pair_first_nth assms len by simp
+  finally show "ysymbols u ! ?i = 2" .
+
+  let ?i = "2 * j + 2"
+  have len2: "?i < length (1 # \<langle>x; u\<rangle>)"
+    using assms length_pair by simp
+  then have "ysymbols u ! ?i = (1 # \<langle>x; u\<rangle>) ! ?i"
+    using * nth_append by metis
+  also have "... = \<langle>x; u\<rangle> ! (2*j+1)"
+    by simp
+  also have "... = (if x ! j then 3 else 2)"
+    using string_pair_first_nth(2) assms len2 by simp
+  finally show "ysymbols u ! ?i = (if x ! j then 3 else 2)" .
+qed
+
+lemma ysymbols_at_2n1: "ysymbols u ! (2*n+1) = 3"
+proof -
+  let ?i = "2 * n + 1"
+  have "ysymbols u ! ?i = \<langle>x; u\<rangle> ! (2*n)"
+    using ysymbols_def
+    by (metis (no_types, lifting) add.commute add_2_eq_Suc' le_add2 le_imp_less_Suc length_pair
+      less_SucI nth_Cons_Suc nth_append plus_1_eq_Suc)
+  also have "... = (if \<langle>x, u\<rangle> ! (2*n) then 3 else 2)"
+    using length_pair by simp
+  also have "... = 3"
+    using string_pair_sep_nth by simp
+  finally show ?thesis .
+qed
+
+lemma ysymbols_at_2n2: "ysymbols u ! (2*n+2) = 3"
+proof -
+  let ?i = "2 * n + 2"
+  have "ysymbols u ! ?i = \<langle>x; u\<rangle> ! (2*n+1)"
+    using ysymbols_def
+    by (smt (z3) One_nat_def add.commute add.right_neutral add_2_eq_Suc' add_Suc_right le_add2
+      le_imp_less_Suc length_pair nth_Cons_Suc nth_append)
+  also have "... = (if \<langle>x, u\<rangle> ! (2*n+1) then 3 else 2)"
+    using length_pair by simp
+  also have "... = 3"
+    using string_pair_sep_nth by simp
+  finally show ?thesis .
+qed
+
+lemma ysymbols_second_at:
+  assumes "j < length u"
+  shows "ysymbols u ! (2*n+2+2*j+1) = 2"
+    and "ysymbols u ! (2*n+2+2*j+2) = (if u ! j then 3 else 2)"
+proof -
+  have *: "ysymbols u = (1 # \<langle>x; u\<rangle>) @ replicate T' 0"
+    using ysymbols_def by simp
+
+  let ?i = "2 * n + 2 + 2 * j + 1"
+  have len: "2 * n + 2 + 2*j < length \<langle>x, u\<rangle>"
+    using assms length_string_pair by simp
+  have "?i < length (1 # \<langle>x; u\<rangle>)"
+    using assms length_pair by simp
+  then have "ysymbols u ! ?i = (1 # \<langle>x; u\<rangle>) ! ?i"
+    using * nth_append by metis
+  also have "... = \<langle>x; u\<rangle> ! (2*n+2+2*j)"
+    by simp
+  also have "... = 2"
+    using string_pair_second_nth(1) assms len by simp
+  finally show "ysymbols u ! ?i = 2" .
+
+  let ?i = "2*n+2+2 * j + 2"
+  have len2: "?i < length (1 # \<langle>x; u\<rangle>)"
+    using assms length_pair by simp
+  then have "ysymbols u ! ?i = (1 # \<langle>x; u\<rangle>) ! ?i"
+    using * nth_append by metis
+  also have "... = \<langle>x; u\<rangle> ! (2*n+2+2*j+1)"
+    by simp
+  also have "... = (if u ! j then 3 else 2)"
+    using string_pair_second_nth(2) assms len2 by simp
+  finally show "ysymbols u ! ?i = (if u ! j then 3 else 2)" .
+qed
+
+lemma ysymbols_last:
+  assumes "length u = p n" and "i > m" and "i < m + 1 + T'"
+  shows "ysymbols u ! i = 0"
+  using assms length_ysymbols m_def m'_def ysymbols_def nth_append[of "1#\<langle>x; u\<rangle>" "replicate T' 0" i] by simp
+
+text \<open>
+The number of symbols used for unary encoding $m'$ symbols will be called $N$:
+\<close>
+
+definition N :: nat where
+  "N \<equiv> H * m'"
+
+lemma N_eq: "N = H * (2 * n + 2 * p n + 3 + T')"
+  using m'_def N_def by simp
+
+lemma m': "m' * H = N "
+  using m'_def N_def by simp
+
+lemma inputpos_less': "inputpos m t < m'"
+  using inputpos_less m_def m'_def
+  by (metis Suc_1 add_less_mono1 le_neq_implies_less lessI linorder_neqE_nat
+   not_add_less2 numeral_plus_numeral semiring_norm(3) trans_less_add2)
+
+lemma T'_less: "T' < N"
+proof -
+  have "T' < 2 * n + 2 * p n + 3 + T'"
+    by simp
+  also have "... < H * (2 * n + 2 * p n + 3 + T')"
+    using H_gr_2 by simp
+  also have "... = N"
+    using N_eq by simp
+  finally show ?thesis .
+qed
+
+text \<open>The three components of a snapshot:\<close>
+
+definition z0 :: "string \<Rightarrow> nat \<Rightarrow> symbol" where
+  "z0 u t \<equiv> exc \<langle>x; u\<rangle> t <.> 0"
+
+definition z1 :: "string \<Rightarrow> nat \<Rightarrow> symbol" where
+  "z1 u t \<equiv> exc \<langle>x; u\<rangle> t <.> 1"
+
+definition z2 :: "string \<Rightarrow> nat \<Rightarrow> state" where
+  "z2 u t \<equiv> fst (exc \<langle>x; u\<rangle> t)"
+
+lemma z0_le: "z0 u t \<le> H"
+  using z0_def H_ge_G tape_alphabet[OF tm_M, where ?j=0 and ?zs="\<langle>x; u\<rangle>"] symbols_lt_pair[of x u] tm_M turing_machine_def
+  by (metis (no_types, lifting) dual_order.strict_trans1 less_or_eq_imp_le zero_less_numeral)
+
+lemma z1_le: "z1 u t \<le> H"
+  using z1_def H_ge_G tape_alphabet[OF tm_M, where ?j=1 and ?zs="\<langle>x; u\<rangle>"] symbols_lt_pair[of x u] tm_M turing_machine_def
+  by (metis (no_types, lifting) dual_order.strict_trans1 less_or_eq_imp_le one_less_numeral_iff semiring_norm(76))
+
+lemma z2_le: "z2 u t \<le> H"
+proof -
+  have "z2 u t \<le> length M"
+    using z2_def turing_machine_execute_states[OF tm_M] start_config_def by simp
+  then show ?thesis
+    using H_ge_length_M by simp
+qed
+
+text \<open>
+The next lemma corresponds to (Z1) from the second equivalence mentioned in the
+introduction. It expresses the first element of a snapshot in terms of $y(u)$
+and $\inputpos$.
+\<close>
+
+lemma z0:
+  assumes "length u = p n"
+  shows "z0 u t = ysymbols u ! (inputpos m t)"
+proof -
+  let ?i = "inputpos m t"
+  let ?y = "\<langle>x; u\<rangle>"
+  have "bit_symbols ?y"
+    by simp
+  have len: "length ?y = m"
+    using assms m_def length_pair by simp
+
+  have "?i < length (ysymbols u)"
+    using inputpos_less' assms length_ysymbols by simp
+  then have *: "ysymbols u ! ?i = (start_config 2 ?y <:> 0) ?i"
+    using ysymbols_init by simp
+
+  have "z0 u t = exc ?y t <.> 0"
+    using z0_def by simp
+  also have "... = (start_config 2 ?y <:> 0) (exc ?y t <#> 0)"
+    using tm_M input_tape_constant start_config_length by simp
+  also have "... = (start_config 2 ?y <:> 0) ?i"
+    using inputpos_oblivious[OF `bit_symbols ?y`] len by simp
+  also have "... = ysymbols u ! ?i"
+    using * by simp
+  finally show ?thesis .
+qed
+
+text \<open>
+The next lemma corresponds to (Z2) from the second equivalence mentioned in the
+introduction. It shows how, in the case $\prev(t) < t$, the second component of
+a snapshot can be expressed recursively using snapshots for earlier steps.
+\<close>
+
+lemma z1:
+  assumes "length u = p n" and "prev m t < t" and "t \<le> T'"
+  shows "z1 u t = (M ! (z2 u (prev m t))) [z0 u (prev m t), z1 u (prev m t)] [.] 1"
+proof -
+  let ?y = "\<langle>x; u\<rangle>"
+  let ?cfg = "exc ?y (prev m t)"
+  have "bit_symbols ?y"
+    by simp
+  moreover have len: "length ?y = m"
+    using assms m_def length_pair by simp
+  ultimately have "exc ?y t <.> 1 = (M ! (fst ?cfg)) [?cfg <.> 0, ?cfg <.> 1] [.] 1"
+    using prev_write_read[of ?y m t ?cfg] assms(2,3) T'_def by fastforce
+  then show ?thesis
+    using z0_def z1_def z2_def by simp
+qed
+
+text \<open>
+The next lemma corresponds to (Z3) from the second equivalence mentioned in the
+introduction. It shows that in the case $\prev(t) = t$, the second component of
+a snapshot equals the blank symbol.
+\<close>
+
+lemma z1':
+  assumes "length u = p n" and "prev m t = t" and "0 < t" and "t \<le> T'"
+  shows "z1 u t = \<box>"
+proof -
+  let ?y = "\<langle>x; u\<rangle>"
+  let ?cfg = "exc ?y (prev m t)"
+  have "bit_symbols ?y"
+    by simp
+  moreover have len: "length ?y = m"
+    using assms m_def length_pair by simp
+  ultimately have "exc ?y t <.> 1 = \<box>"
+    using prev_no_write[of ?y m t] assms T'_def by fastforce
+  then show ?thesis
+    using z0_def z1_def z2_def by simp
+qed
+
+text \<open>
+The next lemma corresponds to (Z4) from the second equivalence mentioned in the
+introduction. It shows how the third component of a snapshot can be expressed
+recursively using snapshots for earlier steps.
+\<close>
+
+lemma z2:
+  assumes "length u = p n" and "t < T'"
+  shows "z2 u (Suc t) = fst ((M ! (z2 u t)) [z0 u t, z1 u t])"
+proof -
+  let ?y = "\<langle>x; u\<rangle>"
+  have "bit_symbols ?y"
+    by simp
+  moreover have len: "length ?y = m"
+    using assms m_def length_pair by simp
+  ultimately have run: "fst (exc ?y t) < length M"
+    using less_TT' assms(2) T'_def by simp
+
+  have "||exc ?y t|| = 2"
+    using start_config_length execute_num_tapes tm_M by simp
+  then have "snd (exc ?y t) = [exc ?y t <!> 0, exc ?y t <!> 1]"
+    by auto (smt (z3) Suc_length_conv length_0_conv nth_Cons_0 nth_Cons_Suc numeral_2_eq_2)
+  then have *: "read (snd (exc ?y t)) = [exc ?y t <.> 0, exc ?y t <.> 1]"
+    using read_def by (metis (no_types, lifting) list.simps(8) list.simps(9))
+
+  have "z2 u (Suc t) = fst (exc ?y (Suc t))"
+    using z2_def by simp
+  also have "... = fst (exe M (exc ?y t))"
+    by simp
+  also have "... = fst (sem (M ! fst (exc ?y t)) (exc ?y t))"
+    using exe_lt_length run by simp
+  also have "... = fst (sem (M ! (z2 u t)) (exc ?y t))"
+    using z2_def by simp
+  also have "... = fst ((M ! (z2 u t)) (read (snd (exc ?y t))))"
+    using sem_fst by simp
+  also have "... = fst ((M ! (z2 u t)) [exc ?y t <.> 0, exc ?y t <.> 1])"
+    using * by simp
+  also have "... = fst ((M ! (z2 u t)) [z0 u t, z1 u t])"
+    using z0_def z1_def by simp
+  finally show ?thesis .
+qed
+
+corollary z2':
+  assumes "length u = p n" and "t > 0" and "t \<le> T'"
+  shows "z2 u t = fst ((M ! (z2 u (t - 1))) [z0 u (t - 1), z1 u (t - 1)])"
+  using assms z2 by (metis Suc_diff_1 Suc_less_eq le_imp_less_Suc)
+
+text \<open>
+The intervals $\zeta_0$, $\zeta_1$, and $\zeta_2$ are long enough for a unary
+encoding of the three components of a snapshot:
+\<close>
+
+definition zeta0 :: "nat \<Rightarrow> nat list" ("\<zeta>\<^sub>0") where
+  "\<zeta>\<^sub>0 t \<equiv> [N + t * Z..<N + t * Z + H]"
+
+definition zeta1 :: "nat \<Rightarrow> nat list" ("\<zeta>\<^sub>1") where
+  "\<zeta>\<^sub>1 t \<equiv> [N + t * Z + H..<N + t * Z + 2 * H]"
+
+definition zeta2 :: "nat \<Rightarrow> nat list" ("\<zeta>\<^sub>2") where
+  "\<zeta>\<^sub>2 t \<equiv> [N + t * Z + 2 * H..<N + (Suc t) * Z]"
+
+lemma length_zeta0 [simp]: "length (\<zeta>\<^sub>0 t) = H"
+  using zeta0_def by simp
+
+lemma length_zeta1 [simp]: "length (\<zeta>\<^sub>1 t) = H"
+  using zeta1_def by simp
+
+lemma length_zeta2 [simp]: "length (\<zeta>\<^sub>2 t) = H"
+  using zeta2_def Z_def by simp
+
+text \<open>
+The substitutions $\rho_t$, which have to be applied to $\psi$ to get the CNF
+formulas $\chi_t$ for the case $\prev(t) < t$:
+\<close>
+
+definition rho :: "nat \<Rightarrow> nat list" ("\<rho>") where
+  "\<rho> t \<equiv>
+     \<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+     \<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t) @
+     \<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @
+     \<gamma> (inputpos m t)"
+
+lemma length_rho: "length (\<rho> t) = 3 * Z + H"
+  using rho_def Z_def by simp
+
+text \<open>
+The substitutions $\rho_t'$, which have to be applied to $\psi'$ to get
+the CNF formulas $\chi_t$ for the case $\prev(t) = t$:
+\<close>
+
+definition rho' :: "nat \<Rightarrow> nat list" ("\<rho>''") where
+  "\<rho>' t \<equiv>
+     \<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+     \<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @
+     \<gamma> (inputpos m t)"
+
+lemma length_rho': "length (\<rho>' t) = 2 * Z + H"
+  using rho'_def Z_def by simp
+
+text \<open>
+An auxiliary lemma for accessing the $n$-th element of a list sandwiched between
+two lists. It will be applied to $xs = \rho_t$ or $xs = \rho'_t$:
+\<close>
+
+lemma nth_append3:
+  fixes xs ys zs ws :: "'a list" and n i :: nat
+  assumes "xs = ys @ zs @ ws" and "i < length zs" and "n = length ys"
+  shows "xs ! (n + i) = zs ! i"
+  using assms by (simp add: nth_append)
+
+text \<open>The formulas $\chi_t$ representing snapshots for $0 < t \leq T'$:\<close>
+
+definition chi :: "nat \<Rightarrow> formula" ("\<chi>") where
+  "\<chi> t \<equiv> if prev m t < t then relabel (\<rho> t) \<psi> else relabel (\<rho>' t) \<psi>'"
+
+text \<open>
+The crucial feature of the formulas $\chi_t$ for $t > 0$ is that they are
+satisfied by exactly those assignments that represent in their bits $N$ to $N +
+Z\cdot(T' + 1)$ the $T' + 1$ snapshots of $M$ on input $\langle x, u\rangle$
+when the relevant portion of the input tape is encoded in the first $N$ bits of
+the assignment.
+
+This works because the $\chi_t$ constrain the assignment to meet the recursive
+characterizations (Z1) --- (Z4) for the snapshots.
+
+The next two lemmas make this more precise.  We first consider the case
+$\prev(t) < t$.  The following lemma says $\alpha$ satisfies $\chi_t$ iff.\
+$\alpha$ satisfies the properties (Z1), (Z2), and (Z4).
+\<close>
+
+lemma satisfies_chi_less:
+  fixes \<alpha> :: assignment
+  assumes "prev m t < t"
+  shows "\<alpha> \<Turnstile> \<chi> t \<longleftrightarrow>
+    unary \<alpha> (\<zeta>\<^sub>0 t) = unary \<alpha> (\<gamma> (inputpos m t)) \<and>
+    unary \<alpha> (\<zeta>\<^sub>1 t) = (M ! (unary \<alpha> (\<zeta>\<^sub>2 (prev m t)))) [unary \<alpha> (\<zeta>\<^sub>0 (prev m t)), unary \<alpha> (\<zeta>\<^sub>1 (prev m t))] [.] 1 \<and>
+    unary \<alpha> (\<zeta>\<^sub>2 t) = fst ((M ! (unary \<alpha> (\<zeta>\<^sub>2 (t - 1)))) [unary \<alpha> (\<zeta>\<^sub>0 (t - 1)), unary \<alpha> (\<zeta>\<^sub>1 (t - 1))])"
+proof -
+  let ?sigma = "\<rho> t"
+  have "\<alpha> \<Turnstile> \<chi> t = \<alpha> \<Turnstile> relabel ?sigma psi"
+    using assms chi_def by simp
+  then have "\<alpha> \<Turnstile> \<chi> t = F (remap ?sigma \<alpha>)"
+      (is "_ = F ?alpha")
+    by (simp add: length_rho satisfies_F)
+  then have *: "\<alpha> \<Turnstile> \<chi> t =
+     (unary ?alpha w\<^sub>6 = unary ?alpha w\<^sub>9 \<and>
+      unary ?alpha w\<^sub>7 = (M ! (unary ?alpha w\<^sub>5)) [unary ?alpha w\<^sub>3, unary ?alpha w\<^sub>4] [.] 1 \<and>
+      unary ?alpha w\<^sub>8 = fst ((M ! (unary ?alpha w\<^sub>2)) [unary ?alpha w\<^sub>0, unary ?alpha w\<^sub>1]))"
+    using F_def by simp
+
+  have w_less_len_rho:
+    "\<forall>s\<in>set w\<^sub>0. s < length (\<rho> t)"
+    "\<forall>s\<in>set w\<^sub>1. s < length (\<rho> t)"
+    "\<forall>s\<in>set w\<^sub>2. s < length (\<rho> t)"
+    "\<forall>s\<in>set w\<^sub>3. s < length (\<rho> t)"
+    "\<forall>s\<in>set w\<^sub>4. s < length (\<rho> t)"
+    "\<forall>s\<in>set w\<^sub>5. s < length (\<rho> t)"
+    "\<forall>s\<in>set w\<^sub>6. s < length (\<rho> t)"
+    "\<forall>s\<in>set w\<^sub>7. s < length (\<rho> t)"
+    "\<forall>s\<in>set w\<^sub>8. s < length (\<rho> t)"
+    "\<forall>s\<in>set w\<^sub>9. s < length (\<rho> t)"
+    using length_rho Z_def by simp_all
+
+  have **: "\<alpha> \<Turnstile> \<chi> t =
+     (unary \<alpha> (reseq ?sigma w\<^sub>6) = unary \<alpha> (reseq ?sigma w\<^sub>9) \<and>
+      unary \<alpha> (reseq ?sigma w\<^sub>7) = (M ! (unary \<alpha> (reseq ?sigma w\<^sub>5))) [unary \<alpha> (reseq ?sigma w\<^sub>3), unary \<alpha> (reseq ?sigma w\<^sub>4)] [.] 1 \<and>
+      unary \<alpha> (reseq ?sigma w\<^sub>8) = fst ((M ! (unary \<alpha> (reseq ?sigma w\<^sub>2))) [unary \<alpha> (reseq ?sigma w\<^sub>0), unary \<alpha> (reseq ?sigma w\<^sub>1)]))"
+    using * w_less_len_rho unary_remap[where ?\<sigma>="?sigma" and ?\<alpha>=\<alpha>]
+    by presburger
+
+  have 1: "reseq ?sigma w\<^sub>0 = \<zeta>\<^sub>0 (t - 1)" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta0_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = [] @ \<zeta>\<^sub>0 (t - 1) @ (\<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t) @ \<zeta>\<^sub>0 t @
+         \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t))"
+        using rho_def by simp
+      have "?sigma ! i = \<zeta>\<^sub>0 (t - 1) ! i"
+        using nth_append3[OF 1, of i 0] Z_def that by simp
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 2: "reseq ?sigma w\<^sub>1 = \<zeta>\<^sub>1 (t - 1)" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta1_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = \<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t) @ \<zeta>\<^sub>0 t @
+         \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho_def by simp
+      have "?sigma ! (H+i) = \<zeta>\<^sub>1 (t - 1) ! i"
+        using that zeta0_def zeta1_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 3: "reseq ?sigma w\<^sub>2 = \<zeta>\<^sub>2 (t - 1)" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show len: "length ?l = length ?r"
+      using zeta2_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1)) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t) @ \<zeta>\<^sub>0 t @
+         \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho_def by simp
+      have "?sigma ! (2*H+i) = \<zeta>\<^sub>2 (t - 1) ! i"
+        using len that zeta0_def zeta1_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 4: "reseq ?sigma w\<^sub>3 = \<zeta>\<^sub>0 (prev m t)" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta0_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1)) @
+          \<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t) @ \<zeta>\<^sub>0 t @
+         \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho_def by simp
+      have "?sigma ! (Z+i) = \<zeta>\<^sub>0 (prev m t) ! i"
+        using that Z_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 5: "reseq ?sigma w\<^sub>4 = \<zeta>\<^sub>1 (prev m t)" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta1_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 (prev m t)) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t) @ \<zeta>\<^sub>0 t @
+         \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho_def by simp
+      have "?sigma ! (Z+H+i) = \<zeta>\<^sub>1 (prev m t) ! i"
+        using that Z_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 6: "reseq ?sigma w\<^sub>5 = \<zeta>\<^sub>2 (prev m t)" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta2_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t)) @ \<zeta>\<^sub>2 (prev m t) @ \<zeta>\<^sub>0 t @
+         \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho_def by simp
+      have "?sigma ! (Z+2*H+i) = \<zeta>\<^sub>2 (prev m t) ! i"
+        using that zeta0_def zeta1_def zeta2_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 7: "reseq ?sigma w\<^sub>6 = \<zeta>\<^sub>0 t" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta0_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t)) @
+          \<zeta>\<^sub>0 t @
+         \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho_def by simp
+      have "?sigma ! (2*Z+i) = \<zeta>\<^sub>0 t ! i"
+        using that Z_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 8: "reseq ?sigma w\<^sub>7 = \<zeta>\<^sub>1 t" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta1_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t) @ \<zeta>\<^sub>0 t) @
+          \<zeta>\<^sub>1 t @
+          \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho_def by simp
+      have "?sigma ! (2*Z+H+i) = \<zeta>\<^sub>1 t ! i"
+        using that Z_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 9: "reseq ?sigma w\<^sub>8 = \<zeta>\<^sub>2 t" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta2_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t) @ \<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t) @
+          \<zeta>\<^sub>2 t @
+          \<gamma> (inputpos m t)"
+        using rho_def by simp
+      have "?sigma ! (2*Z+2*H+i) = \<zeta>\<^sub>2 t ! i"
+        using that zeta2_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 10: "reseq ?sigma w\<^sub>9 = \<gamma> (inputpos m t)" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using gamma_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t) @
+          \<zeta>\<^sub>0 t @
+         \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t) @ \<gamma> (inputpos m t) @ []"
+        using rho_def by simp
+      have "?sigma ! (3*Z+i) = \<gamma> (inputpos m t) ! i"
+        using that Z_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  show ?thesis
+    using ** 1 2 3 4 5 6 7 8 9 10 by simp
+qed
+
+text \<open>
+Next we consider the case $\prev(t) = t$. The following lemma says $\alpha$
+satisfies $\chi_t$ iff.\ $\alpha$ satisfies the properties (Z1), (Z2), and (Z3).
+\<close>
+
+lemma satisfies_chi_eq:
+  assumes "prev m t = t" and "t \<le> T'"
+  shows "\<alpha> \<Turnstile> \<chi> t \<longleftrightarrow>
+    unary \<alpha> (\<zeta>\<^sub>0 t) = unary \<alpha> (\<gamma> (inputpos m t)) \<and>
+    unary \<alpha> (\<zeta>\<^sub>1 t) = 0 \<and>
+    unary \<alpha> (\<zeta>\<^sub>2 t) = fst ((M ! (unary \<alpha> (\<zeta>\<^sub>2 (t - 1)))) [unary \<alpha> (\<zeta>\<^sub>0 (t - 1)), unary \<alpha> (\<zeta>\<^sub>1 (t - 1))])"
+proof -
+  let ?sigma = "\<rho>' t"
+  have "\<alpha> \<Turnstile> \<chi> t = \<alpha> \<Turnstile> relabel ?sigma \<psi>'"
+    using assms(1) chi_def by simp
+  then have "\<alpha> \<Turnstile> \<chi> t = F' (remap ?sigma \<alpha>)"
+      (is "_ = F' ?alpha")
+    by (simp add: length_rho' satisfies_F')
+  then have *: "\<alpha> \<Turnstile> \<chi> t =
+     (unary ?alpha w\<^sub>3 = unary ?alpha w\<^sub>6 \<and>
+      unary ?alpha w\<^sub>4 = 0 \<and>
+      unary ?alpha w\<^sub>5 = fst ((M ! (unary ?alpha w\<^sub>2)) [unary ?alpha w\<^sub>0, unary ?alpha w\<^sub>1]))"
+    using F'_def by simp
+
+  have w_less_len_rho':
+    "\<forall>s\<in>set w\<^sub>0. s < length (\<rho>' t)"
+    "\<forall>s\<in>set w\<^sub>1. s < length (\<rho>' t)"
+    "\<forall>s\<in>set w\<^sub>2. s < length (\<rho>' t)"
+    "\<forall>s\<in>set w\<^sub>3. s < length (\<rho>' t)"
+    "\<forall>s\<in>set w\<^sub>4. s < length (\<rho>' t)"
+    "\<forall>s\<in>set w\<^sub>5. s < length (\<rho>' t)"
+    "\<forall>s\<in>set w\<^sub>6. s < length (\<rho>' t)"
+    using length_rho' Z_def by simp_all
+
+  have **: "\<alpha> \<Turnstile> \<chi> t =
+     (unary \<alpha> (reseq ?sigma w\<^sub>3) = unary \<alpha> (reseq ?sigma w\<^sub>6) \<and>
+      unary \<alpha> (reseq ?sigma w\<^sub>4) = 0 \<and>
+      unary \<alpha> (reseq ?sigma w\<^sub>5) = fst ((M ! (unary \<alpha> (reseq ?sigma w\<^sub>2))) [unary \<alpha> (reseq ?sigma w\<^sub>0), unary \<alpha> (reseq ?sigma w\<^sub>1)]))"
+    using * w_less_len_rho' unary_remap[where ?\<sigma>="?sigma" and ?\<alpha>=\<alpha>]
+    by presburger
+
+  have 1: "reseq ?sigma w\<^sub>0 = \<zeta>\<^sub>0 (t - 1)" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta0_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = [] @ \<zeta>\<^sub>0 (t - 1) @ (\<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t))"
+        using rho'_def by simp
+      have "?sigma ! i = \<zeta>\<^sub>0 (t - 1) ! i"
+        using nth_append3[OF 1, of i 0] Z_def that by simp
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 2: "reseq ?sigma w\<^sub>1 = \<zeta>\<^sub>1 (t - 1)" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta1_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = \<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho'_def by simp
+      have "?sigma ! (H+i) = \<zeta>\<^sub>1 (t - 1) ! i"
+        using that zeta0_def zeta1_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 3: "reseq ?sigma w\<^sub>2 = \<zeta>\<^sub>2 (t - 1)" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show len: "length ?l = length ?r"
+      using zeta2_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1)) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho'_def by simp
+      have "?sigma ! (2*H+i) = \<zeta>\<^sub>2 (t - 1) ! i"
+        using len that zeta0_def zeta1_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 4: "reseq ?sigma w\<^sub>3 = \<zeta>\<^sub>0 t" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta0_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1)) @
+          \<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho'_def by simp
+      have "?sigma ! (Z+i) = \<zeta>\<^sub>0 t ! i"
+        using that Z_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 5: "reseq ?sigma w\<^sub>4 = \<zeta>\<^sub>1 t" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta1_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 t) @ \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho'_def by simp
+      have "?sigma ! (Z+H+i) = \<zeta>\<^sub>1 t ! i"
+        using that Z_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 6: "reseq ?sigma w\<^sub>5 = \<zeta>\<^sub>2 t" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using zeta2_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t) @ \<zeta>\<^sub>2 t @ \<gamma> (inputpos m t)"
+        using rho'_def by simp
+      have "?sigma ! (Z+2*H+i) = \<zeta>\<^sub>2 t ! i"
+        using that zeta0_def zeta1_def zeta2_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  have 7: "reseq ?sigma w\<^sub>6 = (\<gamma> (inputpos m t))" (is "?l = ?r")
+  proof (rule nth_equalityI)
+    show "length ?l = length ?r"
+      using gamma_def by simp
+    show "?l ! i = ?r ! i" if "i < length ?l" for i
+    proof -
+      have 1: "?sigma = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1) @
+          \<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t) @ \<gamma> (inputpos m t) @ []"
+        using rho'_def by simp
+      have "?sigma ! (2*Z+i) = \<gamma> (inputpos m t) ! i"
+        using that Z_def gamma_def by (intro nth_append3[OF 1]) auto
+      then show ?thesis
+        using reseq_def that by simp
+    qed
+  qed
+
+  show ?thesis
+    using ** 1 2 3 4 5 6 7 by simp
+qed
+
+
+section \<open>The CNF formula $\Phi$\<close>
+
+text \<open>
+We can now formulate all the parts $\Phi_0, \dots, \Phi_9$ of the complete
+formula $\Phi$, and thus $\Phi$ itself.
+
+Representing the snapshot in step~0:
+\<close>
+
+definition PHI0 :: formula ("\<Phi>\<^sub>0") where
+  "\<Phi>\<^sub>0 \<equiv> \<Psi> (\<zeta>\<^sub>0 0) 1 @ \<Psi> (\<zeta>\<^sub>1 0) 1 @ \<Psi> (\<zeta>\<^sub>2 0) 0"
+
+text \<open>The start symbol at the beginning of the input tape:\<close>
+
+definition PHI1 :: formula ("\<Phi>\<^sub>1") where
+  "\<Phi>\<^sub>1 \<equiv> \<Psi> (\<gamma> 0) 1"
+
+text \<open>The separator \textbf{11} between $x$ and $u$:\<close>
+
+definition PHI2 :: formula ("\<Phi>\<^sub>2") where
+  "\<Phi>\<^sub>2 \<equiv> \<Psi> (\<gamma> (2*n+1)) 3 @ \<Psi> (\<gamma> (2*n+2)) 3"
+
+text \<open>The zeros before the symbols of $x$:\<close>
+
+definition PHI3 :: formula ("\<Phi>\<^sub>3") where
+  "\<Phi>\<^sub>3 \<equiv> concat (map (\<lambda>i. \<Psi> (\<gamma> (2*i+1)) 2) [0..<n])"
+
+text \<open>The zeros before the symbols of $u$:\<close>
+
+definition PHI4 :: formula ("\<Phi>\<^sub>4") where
+  "\<Phi>\<^sub>4 \<equiv> concat (map (\<lambda>i. \<Psi> (\<gamma> (2*n+2+2*i+1)) 2) [0..<p n])"
+
+text \<open>The blank symbols after the input $\langle x, u\rangle$:\<close>
+
+definition PHI5 :: formula ("\<Phi>\<^sub>5") where
+  "\<Phi>\<^sub>5 \<equiv> concat (map (\<lambda>i. \<Psi> (\<gamma> (2*n + 2*p n + 3 + i)) 0) [0..<T'])"
+
+text \<open>The symbols of $x$:\<close>
+
+definition PHI6 :: formula ("\<Phi>\<^sub>6") where
+  "\<Phi>\<^sub>6 \<equiv> concat (map (\<lambda>i. \<Psi> (\<gamma> (2*i+2)) (if x ! i then 3 else 2)) [0..<n])"
+
+text \<open>Constraining the symbols of $u$ to be from $\{\mathbf{0}, \mathbf{1}\}$:\<close>
+
+definition PHI7 :: formula ("\<Phi>\<^sub>7") where
+  "\<Phi>\<^sub>7 \<equiv> concat (map (\<lambda>i. \<Upsilon> (\<gamma> (2*n+4+2*i))) [0..<p n])"
+
+text \<open>Reading a \textbf{1} in the final step to signal acceptance of $\langle x, u\rangle$:\<close>
+
+definition PHI8 :: formula ("\<Phi>\<^sub>8") where
+  "\<Phi>\<^sub>8 \<equiv> \<Psi> (\<zeta>\<^sub>1 T') 3"
+
+text \<open>The snapshots after the first and before the last:\<close>
+
+definition PHI9 :: formula ("\<Phi>\<^sub>9") where
+  "\<Phi>\<^sub>9 \<equiv> concat (map (\<lambda>t. \<chi> (Suc t)) [0..<T'])"
+
+text \<open>The complete formula:\<close>
+
+definition PHI :: formula ("\<Phi>") where
+  "\<Phi> \<equiv> \<Phi>\<^sub>0 @ \<Phi>\<^sub>1 @ \<Phi>\<^sub>2 @ \<Phi>\<^sub>3 @ \<Phi>\<^sub>4 @ \<Phi>\<^sub>5 @ \<Phi>\<^sub>6 @ \<Phi>\<^sub>7 @ \<Phi>\<^sub>8 @ \<Phi>\<^sub>9"
+
+
+section \<open>Correctness of the formula\<close>
+
+text \<open>
+We have to show that the formula $\Phi$ is satisfiable if and only if $x \in L$.
+There is a subsection for both of the implications. Instead of $x \in L$ we will
+use the right-hand side of the following equivalence.
+\<close>
+
+lemma L_iff_ex_u: "x \<in> L \<longleftrightarrow>  (\<exists>u. length u = p n \<and> exc \<langle>x; u\<rangle> T' <.> 1 = \<one>)"
+proof -
+  have "x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> exc \<langle>x; u\<rangle> (T (length \<langle>x; u\<rangle>)) <.> 1 = \<one>)"
+    using cert by simp
+  also have "... \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> exc \<langle>x; u\<rangle> (TT (length \<langle>x; u\<rangle>)) <.> 1 = \<one>)"
+  proof -
+    have "bit_symbols \<langle>x; u\<rangle>" for u
+      by simp
+    then have "exc \<langle>x; u\<rangle> (TT (length \<langle>x; u\<rangle>)) = exc \<langle>x; u\<rangle> (T (length \<langle>x; u\<rangle>))" for u
+      using exc_TT_eq_exc_T by blast
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<longleftrightarrow>  (\<exists>u. length u = p n \<and> exc \<langle>x; u\<rangle> T' <.> 1 = \<one>)"
+    using T'_def length_pair m_def by auto
+  finally show ?thesis .
+qed
+
+
+subsection \<open>$\Phi$ satisfiable implies $x\in L$\<close>
+
+text \<open>
+The proof starts from an assignment $\alpha$ satisfying $\Phi$ and shows that
+there is a string $u$ of length $p(n)$ such that $M$, on input $\langle x,
+u\rangle$, halts with the output tape head on the symbol \textbf{1}. The overarching
+idea is that $\alpha$, by satisfying $\Phi$, encodes a string $u$ and a
+computation of $M$ on $u$ that results in $M$ halting with the output tape head on
+the symbol~\textbf{1}.
+
+The assignment $\alpha$ is an infinite bit string, whose first $N = m'\cdot H$
+bits are supposed to encode the first $m'$ symbols on $M$'s input tape, which
+contains the pair $\langle x, u\rangle$. The first step of the proof is thus to
+extract a $u$ of length $p(n)$ from the first $N$ bits of $\alpha$.  The Formula
+$\Phi_7$ ensures that the symbols representing $u$ are \textbf{0} or \textbf{1}
+and thus represent a bit string.
+
+Next the proof shows that the first $N$ bits of $\alpha$ encode the relevant
+portion $y(u)$ of the input tape for the $u$ just extracted, that is, $y(u)_i =
+\alpha(\gamma_i)$ for $i < m'$. The proof exploits the constraints set by
+$\Phi_1$ to $\Phi_6$. In particular this implies that $y(u)_{\inputpos(t)} =
+\alpha(\gamma_{\inputpos(t)})$ for all $t$.
+
+The next $Z\cdot (T' + 1)$ bits of $\alpha$ encode $T' + 1$ snapshots.  More
+precisely, we prove $z_0(u, t) = \alpha(\zeta_0^t)$ and $z_1(u, t) =
+\alpha(\zeta_1^t)$ and $z_2(u, t) = \alpha(\zeta_2^t)$ for all $t \leq T'$. This
+works by induction on $t$. The case $t = 0$ is covered by the formula $\Phi_0$.
+For $0 < t \leq T'$ the formulas $\chi_t$ are responsible, which make up
+$\Phi_9$. Basically $\chi_t$ represents the recursive characterization of the
+snapshot $z_t$ in terms of earlier snapshots (of $t-1$ and possibly $prev(t)$).
+This is the trickiest part and we need some preliminary lemmas for that.
+
+Once that is done, we know that some bits of $\alpha$, namely
+$\alpha(\zeta_1(T'))$, encode the symbol under the output tape head after $T'$ steps,
+that is, when $M$ has halted. Formula $\Phi_8$ ensures that this symbol is
+\textbf{1}, which concludes the proof.
+
+\null
+\<close>
+
+lemma sat_PHI_imp_ex_u:
+  assumes "satisfiable \<Phi>"
+  shows "\<exists>u. length u = p n \<and> exc \<langle>x; u\<rangle> T' <.> 1 = \<one>"
+proof -
+  obtain \<alpha> where \<alpha>: "\<alpha> \<Turnstile> \<Phi>"
+    using assms satisfiable_def by auto
+
+  define us where "us = map (\<lambda>i. unary \<alpha> (\<gamma> (2*n+4+2*i))) [0..<p n]"
+
+  have len_us: "length us = p n"
+    using us_def by simp
+
+  have us23: "us ! i = 2 \<or> us ! i = 3" if "i < p n" for i
+  proof -
+    have "\<alpha> \<Turnstile> \<Phi>\<^sub>7"
+      using PHI_def satisfies_def \<alpha> by simp
+    then have "\<alpha> \<Turnstile> \<Upsilon> (\<gamma> (2*n+4+2*i))"
+      using that PHI7_def satisfies_concat_map by auto
+    then have "unary \<alpha> (\<gamma> (2*n+4+2*i)) = 2 \<or> unary \<alpha> (\<gamma> (2*n+4+2*i)) = 3"
+      using Upsilon_unary length_gamma H_gr_2 by simp
+    then show ?thesis
+      using us_def that by simp
+  qed
+
+  define u :: string where "u = symbols_to_string us"
+
+  have len_u: "length u = p n"
+    using u_def len_us by simp
+
+  have "ysymbols u ! i = unary \<alpha> (\<gamma> i)" if "i < m'" for i
+  proof -
+    consider
+        "i = 0"
+      | "1 \<le> i \<and> i < 2 * n + 1"
+      | "2 * n + 1 \<le> i \<and> i < 2 * n + 3"
+      | "2 * n + 3 \<le> i \<and> i < m + 1"
+      | "i \<ge> m + 1 \<and> i < m + 1 + T'"
+      using `i < m'` m'_def m_def by linarith
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "\<alpha> \<Turnstile> \<Psi> (\<gamma> i) 1"
+        using PHI_def PHI1_def \<alpha> satisfies_append by metis
+      then have "unary \<alpha> (\<gamma> i) = 1"
+        using Psi_unary H_gr_2 gamma_def by simp
+      moreover have "ysymbols u ! i = 1"
+        using 1 by (simp add: ysymbols_def)
+      ultimately show ?thesis
+        by simp
+    next
+      case 2
+      define j where "j = (i - 1) div 2"
+      then have "j < n"
+        using 2 by auto
+      have "i = 2 * j + 1 \<or> i = 2 * j + 2"
+        using 2 j_def by auto
+      then show ?thesis
+      proof
+        assume i: "i = 2 * j + 1"
+        have "\<alpha> \<Turnstile> \<Phi>\<^sub>3"
+          using PHI_def satisfies_def \<alpha> by simp
+        then have "\<alpha> \<Turnstile> \<Psi> (\<gamma> (2*j+1)) 2"
+          using PHI3_def satisfies_concat_map[OF _ `j < n`] by auto
+        then have "unary \<alpha> (\<gamma> (2*j+1)) = 2"
+          using Psi_unary H_gr_2 gamma_def by simp
+        moreover have "ysymbols u ! (2*j+1) = 2"
+          using ysymbols_first_at[OF `j < n`] by simp
+        ultimately show ?thesis
+          using i by simp
+      next
+        assume i: "i = 2 * j + 2"
+        have "\<alpha> \<Turnstile> \<Phi>\<^sub>6"
+          using PHI_def satisfies_def \<alpha> by simp
+        then have "\<alpha> \<Turnstile> \<Psi> (\<gamma> (2*j+2)) (if x ! j then 3 else 2)"
+          using PHI6_def satisfies_concat_map[OF _ `j < n`] by fastforce
+        then have "unary \<alpha> (\<gamma> (2*j+2)) = (if x ! j then 3 else 2)"
+          using Psi_unary H_gr_2 gamma_def by simp
+        moreover have "ysymbols u ! (2*j+2) = (if x ! j then 3 else 2)"
+          using ysymbols_first_at[OF `j < n`] by simp
+        ultimately show ?thesis
+          using i by simp
+      qed
+    next
+      case 3
+      then have "i = 2*n + 1 \<or> i = 2*n + 2"
+        by auto
+      then show ?thesis
+      proof
+        assume i: "i = 2 * n + 1"
+        then have "\<alpha> \<Turnstile> \<Psi> (\<gamma> i) 3"
+          using PHI_def PHI2_def \<alpha> satisfies_append by metis
+        then have "unary \<alpha> (\<gamma> i) = 3"
+          using Psi_unary H_gr_2 gamma_def by simp
+        moreover have "ysymbols u ! i = 3"
+          using i ysymbols_at_2n1 by simp
+        ultimately show ?thesis
+          by simp
+      next
+        assume i: "i = 2 * n + 2"
+        then have "\<alpha> \<Turnstile> \<Psi> (\<gamma> i) 3"
+          using PHI_def PHI2_def \<alpha> satisfies_append by metis
+        then have "unary \<alpha> (\<gamma> i) = 3"
+          using Psi_unary H_gr_2 gamma_def by simp
+        moreover have "ysymbols u ! i = 3"
+          using i ysymbols_at_2n2 by simp
+        ultimately show ?thesis
+          by simp
+      qed
+    next
+      case 4
+      moreover define j where "j = (i - 2*n-3) div 2"
+      ultimately have j: "j < p n"
+        using m_def by auto
+      have "i = 2*n+2+2 * j + 1 \<or> i = 2*n+2+2 * j + 2"
+        using 4 j_def by auto
+      then show ?thesis
+      proof
+        assume i: "i = 2 * n + 2 + 2 * j + 1"
+        have "\<alpha> \<Turnstile> \<Phi>\<^sub>4"
+          using PHI_def satisfies_def \<alpha> by simp
+        then have "\<alpha> \<Turnstile> \<Psi> (\<gamma> (2*n+2+2*j+1)) 2"
+          using PHI4_def satisfies_concat_map[OF _ `j < p n`] by auto
+        then have "unary \<alpha> (\<gamma> (2*n+2+2*j+1)) = 2"
+          using Psi_unary H_gr_2 gamma_def by simp
+        moreover have "ysymbols u ! (2*n+2+2*j+1) = 2"
+          using \<open>j < p n\<close> ysymbols_second_at(1) len_u by presburger
+        ultimately show ?thesis
+          using i by simp
+      next
+        assume i: "i = 2 * n + 2 + 2 * j + 2"
+        have "us ! j = unary \<alpha> (\<gamma> (2*n+4+2*j))"
+          using us_def `j < p n` by simp
+        then have "us ! j = unary \<alpha> (\<gamma> (2*n+2+2*j+2))"
+          by (simp add: numeral_Bit0)
+        then have "unary \<alpha> (\<gamma> (2*n+2+2*j+2)) = (if u ! j then 3 else 2)"
+          using u_def us23 \<open>j < p local.n\<close> len_us by fastforce
+        then have *: "unary \<alpha> (\<gamma> i) = (if u ! j then 3 else 2)"
+          using i by simp
+        have "ysymbols u ! (2*n+2+2*j+2) = (if u ! j then 3 else 2)"
+          using ysymbols_second_at(2) `j < p n` len_u by simp
+        then have "ysymbols u ! i = (if u ! j then 3 else 2)"
+          using i by simp
+        then show ?thesis
+          using * i by simp
+      qed
+    next
+      case 5
+      then have "\<alpha> \<Turnstile> \<Phi>\<^sub>5"
+        using PHI_def satisfies_def \<alpha> by simp
+      then have "\<alpha> \<Turnstile> \<Psi> (\<gamma> (2*n+2*p n + 3 + i')) 0" if "i' < T'" for i'
+        unfolding PHI5_def using \<alpha> satisfies_concat_map[OF _ that, of \<alpha>] that by auto
+      moreover obtain i' where i': "i' < T'" "i = m + 1 + i'"
+        using 5 by (metis add_less_cancel_left le_Suc_ex)
+      ultimately have "\<alpha> \<Turnstile> \<Psi> (\<gamma> i) 0"
+        using m_def numeral_3_eq_3 by simp
+      then have "unary \<alpha> (\<gamma> i) = 0"
+        using Psi_unary H_gr_2 gamma_def by simp
+      moreover have "ysymbols u ! i = 0"
+        using 5 ysymbols_last len_u by simp
+      ultimately show ?thesis
+        by simp
+    qed
+  qed
+  then have ysymbols: "ysymbols u ! (inputpos m t) = unary \<alpha> (\<gamma> (inputpos m t))" for t
+    using inputpos_less' len_u by simp
+
+  have "z0 u t = unary \<alpha> (\<zeta>\<^sub>0 t) \<and> z1 u t = unary \<alpha> (\<zeta>\<^sub>1 t) \<and> z2 u t = unary \<alpha> (\<zeta>\<^sub>2 t)"
+      if "t \<le> T'" for t
+    using that
+  proof (induction t rule: nat_less_induct)
+    case (1 t)
+    show ?case
+    proof (cases "t = 0")
+      case True
+      have "\<alpha> \<Turnstile> \<Phi>\<^sub>0"
+        using \<alpha> PHI_def satisfies_def by simp
+      then have
+        1: "\<alpha> \<Turnstile> \<Psi> (\<zeta>\<^sub>0 0) 1" and
+        2: "\<alpha> \<Turnstile> \<Psi> (\<zeta>\<^sub>1 0) 1" and
+        3: "\<alpha> \<Turnstile> \<Psi> (\<zeta>\<^sub>2 0) 0"
+        using PHI0_def by (metis satisfies_append(1), metis satisfies_append, metis satisfies_append(2))
+      have "unary \<alpha> (\<zeta>\<^sub>0 0) = 1"
+        using Psi_unary[OF _ 1] H_gr_2 by simp
+      moreover have "unary \<alpha> (\<zeta>\<^sub>1 0) = 1"
+        using Psi_unary[OF _ 2] H_gr_2 by simp
+      moreover have "unary \<alpha> (\<zeta>\<^sub>2 0) = 0"
+        using Psi_unary[OF _ 3] by simp
+      moreover have "z0 u 0 = \<triangleright>"
+        using z0_def start_config2 by (simp add: start_config_pos)
+      moreover have "z1 u 0 = \<triangleright>"
+        using z1_def by (simp add: start_config2 start_config_pos)
+      moreover have "z2 u 0 = \<box>"
+        using z2_def by (simp add: start_config_def)
+      ultimately show ?thesis
+        using True by simp
+    next
+      case False
+      then have "t > 0"
+        by simp
+      let ?t = "t - 1"
+      have sat_chi: "\<alpha> \<Turnstile> \<chi> t"
+      proof -
+        have "\<alpha> \<Turnstile> \<Phi>\<^sub>9"
+          using \<alpha> PHI_def satisfies_def by simp
+        moreover have "?t < T'"
+          using 1 `t > 0` by simp
+        ultimately have "\<alpha> \<Turnstile> \<chi> (Suc ?t)"
+          using satisfies_concat_map PHI9_def by auto
+        then show ?thesis
+          using \<open>t > 0\<close> by simp
+      qed
+      show ?thesis
+      proof (cases "prev m t < t")
+        case True
+        then show ?thesis
+          using satisfies_chi_less z0 z1 z2' 1 len_u ysymbols sat_chi True `t \<le> T'` len_u by simp
+      next
+        case False
+        then have eq: "prev m t = t"
+          using prev_eq prev_less by blast
+        show ?thesis
+          using satisfies_chi_eq z0 z1' z2' ysymbols sat_chi eq `t > 0` `t \<le> T'` len_u 1 `t > 0` by simp
+      qed
+    qed
+  qed
+  then have "z1 u T' = unary \<alpha> (\<zeta>\<^sub>1 T')"
+    by simp
+  moreover have "unary \<alpha> (\<zeta>\<^sub>1 T') = 3"
+  proof -
+    have "\<alpha> \<Turnstile> \<Phi>\<^sub>8"
+      using \<alpha> PHI_def satisfies_def by simp
+    then have "\<alpha> \<Turnstile> \<Psi> (\<zeta>\<^sub>1 T') 3"
+      using PHI8_def by simp
+    then show ?thesis
+      using Psi_unary[of 3 "\<zeta>\<^sub>1 T'"] length_zeta1 H_gr_2 by simp
+  qed
+  ultimately have "z1 u T' = \<one>"
+    by simp
+  then have "exc \<langle>x; u\<rangle> T' <.> 1 = \<one>"
+    using z1_def by simp
+  then show ?thesis
+    using len_u by auto
+qed
+
+
+subsection \<open>$x\in L$ implies $\Phi$ satisfiable\<close>
+
+text \<open>
+For the other direction, we assume a string $x \in L$ and show that the formula
+$\Phi$ derived from it is satisfiable. From $x \in L$ it follows that there is a
+certificate $u$ of length $p(n)$ such that $M$ on input $\langle x, u\rangle$
+halts after $T'$ steps with the output tape head on the symbol~\textbf{1}.
+
+An assignment that satisfies $\Phi$ must have its first $N = m' \cdot H$ bits
+set in such a way that they encode the relevant portion $y(u)$ of the input
+tape, that is, with $\langle x, u\rangle$ followed by $T'$ blanks.  This will
+take care of satisfying $\Phi_1, \dots, \Phi_7$.  The next $Z\cdot (T' + 1)$
+bits of $\alpha$ must be set such that they encode the $T' + 1$ snapshots of $M$
+when started on $\langle x, u\rangle$. This way $\Phi_0$ and $\Phi_9$ will be
+satisfied.  Finally, $\Phi_8$ is satisfied because by the choice of $u$ the last
+snapshot contains a \textbf{1} as the symbol under the output tape head.
+
+The following function maps a string $u$ to an assignment as just described.
+\<close>
+
+definition beta :: "string \<Rightarrow> assignment" ("\<beta>") where
+  "\<beta> u i \<equiv>
+    if i < N then
+      let
+        j = i div H;
+        k = i mod H
+      in
+        if j = 0 then k < 1
+        else if j = 2 * n + 1 \<or> j = 2 * n + 2 then k < 3
+        else if j \<ge> 2 * n + 2 * p n + 3 then k < 0
+        else if odd j then k < 2
+        else if j \<le> 2 * n then k < (if x ! (j div 2 - 1) then 3 else 2)
+        else k < (if u ! (j div 2 - n - 2) then 3 else 2)
+    else if i < N + Z * (Suc T') then
+      let t = (i - N) div Z; k = (i - N) mod Z in
+        if k < H then k < z0 u t
+        else if k < 2 * H then k - H < z1 u t
+        else k - 2 * H < z2 u t
+    else False"
+
+text \<open>
+In order to show that $\beta(u)$ satisfies $\Phi$, we show that it satisfies all
+parts of $\Phi$. These parts consist mostly of $\Psi$ formulas, whose
+satisfiability can be proved using lemma~@{thm [source] satisfies_Psi}. To apply
+this lemma, the following ones will be helpful.
+\<close>
+
+lemma blocky_gammaI:
+  assumes "\<And>k. k < H \<Longrightarrow> \<alpha> (j * H + k) = (k < l)"
+  shows "blocky \<alpha> (\<gamma> j) l"
+  unfolding blocky_def gamma_def using assms by simp
+
+lemma blocky_zeta0I:
+  assumes "\<And>k. k < H \<Longrightarrow> \<alpha> (N + t * Z + k) = (k < l)"
+  shows "blocky \<alpha> (\<zeta>\<^sub>0 t) l"
+  unfolding blocky_def zeta0_def using assms by simp
+
+lemma blocky_zeta1I:
+  assumes "\<And>k. k < H \<Longrightarrow> \<alpha> (N + t * Z + H + k) = (k < l)"
+  shows "blocky \<alpha> (\<zeta>\<^sub>1 t) l"
+  unfolding blocky_def zeta1_def using assms by simp
+
+lemma blocky_zeta2I:
+  assumes "\<And>k. k < H \<Longrightarrow> \<alpha> (N + t * Z + 2 * H + k) = (k < l)"
+  shows "blocky \<alpha> (\<zeta>\<^sub>2 t) l"
+  unfolding blocky_def zeta2_def using Z_def assms by simp
+
+lemma beta_1: "blocky (\<beta> u) (\<gamma> 0) 1"
+proof (intro blocky_gammaI)
+  fix k :: nat
+  assume k: "k < H"
+  let ?i = "0 * H + k"
+  have "?i < N"
+    using N_eq add_mult_distrib2 k by auto
+  then show "\<beta> u ?i = (k < 1)"
+    using beta_def k by simp
+qed
+
+lemma beta_2a: "blocky (\<beta> u) (\<gamma> (2*n+1)) 3"
+proof (intro blocky_gammaI)
+  fix k :: nat
+  assume k: "k < H"
+  let ?i = "(2*n+1) * H + k"
+  let ?j = "?i div H"
+  let ?k = "?i mod H"
+  have "?i < N"
+    using N_eq add_mult_distrib2 k by auto
+  moreover have j: "?j = 2 * n + 1"
+    using k by (metis add_cancel_left_right div_less div_mult_self3 less_nat_zero_code)
+  moreover have "?k = k"
+    using k by (metis mod_if mod_mult_self3)
+  moreover have "\<not> ?j = 0"
+    using j by linarith
+  ultimately show "\<beta> u ?i = (k < 3)"
+    using beta_def by simp
+qed
+
+lemma beta_2b: "blocky (\<beta> u) (\<gamma> (2*n+2)) 3"
+proof (intro blocky_gammaI)
+  fix k :: nat
+  assume k: "k < H"
+  let ?i = "(2*n+2) * H + k"
+  let ?j = "?i div H"
+  let ?k = "?i mod H"
+  have "?i < N"
+    using N_eq add_mult_distrib2 k by auto
+  moreover have "?j = 2 * n + 2"
+    using k by (metis add_cancel_left_right div_less div_mult_self3 less_nat_zero_code)
+  moreover have "?k = k"
+    using k by (metis mod_if mod_mult_self3)
+  moreover have "\<not> ?j = 0"
+    using calculation(2) by linarith
+  ultimately show "\<beta> u ?i = (k < 3)"
+    using beta_def Let_def k by presburger
+qed
+
+lemma beta_3:
+  assumes "ii < n"
+  shows "blocky (\<beta> u) (\<gamma> (2 * ii + 1)) 2"
+proof (intro blocky_gammaI)
+  fix k ::nat
+  assume k: "k < H"
+  let ?i = "(2*ii+1) * H + k"
+  let ?j = "?i div H"
+  let ?k = "?i mod H"
+  have "?i < N"
+  proof -
+    have "?i < (2*n+1) * H + k"
+      using assms k by simp
+    also have "... < (2*n+1) * H + H"
+      using k by simp
+    also have "... = H * (2*n+2)"
+      by simp
+    also have "... \<le> H * (2*n+3)"
+      by (metis add.commute add.left_commute add_2_eq_Suc le_add2 mult_le_mono2 numeral_3_eq_3)
+    also have "... \<le> H * (2*n+2*p n+3)"
+      by simp
+    also have "... \<le> H * (2*n+2*p n+3 + T')"
+      by simp
+    finally have "?i < H * (2*n+2*p n+3 + T')" .
+    then show ?thesis
+      using N_eq by simp
+  qed
+  moreover have j: "?j = 2 * ii + 1"
+    using k by (metis add_cancel_left_right div_less div_mult_self3 less_nat_zero_code)
+  moreover have "?k = k"
+    using k by (metis mod_if mod_mult_self3)
+  moreover have "\<not> ?j = 0"
+    using j by linarith
+  moreover have "\<not> (?j = 2*n+1 \<or> ?j = 2*n+2)"
+    using j assms by simp
+  moreover have "\<not> ?j \<ge> 2*n+2*p n + 3"
+    using j assms by simp
+  moreover have "odd ?j"
+    using j by simp
+  ultimately show "\<beta> u ?i = (k < 2)"
+    using beta_def by simp
+qed
+
+lemma beta_4:
+  assumes "ii < p n" and "length u = p n"
+  shows "blocky (\<beta> u) (\<gamma> (2*n+2+2*ii+1)) 2"
+proof (intro blocky_gammaI)
+  fix k :: nat
+  assume k: "k < H"
+  let ?i = "(2*n+2+2*ii+1) * H + k"
+  let ?j = "?i div H"
+  let ?k = "?i mod H"
+  have "?i < N"
+  proof -
+    have "?i = (2*n+2*ii+3) * H + k"
+      by (simp add: numeral_3_eq_3)
+    also have "... < (2*n+2*ii+3) * H + H"
+      using k by simp
+    also have "... = H * (2*n+2*ii+4)"
+      by algebra
+    also have "... \<le> H * (2*n+2*p n+3)"
+      using assms(1) by simp
+    also have "... \<le> H * (2*n+2*p n+3 + T')"
+      by simp
+    finally have "?i < H * (2*n+2*p n+3 + T')" .
+    then show ?thesis
+      using N_eq by simp
+  qed
+  moreover have j: "?j = 2 * n + 2 + 2 * ii + 1"
+    using k by (metis add_cancel_left_right div_less div_mult_self3 less_nat_zero_code)
+  moreover have "?k = k"
+    using k by (metis mod_if mod_mult_self3)
+  moreover have "\<not> ?j = 0"
+    using j by linarith
+  moreover have "\<not> (?j = 2*n+1 \<or> ?j = 2*n+2)"
+    using j assms by simp
+  moreover have "\<not> ?j \<ge> 2*n+2*p n + 3"
+    using j assms by simp
+  moreover have "odd ?j"
+    using j by simp
+  ultimately show "\<beta> u ?i = (k < 2)"
+    using beta_def by simp
+qed
+
+lemma beta_5:
+  assumes "ii < T'"
+  shows "blocky (\<beta> u) (\<gamma> (2*n+2*p n + 3 + ii)) 0"
+proof (intro blocky_gammaI)
+  fix k :: nat
+  assume k: "k < H"
+  let ?i = "(2*n+2*p n + 3 + ii) * H + k"
+  let ?j = "?i div H"
+  let ?k = "?i mod H"
+  have "?i < N"
+  proof -
+    have "?i < (2*n+2*p n + 3 + ii) * H + H"
+      using k by simp
+    also have "... \<le> (2*n+2*p n + 3 + T' - 1) * H + H"
+    proof -
+      have "2*n+2*p n + 3 + ii \<le> 2*n+2*p n + 3 + T' - 1"
+        using assms by simp
+      then show ?thesis
+        using add_le_mono1 mult_le_mono1 by presburger
+    qed
+    also have "... \<le> (2*n+2*p n + 2 + T') * H + H"
+      by simp
+    also have "... \<le> H * (2*n+2*p n + 3 + T')"
+      by (simp add: numeral_3_eq_3)
+    finally have "?i < H * (2*n+2*p n + 3 + T')" .
+    then show ?thesis
+      using N_eq by simp
+  qed
+  moreover have j: "?j = 2 * n + 2*p n + 3 + ii"
+    using k by (metis add_cancel_left_right div_less div_mult_self3 less_nat_zero_code)
+  moreover have "?k = k"
+    using k by (metis mod_if mod_mult_self3)
+  moreover have "\<not> ?j = 0"
+    using j by linarith
+  moreover have "\<not> (?j = 2*n+1 \<or> ?j = 2*n+2)"
+    using j by simp
+  ultimately show "\<beta> u ?i = (k < 0)"
+    using beta_def Let_def k by simp
+qed
+
+lemma beta_6:
+  assumes "ii < n"
+  shows "blocky (\<beta> u) (\<gamma> (2 * ii + 2)) (if x ! ii then 3 else 2)"
+proof (intro blocky_gammaI)
+  fix k :: nat
+  assume k: "k < H"
+  let ?i = "(2*ii+2) * H + k"
+  let ?j = "?i div H"
+  let ?k = "?i mod H"
+  have "?i < N"
+  proof -
+    have "?i \<le> (2*n+2) * H + k"
+      using assms by simp
+    also have "... < (2*n+2) * H + H"
+      using k by simp
+    also have "... = (2*n+3) * H"
+      by algebra
+    also have "... \<le> (2*n + 2*p n + 3) * H"
+      by simp
+    also have "... \<le> (2*n + 2*p n + 3 + T') * H"
+      by simp
+    finally have "?i < (2*n + 2*p n + 3 + T') * H" .
+    then show ?thesis
+      using N_eq by (metis mult.commute)
+  qed
+  moreover have j: "?j = 2 * ii + 2"
+    using k by (metis add_cancel_left_right div_less div_mult_self3 less_nat_zero_code)
+  moreover have "?k = k"
+    using k by (metis mod_if mod_mult_self3)
+  moreover have "\<not> ?j = 0"
+    using j by linarith
+  moreover have "\<not> (?j = 2*n+1 \<or> ?j = 2*n+2)"
+    using j assms by simp
+  moreover have "\<not> ?j = 2*n+2*p n + 3"
+    using j assms by simp
+  moreover have "\<not> odd ?j"
+    using j by simp
+  moreover have "?j \<le> 2 * n"
+    using j assms by simp
+  ultimately show "\<beta> u ?i = (k < (if x ! ii then 3 else 2))"
+    using beta_def by simp
+qed
+
+lemma beta_7:
+  assumes "ii < p n" and "length u = p n"
+  shows "blocky (\<beta> u) (\<gamma> (2 * n + 4 + 2 * ii)) (if u ! ii then 3 else 2)"
+proof (intro blocky_gammaI)
+  fix k :: nat
+  assume k: "k < H"
+  let ?i = "(2*n+4+2*ii) * H + k"
+  let ?j = "?i div H"
+  let ?k = "?i mod H"
+  have "?i < N"
+  proof -
+    have 1: "ii \<le> p n - 1"
+      using assms(1) by simp
+    have 2: "p n > 0"
+      using assms(1) by simp
+    have "?i \<le> (2*n+4+2*(p n - 1)) * H + k"
+      using 1 by simp
+    also have "... = (2*n+4+2*p n-2) * H + k"
+      using 2 diff_mult_distrib2 by auto
+    also have "... = (2*n+2+2*p n) * H + k"
+      by simp
+    also have "... < (2*n+2+2*p n) * H + H"
+      using k by simp
+    also have "... = (2*n+3+2*p n) * H"
+      by algebra
+    also have "... = H * (2*n + 2*p n + 3)"
+      by simp
+    also have "... \<le> H * (2*n + 2*p n + 3 + T')"
+      by simp
+    finally have "?i < H * (2*n + 2*p n + 3 + T')" .
+    then show ?thesis
+      using N_eq by simp
+  qed
+  moreover have j: "?j = 2 * n + 4 + 2 * ii"
+    using k by (metis add_cancel_left_right div_less div_mult_self3 less_nat_zero_code)
+  moreover have "?k = k"
+    using k by (metis mod_if mod_mult_self3)
+  moreover have "\<not> ?j = 0"
+    using j by linarith
+  moreover have "\<not> (?j = 2*n+1 \<or> ?j = 2*n+2)"
+    using j assms by simp
+  moreover have "\<not> odd ?j"
+    using j by simp
+  moreover have "\<not> ?j \<le> 2 * n"
+    using j assms by simp
+  moreover have "?j \<le> 2 * n + 2 * p n + 2"
+    using j assms by simp
+  ultimately show "\<beta> u ?i = (k < (if u ! ii then 3 else 2))"
+    using beta_def by simp
+qed
+
+lemma beta_zeta0:
+  assumes "t \<le> T'"
+  shows "blocky (\<beta> u) (\<zeta>\<^sub>0 t) (z0 u t)"
+proof (intro blocky_zeta0I)
+  fix k ::nat
+  assume k: "k < H"
+  let ?i = "N + t * Z + k"
+  let ?t = "(?i - N) div Z"
+  let ?k = "(?i - N) mod Z"
+  have "\<not> ?i < N"
+    by simp
+  moreover have "?i < N + Z * (Suc T')"
+  proof -
+    have "?i \<le> N + T' * Z + k"
+      using assms by simp
+    also have "... < N + T' * Z + H"
+      using k by simp
+    also have "... \<le> N + T' * Z + Z"
+      using Z_def by simp
+    also have "... = N + Z * (Suc T')"
+      by simp
+    finally show ?thesis
+      by simp
+  qed
+  moreover have kk: "?k = k"
+    using k Z_def by simp
+  moreover have "?t = t"
+    using k Z_def by simp
+  moreover have "?k < H"
+    using kk k by simp
+  ultimately show "\<beta> u ?i = (k < z0 u t)"
+    using beta_def by simp
+qed
+
+lemma beta_zeta1:
+  assumes "t \<le> T'"
+  shows "blocky (\<beta> u) (\<zeta>\<^sub>1 t) (z1 u t)"
+proof (intro blocky_zeta1I)
+  fix k :: nat
+  assume k: "k < H"
+  let ?i = "N + t * Z + H + k"
+  let ?t = "(?i - N) div Z"
+  let ?k = "(?i - N) mod Z"
+  have "\<not> ?i < N"
+    by simp
+  moreover have "?i < N + Z * (Suc T')"
+  proof -
+    have "?i \<le> N + T' * Z + H + k"
+      using assms by simp
+    also have "... < N + T' * Z + H + H"
+      using k by simp
+    also have "... \<le> N + T' * Z + Z"
+      using Z_def by simp
+    also have "... = N + Z * (Suc T')"
+      by simp
+    finally show ?thesis
+      by simp
+  qed
+  moreover have "?t = t"
+    using k Z_def by simp
+  moreover have kk: "?k = H + k"
+    using k Z_def by simp
+  moreover have "\<not> ?k < H"
+    using kk by simp
+  moreover have "?k < 2 * H"
+    using kk k by simp
+  ultimately have "\<beta> u ?i = (?k - H < z1 u t)"
+    using beta_def by simp
+  then show "\<beta> u ?i = (k < z1 u t)"
+    using kk by simp
+qed
+
+lemma beta_zeta2:
+  assumes "t \<le> T'"
+  shows "blocky (\<beta> u) (\<zeta>\<^sub>2 t) (z2 u t)"
+proof (intro blocky_zeta2I)
+  fix k :: nat
+  assume k: "k < H"
+  let ?i = "N + t * Z + 2 * H + k"
+  let ?t = "(?i - N) div Z"
+  let ?k = "(?i - N) mod Z"
+  have 1: "2 * H + k < Z"
+    using k Z_def by simp
+  have "\<not> ?i < N"
+    by simp
+  moreover have "?i < N + Z * (Suc T')"
+  proof -
+    have "?i \<le> N + T' * Z + 2 * H + k"
+      using assms by simp
+    also have "... < N + T' * Z + 2 * H + H"
+      using k by simp
+    also have "... \<le> N + T' * Z + Z"
+      using Z_def by simp
+    also have "... = N + Z * (Suc T')"
+      by simp
+    finally show ?thesis
+      by simp
+  qed
+  moreover have "?t = t"
+    using 1 by simp
+  moreover have kk: "?k = 2 * H + k"
+    using k Z_def by simp
+  moreover have "\<not> ?k < H"
+    using kk by simp
+  moreover have "\<not> ?k < 2 * H"
+    using kk by simp
+  ultimately have "\<beta> u ?i = (?k - 2 * H < z2 u t)"
+    using beta_def by simp
+  then show "\<beta> u ?i = (k < z2 u t)"
+    using kk by simp
+qed
+
+text \<open>
+We can finally show that $\beta(u)$ satisfies $\Phi$ if $u$ is a certificate for
+$x$.
+\<close>
+
+lemma satisfies_beta_PHI:
+  assumes "length u = p n" and "exc \<langle>x; u\<rangle> T' <.> 1 = \<one>"
+  shows "\<beta> u \<Turnstile> \<Phi>"
+proof -
+  have "\<beta> u \<Turnstile> \<Phi>\<^sub>0"
+  proof -
+    have "blocky (\<beta> u) (\<zeta>\<^sub>0 0) (z0 u 0)"
+      using beta_zeta0 by simp
+    then have "blocky (\<beta> u) (\<zeta>\<^sub>0 0) 1"
+      using z0_def start_config2 start_config_pos by auto
+    then have "\<beta> u \<Turnstile> \<Psi> (\<zeta>\<^sub>0 0) 1"
+      using satisfies_Psi H_gr_2 by simp
+    moreover have "\<beta> u \<Turnstile> \<Psi> (\<zeta>\<^sub>1 0) 1"
+    proof -
+      have "blocky (\<beta> u) (\<zeta>\<^sub>1 0) (z1 u 0)"
+        using beta_zeta1 by simp
+      then have "blocky (\<beta> u) (\<zeta>\<^sub>1 0) 1"
+        using z1_def start_config2 start_config_pos by simp
+      then show ?thesis
+        using satisfies_Psi H_gr_2 by simp
+    qed
+    moreover have "\<beta> u \<Turnstile> \<Psi> (\<zeta>\<^sub>2 0) 0"
+    proof -
+      have "blocky (\<beta> u) (\<zeta>\<^sub>2 0) (z2 u 0)"
+        using beta_zeta2 by simp
+      then have "blocky (\<beta> u) (\<zeta>\<^sub>2 0) 0"
+        using z2_def start_config_def by simp
+      then show ?thesis
+        using satisfies_Psi H_gr_2 by simp
+    qed
+    ultimately show ?thesis
+      using PHI0_def satisfies_def by auto
+  qed
+  moreover have "\<beta> u \<Turnstile> \<Phi>\<^sub>1"
+    using PHI1_def H_gr_2 satisfies_Psi beta_1 by simp
+  moreover have "\<beta> u \<Turnstile> \<Phi>\<^sub>2"
+  proof -
+    have "\<beta> u \<Turnstile> \<Psi> (\<gamma> (2*n+1)) 3"
+      using satisfies_Psi H_gr_2 beta_2a by simp
+    moreover have "\<beta> u \<Turnstile> \<Psi> (\<gamma> (2*n+2)) 3"
+      using satisfies_Psi H_gr_2 beta_2b by simp
+    ultimately show ?thesis
+      using PHI2_def satisfies_def by auto
+  qed
+  moreover have "\<beta> u \<Turnstile> \<Phi>\<^sub>3"
+  proof -
+    have "\<beta> u \<Turnstile> \<Psi> (\<gamma> (2*i+1)) 2" if "i < n" for i
+      using satisfies_Psi that H_gr_2 length_gamma less_imp_le_nat beta_3 by simp
+    then show ?thesis
+      using PHI3_def satisfies_concat_map' by simp
+  qed
+  moreover have "\<beta> u \<Turnstile> \<Phi>\<^sub>4"
+  proof -
+    have "\<beta> u \<Turnstile> \<Psi> (\<gamma> (2*n+2+2*i+1)) 2" if "i < p n" for i
+      using satisfies_Psi that H_gr_2 length_gamma less_imp_le_nat beta_4 assms(1) by simp
+    then show ?thesis
+      using PHI4_def satisfies_concat_map' by simp
+  qed
+  moreover have "\<beta> u \<Turnstile> \<Phi>\<^sub>5"
+  proof -
+    have "\<beta> u \<Turnstile> \<Psi> (\<gamma> (2*n+2*p n+3+i)) 0" if "i < T'" for i
+      using satisfies_Psi that H_gr_2 length_gamma less_imp_le_nat beta_5 assms(1) by simp
+    then show ?thesis
+      using PHI5_def satisfies_concat_map' by simp
+  qed
+  moreover have "\<beta> u \<Turnstile> \<Phi>\<^sub>6"
+  proof -
+    have "\<beta> u \<Turnstile> \<Psi> (\<gamma> (2*i+2)) (if x ! i then 3 else 2)" if "i < n" for i
+      using satisfies_Psi that H_gr_2 length_gamma less_imp_le_nat beta_6 by simp
+    then show ?thesis
+      using PHI6_def satisfies_concat_map' by simp
+  qed
+  moreover have "\<beta> u \<Turnstile> \<Phi>\<^sub>7"
+  proof -
+    have "\<beta> u \<Turnstile> \<Upsilon> (\<gamma> (2*n+4+2*i))" if "i < p n" for i
+    proof -
+      have "blocky (\<beta> u) (\<gamma> (2*n+4+2*i)) 2 \<or> blocky (\<beta> u) (\<gamma> (2*n+4+2*i)) 3"
+        using assms that beta_7[of i u] by (metis (full_types))
+      then have "\<beta> u \<Turnstile> \<Psi> (\<gamma> (2*n+4+2*i)) 2 \<or> \<beta> u \<Turnstile> \<Psi> (\<gamma> (2*n+4+2*i)) 3"
+        using satisfies_Psi H_gr_2 by auto
+      then show ?thesis
+        using Psi_2_imp_Upsilon Psi_3_imp_Upsilon H_gr_2 length_gamma by auto
+    qed
+    then show ?thesis
+      using PHI7_def satisfies_concat_map' by simp
+  qed
+  moreover have "\<beta> u \<Turnstile> \<Phi>\<^sub>8"
+    using PHI8_def H_gr_2 assms satisfies_Psi z1_def beta_zeta1
+    by (metis One_nat_def Suc_1 Suc_leI length_zeta1 nat_le_linear numeral_3_eq_3)
+  moreover have "\<beta> u \<Turnstile> \<Phi>\<^sub>9"
+  proof -
+    have *: "unary (\<beta> u) (\<gamma> i) = ysymbols u ! i" if "i < length (ysymbols u)" for i
+    proof -
+      have "i < m'"
+        using assms length_ysymbols that by simp
+      then consider
+          "i = 0"
+        | "1 \<le> i \<and> i < 2*n + 1"
+        | "2*n+1 \<le> i \<and> i < 2*n+3"
+        | "2*n+3 \<le> i \<and> i < m+1"
+        | "i \<ge> m + 1 \<and> i < m + 1 + T'"
+        using m'_def m_def by linarith
+      then show ?thesis
+      proof (cases)
+        case 1
+        then show ?thesis
+          using ysymbols_at_0 blocky_imp_unary H_gr_2 beta_1 by simp
+      next
+        case 2
+        moreover define j where "j = (i - 1) div 2"
+        ultimately have j: "j < n" "i = 2 * j + 1 \<or> i = 2 * j + 2"
+          by auto
+        show ?thesis
+        proof (cases "i = 2 * j + 1")
+          case True
+          then show ?thesis
+            using ysymbols_first_at(1) blocky_imp_unary H_gr_2 j(1) beta_3 by simp
+        next
+          case False
+          then have "i = 2 * j + 2"
+            using j(2) by simp
+          then show ?thesis
+            using ysymbols_first_at(2) blocky_imp_unary H_gr_2 j(1) beta_4 beta_6 by simp
+        qed
+      next
+        case 3
+        show ?thesis
+        proof (cases "i = 2*n+1")
+          case True
+          then show ?thesis
+            using ysymbols_at_2n1 blocky_imp_unary H_gr_2 beta_2a by simp
+        next
+          case False
+          then have "i = 2*n+2"
+            using 3 by simp
+          then show ?thesis
+            using ysymbols_at_2n2 blocky_imp_unary H_gr_2 beta_2b by simp
+        qed
+      next
+        case 4
+        moreover define j where "j = (i - 2*n-3) div 2"
+        ultimately have j: "j < p n" "i = 2*n+2+2 * j + 1 \<or> i = 2*n+2+2 * j + 2"
+          using j_def m_def by auto
+        show ?thesis
+        proof (cases "i = 2*n+2+2 * j + 1")
+          case True
+          then show ?thesis
+            using ysymbols_second_at(1) assms(1) blocky_imp_unary H_gr_2 j(1) beta_4 by simp
+        next
+          case False
+          then have i: "i = 2*n+4+2 * j"
+            using j(2) by simp
+          then have "ysymbols u ! (2*n+2+2*j+2) = (if u ! j then 3 else 2)"
+            using ysymbols_second_at(2) assms j(1) by simp
+          then have "ysymbols u ! (2*n+4+2*j) = (if u ! j then 3 else 2)"
+            by (metis False i j(2))
+          then have "ysymbols u ! i = (if u ! j then 3 else 2)"
+            using i by simp
+          then show ?thesis
+            using beta_7[OF j(1)] blocky_imp_unary H_gr_2 length_gamma i assms(1) by simp
+        qed
+      next
+        case 5
+        then obtain ii where ii: "ii < T'" "i = m + 1 + ii"
+          by (metis le_iff_add nat_add_left_cancel_less)
+        have "blocky (\<beta> u) (\<gamma> (2*n+2*p n + 3 + ii)) 0"
+          using beta_5[OF ii(1)] by simp
+        then have "blocky (\<beta> u) (\<gamma> i) 0"
+          using ii(2) m_def numeral_3_eq_3 by simp
+        then have "unary (\<beta> u) (\<gamma> i) = 0"
+          using blocky_imp_unary by simp
+        moreover have "ysymbols u ! i = 0"
+          using ysymbols_last[OF assms(1)] 5 by simp
+        ultimately show ?thesis
+          by simp
+      qed
+    qed
+    have "\<beta> u \<Turnstile> \<chi> (Suc t)" (is "\<beta> u \<Turnstile> \<chi> ?t")
+      if "t < T'" for t
+    proof (cases "prev m ?t < ?t")
+      case True
+      have t: "?t \<le> T'"
+        using that by simp
+      then have "unary (\<beta> u) (\<zeta>\<^sub>0 ?t) = z0 u ?t"
+        using blocky_imp_unary z0_le beta_zeta0 by simp
+      moreover have "ysymbols u ! (inputpos m ?t) = unary (\<beta> u) (\<gamma> (inputpos m ?t))"
+        using * assms(1) inputpos_less' length_ysymbols by simp
+      ultimately have "unary (\<beta> u) (\<zeta>\<^sub>0 ?t) = unary (\<beta> u) (\<gamma> (inputpos m ?t))"
+        using assms(1) z0 by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>1 ?t) = z1 u ?t"
+        using beta_zeta1 blocky_imp_unary z1_le t by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>2 ?t) = z2 u ?t"
+        using beta_zeta2 blocky_imp_unary z2_le t by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>0 (prev m ?t)) = z0 u (prev m ?t)"
+        using beta_zeta0 blocky_imp_unary z0_le t True by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>1 (prev m ?t)) = z1 u (prev m ?t)"
+        using beta_zeta1 blocky_imp_unary z1_le t True by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>2 (prev m ?t)) = z2 u (prev m ?t)"
+        using beta_zeta2 blocky_imp_unary z2_le t True by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>0 (?t - 1)) = z0 u (?t - 1)"
+        using beta_zeta0 blocky_imp_unary z0_le t True by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>1 (?t - 1)) = z1 u (?t - 1)"
+        using beta_zeta1 blocky_imp_unary z1_le t True by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>2 (?t - 1)) = z2 u (?t - 1)"
+        using beta_zeta2 blocky_imp_unary z2_le t True by simp
+      ultimately show ?thesis
+        using True assms(1) satisfies_chi_less[OF True] t z1 z2'
+        by (metis bot_nat_0.extremum less_nat_zero_code nat_less_le)
+    next
+      case False
+      then have prev: "prev m ?t = ?t"
+        using prev_le by (meson le_neq_implies_less)
+      have t: "?t \<le> T'"
+        using that by simp
+      then have "unary (\<beta> u) (\<zeta>\<^sub>0 ?t) = z0 u ?t"
+        using beta_zeta0 blocky_imp_unary z0_le by simp
+      moreover have "ysymbols u ! (inputpos m ?t) = unary (\<beta> u) (\<gamma> (inputpos m ?t))"
+        using * assms(1) inputpos_less' length_ysymbols by simp
+      ultimately have "unary (\<beta> u) (\<zeta>\<^sub>0 ?t) = unary (\<beta> u) (\<gamma> (inputpos m ?t))"
+        using assms(1) z0 by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>1 ?t) = z1 u ?t"
+        using beta_zeta1 blocky_imp_unary z1_le t by simp
+      moreover have "z1 u ?t = \<box>"
+        using z1' beta_zeta1 assms(1) prev t by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>2 ?t) = z2 u ?t"
+        using beta_zeta2 blocky_imp_unary z2_le t by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>0 (?t - 1)) = z0 u (?t - 1)"
+        using beta_zeta0 blocky_imp_unary z0_le t by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>1 (?t - 1)) = z1 u (?t - 1)"
+        using beta_zeta1 blocky_imp_unary z1_le t by simp
+      moreover have "unary (\<beta> u) (\<zeta>\<^sub>2 (?t - 1)) = z2 u (?t - 1)"
+        using beta_zeta2 blocky_imp_unary z2_le t by simp
+      ultimately show ?thesis
+        using satisfies_chi_eq[OF prev] start_config2 start_config_pos t that z1_def z2 assms(1)
+        by (metis (no_types, lifting) One_nat_def Suc_1 Suc_less_eq add_diff_inverse_nat
+          execute.simps(1) less_one n_not_Suc_n plus_1_eq_Suc)
+    qed
+    then show ?thesis
+      using PHI9_def satisfies_concat_map' by presburger
+  qed
+  ultimately show ?thesis
+    using satisfies_append' PHI_def by simp
+qed
+
+corollary ex_u_imp_sat_PHI:
+  assumes "length u = p n" and "exc \<langle>x; u\<rangle> T' <.> 1 = \<one>"
+  shows "satisfiable \<Phi>"
+  using satisfies_beta_PHI assms satisfiable_def by auto
+
+text \<open>
+The formula $\Phi$ has the desired property:
+\<close>
+
+theorem L_iff_satisfiable: "x \<in> L \<longleftrightarrow> satisfiable \<Phi>"
+  using L_iff_ex_u ex_u_imp_sat_PHI sat_PHI_imp_ex_u by auto
+
+end  (* locale reduction_sat_x *)
+
+end
diff --git a/thys/Cook_Levin/Reduction_TM.thy b/thys/Cook_Levin/Reduction_TM.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Reduction_TM.thy
@@ -0,0 +1,5300 @@
+chapter \<open>Turing machines for reducing $\NP$ languages to \SAT{}\label{s:Red_TM}\<close>
+
+theory Reduction_TM
+  imports Sat_TM_CNF Oblivious_2_Tape
+begin
+
+text \<open>
+At long last we are going to create a polynomial-time Turing machine that, for a
+fixed language $L\in\NP$, computes for every string $x$ a CNF formula $\Phi$
+such that $x\in L$ iff.\ $\Phi$ is satisfiable. This concludes the proof of the
+Cook-Levin theorem.
+
+The CNF formula $\Phi$ is a conjunction of formulas $\Phi_0, \dots, \Phi_9$, and
+the previous chapter has provided us with Turing machines @{const tm_PHI0},
+@{const tm_PHI1}, etc.\ that are supposed to generate these formulas. But only
+for $\Phi_9$ has this been proven yet. So our first task is to transfer the
+Turing machines @{const tm_PHI0}, $\dots$, @{const tm_PHI8} into the locale
+@{locale reduction_sat_x} and show that they really do generate the CNF formulas
+$\Phi_0, \dots, \Phi_8$.
+
+The TMs require certain values on their tapes prior to starting. Therefore we
+build a Turing machine that computes these values. Then, in a final effort, we
+combine all these TMs to create this article's biggest Turing machine.
+\<close>
+
+
+section \<open>Turing machines for parts of $\Phi$ revisited\<close>
+
+text \<open>
+In this section we restate the semantic lemmas @{text "transforms_tm_PHI0"}
+etc.\ of the Turing machines @{const tm_PHI0} etc.\ in the context of the locale
+@{locale reduction_sat_x}. This means that the lemmas now have terms like @{term
+"formula_n \<Phi>\<^sub>0"} in them instead of more complicated expressions. It also means
+that we more clearly see which values the tapes need to contain initially
+because they are now expressed in terms of values in the locale, such as $n$,
+$p(n)$, or $m'$.
+
+\null
+\<close>
+
+context reduction_sat_x
+begin
+
+lemma tm_PHI0 [transforms_intros]:
+  fixes tps tps' :: "tape list" and j :: tapeidx and ttt k :: nat
+  assumes "length tps = k" and "1 < j" and "j + 8 < k"
+  assumes
+    "tps ! 1 = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! j = (\<lfloor>m'\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 8) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "tps' = tps
+    [j := (\<lfloor>Suc (Suc m')\<rfloor>\<^sub>N, 1),
+     j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>nll_Psi (Suc (Suc m') * H) H 0\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+     1 := nlltape (formula_n \<Phi>\<^sub>0)]"
+  assumes "ttt = 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2"
+  shows "transforms (tm_PHI0 j) tps ttt tps'"
+proof -
+  have "nll_Psi (m' * H) H 1 = formula_n (\<Psi> (\<zeta>\<^sub>0 0) 1)"
+    using nll_Psi zeta0_def m' by simp
+  moreover have "nll_Psi (H + m' * H) H 1 = formula_n (\<Psi> (\<zeta>\<^sub>1 0) 1)"
+    using nll_Psi zeta1_def m'
+    by (smt (verit) ab_semigroup_add_class.add_ac(1) add.commute add_cancel_left_right mult_2 mult_zero_left)
+  moreover have "nll_Psi (Suc (Suc m') * H) H 0 = formula_n (\<Psi> (\<zeta>\<^sub>2 0) 0)"
+  proof -
+    have "Suc (Suc m') * H = N + 2 * H"
+      using m' by simp
+    moreover have "Suc (Suc m') * H + H = N + (Suc 0) * Z"
+      using m' Z_def by simp
+    ultimately have "\<zeta>\<^sub>2 0 = [Suc (Suc m') * H..<Suc (Suc m') * H + H]"
+      using zeta2_def by (metis Nat.add_0_right mult_zero_left)
+    then show ?thesis
+      using nll_Psi by simp
+  qed
+  ultimately have "nll_Psi (m' * H) H 1 @ nll_Psi (H + m' * H) H 1 @ nll_Psi (Suc (Suc m') * H) H 0 =
+      formula_n \<Phi>\<^sub>0"
+    using formula_n_def PHI0_def by simp
+  then show ?thesis
+    using transforms_tm_PHI0I[OF assms(1-3) H_ge_3 assms(4-13)] assms(14,15) by simp
+qed
+
+lemma tm_PHI1 [transforms_intros]:
+  fixes tps tps' :: "tape list" and j :: tapeidx and ttt k :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 7 < k"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "tps' = tps
+    [j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>nll_Psi 0 H 1\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+     1 := nlltape (nss @ formula_n \<Phi>\<^sub>1)]"
+  assumes "ttt = 1875 * H ^ 4"
+  shows "transforms (tm_PHI1 j) tps ttt tps'"
+proof -
+  have "nll_Psi 0 H 1 = formula_n (\<Psi> ([0..<H]) 1)"
+    using nll_Psi by simp
+  then have "nll_Psi 0 H 1 = formula_n (\<Psi> (\<gamma> 0) 1)"
+    using gamma_def by simp
+  then have "nll_Psi 0 H 1 = formula_n \<Phi>\<^sub>1"
+    using PHI1_def by simp
+  then show ?thesis
+    using transforms_tm_PHI1I[OF assms(1-3) H_ge_3 assms(4-12)] assms(13,14) by simp
+qed
+
+lemma tm_PHI2 [transforms_intros]:
+  fixes tps tps' :: "tape list" and j :: tapeidx and ttt k :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 8 < k"
+  assumes "idx = n "
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 8) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * idx * H))\<^sup>2"
+  assumes "tps' = tps
+    [j := (\<lfloor>2 * idx + 2\<rfloor>\<^sub>N, 1),
+     j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>nll_Psi (Suc (Suc (2 * idx)) * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+     1 := nlltape (nss @ formula_n \<Phi>\<^sub>2)]"
+  shows "transforms (tm_PHI2 j) tps ttt tps'"
+proof -
+  have "nll_Psi (H + 2 * idx * H) H 3 @ nll_Psi (2 * H + 2 * idx * H) H 3 = formula_n \<Phi>\<^sub>2"
+  proof -
+    have "\<gamma> (2 * n + 1) = [H + 2 * idx * H..<H + 2 * idx * H + H]"
+      using assms(4) gamma_def by simp
+    moreover have "\<gamma> (2 * n + 2) = [2 * H + 2 * idx * H..<2 * H + 2 * idx * H + H]"
+      using assms(4) gamma_def by simp
+    ultimately show "nll_Psi (H + 2 * idx * H) H 3 @ nll_Psi (2 * H + 2 * idx * H) H 3 = formula_n \<Phi>\<^sub>2"
+      using nll_Psi PHI2_def formula_n_def by simp
+  qed
+  then show ?thesis
+    using transforms_tm_PHI2I[OF assms(1-3) H_ge_3 assms(5-14)] assms(15,16) by simp
+qed
+
+lemma PHI3_correct: "concat (map (\<lambda>i. nll_Psi (H * (1 + 2 * i)) H 2) [0..<n]) = formula_n \<Phi>\<^sub>3"
+proof -
+  have "nll_Psi (H * (1 + 2 * i)) H 2 = formula_n (\<Psi> (\<gamma> (2*i+1)) 2)" for i
+  proof -
+    have "\<gamma> (2 * i + 1) = [H * (1 + 2 * i)..<H * (1 + 2 * i) + H]"
+      using gamma_def by (simp add: mult.commute)
+    then show ?thesis
+      using nll_Psi by simp
+  qed
+  then have "concat (map (\<lambda>i. nll_Psi (H * (1 + 2 * i)) H 2) [0..<n]) =
+      concat (map (\<lambda>i. formula_n (\<Psi> (\<gamma> (2*i+1)) 2)) [0..<n])"
+    by simp
+  also have "... = formula_n (concat (map (\<lambda>i. \<Psi> (\<gamma> (2*i+1)) 2) [0..<n]))"
+    using concat_formula_n by simp
+  also have "... = formula_n \<Phi>\<^sub>3"
+    using PHI3_def by simp
+  finally show ?thesis .
+qed
+
+lemma tm_PHI3:
+  fixes tps tps' :: "tape list" and j :: tapeidx and ttt k :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 8 < k"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>1\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>2\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 8) = (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2))"
+  assumes "tps' = tps
+    [j := (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ formula_n \<Phi>\<^sub>3),
+     j + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_PHI345 2 j) tps ttt tps'"
+  using transforms_tm_PHI345I[OF assms(1,2,3) H_ge_3, of 2 2 nss 1 "n "] H_gr_2 assms PHI3_correct
+  by fastforce
+
+lemma PHI4_correct:
+  assumes "idx = 2 * n + 2 + 1" and "kappa = 2" and "step = 2" and "numiter = p n"
+  shows "concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<numiter]) = formula_n \<Phi>\<^sub>4"
+proof -
+  have "nll_Psi (H * (idx + step * i)) H kappa = formula_n (\<Psi> (\<gamma> (2 * n + 2 + 2 * i + 1)) 2)" for i
+  proof -
+    have "\<gamma> (2 * n + 2 + 2 * i + 1) = [H * (idx + step * i)..<H * (idx + step * i) + H]"
+      using assms gamma_def by (simp add: add.commute mult.commute)
+    then show ?thesis
+      using nll_Psi assms by simp
+  qed
+  then have "concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<numiter]) =
+      concat (map (\<lambda>i. formula_n (\<Psi> (\<gamma> (2 * n + 2 + 2 * i + 1)) 2)) [0..<numiter])"
+    by simp
+  also have "... = formula_n (concat (map (\<lambda>i. \<Psi> (\<gamma> (2 * n + 2 + 2 * i + 1)) 2) [0..<p n]))"
+    using assms concat_formula_n by simp
+  also have "... = formula_n \<Phi>\<^sub>4"
+    using PHI4_def by simp
+  finally show ?thesis .
+qed
+
+lemma tm_PHI4:
+  fixes tps tps' :: "tape list" and j :: tapeidx and ttt step k :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 8 < k" assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>2 * n + 2 + 1\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>2\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 8) = (\<lfloor>2 * n + 2 + 1 + 2 * p n\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (2 * n + 2 + 1 + 2 * p n))\<^sup>2))"
+  assumes "tps' = tps
+    [j := (\<lfloor>2 * n + 2 + 1 + 2 * p n\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ formula_n \<Phi>\<^sub>4),
+     j + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_PHI345 2 j) tps ttt tps'"
+  using transforms_tm_PHI345I[OF assms(1,2,3) H_ge_3, of 2 2 nss "2 * n + 2 + 1" "p n"] H_gr_2 assms PHI4_correct
+  by fastforce
+
+lemma PHI5_correct:
+  assumes "idx = 2 * n + 2 * p n + 3" and "kappa = 0" and "step = 1" and "numiter = T' "
+  shows "concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<numiter]) = formula_n \<Phi>\<^sub>5"
+proof -
+  have "nll_Psi (H * (idx + step * i)) H kappa = formula_n (\<Psi> (\<gamma> (2 * n + 2 * p n + 3 + i)) 0)" for i
+  proof -
+    have "\<gamma> (2 * n + 2 * p n + 3 + i) = [H * (idx + step * i)..<H * (idx + step * i) + H]"
+      using assms gamma_def by (simp add: add.commute mult.commute)
+    then show ?thesis
+      using nll_Psi assms by simp
+  qed
+  then have "concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<numiter]) =
+      concat (map (\<lambda>i. formula_n (\<Psi> (\<gamma> (2 * n + 2 * p n + 3 + i)) 0)) [0..<numiter])"
+    by simp
+  also have "... = formula_n (concat (map (\<lambda>i. \<Psi> (\<gamma> (2 * n + 2 * p n + 3 + i)) 0) [0..<T']))"
+    using assms concat_formula_n by simp
+  also have "... = formula_n \<Phi>\<^sub>5"
+    using PHI5_def by simp
+  finally show ?thesis .
+qed
+
+lemma tm_PHI5:
+  fixes tps tps' :: "tape list" and j :: tapeidx and ttt k :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 8 < k"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>2 * n + 2 * p n + 3\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 8) = (\<lfloor>2 * n + 2 * p n + 3 + T'\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = Suc T' * (9 + 1891 * (H ^ 4 * (nlength (2 * n + 2 * p n + 3 + T'))\<^sup>2))"
+  assumes "tps' = tps
+    [j := (\<lfloor>2 * n + 2 * p n + 3 + T'\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ formula_n \<Phi>\<^sub>5),
+     j + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_PHI345 1 j) tps ttt tps'"
+  using transforms_tm_PHI345I[OF assms(1,2,3) H_ge_3, of 0 1, OF _ _ assms(4-12)] H_gr_2 assms(13-) PHI5_correct
+  by fastforce
+
+lemma PHI6_correct:
+  "concat (map (\<lambda>i. nll_Psi (H * (2 + 2 * i)) H (xs ! i)) [0..<length xs]) = formula_n \<Phi>\<^sub>6"
+proof -
+  have "nll_Psi (H * (2 + 2 * i)) H (xs ! i) = formula_n (\<Psi> (\<gamma> (2 * i + 2)) (if x ! i then 3 else 2))"
+    if "i < length xs" for i
+  proof -
+    have "\<gamma> (2 * i + 2) = [H * (2 + 2 * i)..<H * (2 + 2* i) + H]"
+      using gamma_def by (simp add: mult.commute)
+    then have "nll_Psi (H * (2 + 2 * i)) H (xs ! i) = formula_n (\<Psi> (\<gamma> (2 * i + 2)) (xs ! i))"
+      using nll_Psi by simp
+    moreover have "xs ! i = (if x ! i then 3 else 2)"
+      using that by simp
+    ultimately show ?thesis
+      by simp
+  qed
+  then have "map (\<lambda>i. nll_Psi (H * (2 + 2 * i)) H (xs ! i)) [0..<length xs] =
+      map (\<lambda>i. formula_n (\<Psi> (\<gamma> (2 * i + 2)) (if x ! i then 3 else 2))) [0..<length xs]"
+    by simp
+  then have "concat (map (\<lambda>i. nll_Psi (H * (2 + 2 * i)) H (xs ! i)) [0..<length xs]) =
+      concat (map (\<lambda>i. formula_n (\<Psi> (\<gamma> (2 * i + 2)) (if x ! i then 3 else 2))) [0..<length xs])"
+    by metis
+  also have "... = formula_n (concat (map (\<lambda>i. \<Psi> (\<gamma> (2 * i + 2)) (if x ! i then 3 else 2)) [0..<length xs]))"
+    using concat_formula_n by simp
+  also have "... = formula_n (concat (map (\<lambda>i. \<Psi> (\<gamma> (2 * i + 2)) (if x ! i then 3 else 2)) [0..<n]))"
+    by simp
+  also have "... = formula_n \<Phi>\<^sub>6"
+    using PHI6_def by simp
+  finally show ?thesis .
+qed
+
+lemma tm_PHI6 [transforms_intros]:
+  fixes tps tps' :: "tape list" and j :: tapeidx and ttt k :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 7 < k"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! 0 = (\<lfloor>xs\<rfloor>, 1)"
+    "tps ! j = (\<lfloor>2\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "tps' = tps
+    [0 := (\<lfloor>xs\<rfloor>, Suc n),
+     j := (\<lfloor>2 + 2 * n\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ formula_n \<Phi>\<^sub>6)]"
+  assumes "ttt = 133650 * H ^ 6 * n ^ 3 + 1"
+  shows "transforms (tm_PHI6 j) tps ttt tps'"
+  using transforms_tm_PHI6I[OF assms(1,2,3) H_ge_3 bs_xs assms(4-13) _] assms(14,15) PHI6_correct
+  by simp
+
+lemma PHI7_correct:
+  assumes "idx = 2 * n + 4" and "numiter = p n"
+  shows "concat (map (\<lambda>i. nll_Upsilon (idx + 2 * i) H) [0..<numiter]) = formula_n \<Phi>\<^sub>7"
+proof -
+  have "nll_Upsilon (idx + 2 * i) H = formula_n (\<Upsilon> (\<gamma> (2*n + 4 + 2 * i)))" for i
+  proof -
+    have "nll_Upsilon (idx + 2 * i) H = formula_n (\<Upsilon> [(idx + 2 * i)*H..<(idx + 2 * i)*H+H])"
+      using nll_Upsilon[OF H_ge_3] by simp
+    also have "... = formula_n (\<Upsilon> (\<gamma> (2 * n + 4 + 2 * i)))"
+      using gamma_def assms(1) by (simp add: add.commute)
+    finally show ?thesis .
+  qed
+  then have "concat (map (\<lambda>i. nll_Upsilon (idx + 2 * i) H) [0..<numiter]) =
+      concat (map (\<lambda>i. formula_n (\<Upsilon> (\<gamma> (2*n + 4 + 2 * i)))) [0..<numiter])"
+    by simp
+  also have "... = formula_n (concat (map (\<lambda>i. \<Upsilon> (\<gamma> (2*n + 4 + 2 * i))) [0..<numiter]))"
+    using concat_formula_n by simp
+  also have "... = formula_n (concat (map (\<lambda>i. \<Upsilon> (\<gamma> (2*n + 4 + 2 * i))) [0..<p n]))"
+    using assms(2) by simp
+  also have "... = formula_n \<Phi>\<^sub>7"
+    using PHI7_def by simp
+  finally show ?thesis .
+qed
+
+lemma tm_PHI7 [transforms_intros]:
+  fixes tps tps' :: "tape list" and j :: tapeidx and ttt numiter k idx :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 6 < k"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>2 * n + 4\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>p n\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 1"
+  assumes "tps' = tps
+    [j := (\<lfloor>2 * n + 4 + 2 * p n\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ formula_n \<Phi>\<^sub>7)]"
+  shows "transforms (tm_PHI7 j) tps ttt tps'"
+  using transforms_tm_PHI7I[OF assms(1,2,3) H_ge_3 assms(4-12)] assms(13) PHI7_correct
+  by simp
+
+lemma tm_PHI8 [transforms_intros]:
+  fixes tps tps' :: "tape list" and j :: tapeidx and ttt k idx :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 7 < k"
+  assumes "idx = 1 + 3 * T' + m' "
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>1 + 3 * T' + m'\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "tps' = tps
+      [1 := nlltape (nss @ formula_n \<Phi>\<^sub>8),
+       j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+       j + 6 := (\<lfloor>formula_n \<Phi>\<^sub>8\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+  assumes "ttt = 18 + 1861 * H ^ 4 * (nlength (Suc (1 + 3 * T' + m')))\<^sup>2"
+  shows "transforms (tm_PHI8 j) tps ttt tps'"
+proof -
+  let ?idx = "1 + 3 * T' + m' "
+  have "m' * H + T' * 3 * H + H = ?idx * H"
+    using m' add_mult_distrib by simp
+  then have "\<zeta>\<^sub>1 T' = [?idx * H..<?idx * H + H]"
+    using zeta1_def Z_def m' by (metis ab_semigroup_add_class.add_ac(1) mult.assoc mult_2)
+  then have "nll_Psi (?idx * H) H 3 = formula_n \<Phi>\<^sub>8"
+    using PHI8_def nll_Psi by simp
+  then show ?thesis
+    using transforms_tm_PHI8I[OF assms(1-3) H_ge_3 assms(5-13) _ assms(15)] assms(14) by simp
+qed
+
+end  (* context reduction_sat_x *)
+
+
+section \<open>A Turing machine for initialization\<close>
+
+text \<open>
+As we have seen in the previous section, the Turing machines @{const tm_PHI0}
+etc.\ expect some tapes to contain certain values that depend on the verifier TM
+$M$. In this section we construct the TM @{term tm_PHI_init} that computes
+theses values.
+
+The TM expects the string $x$ on the input tape. Then it determines the length
+$n$ of $x$ and stores it on tape~11. Then it computes the value $p(n)$ and
+stores it on tape~15. Then it computes $m = 2n + 2p(n) + 2$ and stores it on
+tape~16. It then writes $\mathbf{0}^m$ to tape~9 and runs @{const
+tm_list_headpos}, which writes the sequences of head positions for the input and
+work/output tape of the verifier TM $M$ to tapes~4 and~7, respectively.  The
+length of these lists determines $T'$, which is written to tape~17. From this
+and $m$ the TM computes $m'$ and writes it to tape~18. It then writes $H$, which
+is hard-coded, to tape~19 and finally $N = H\cdot m'$ to tape~20.
+
+We assume that the TM starts in a configuration where the input tape head and
+the heads on tapes with index greater than 10 are positioned on cell number~1,
+whereas all other tapes are on cell number~0 as usual.
+The TM has no tape parameters, as all tapes are fixed to work with the final TM
+later.
+
+As with other TMs before, we will define and analyze the TM on the theory level
+and then transfer the semantics to the locale @{locale reduction_sat_x}.
+\<close>
+
+definition tm_PHI_init :: "nat \<Rightarrow> machine \<Rightarrow> (nat \<Rightarrow> nat) \<Rightarrow> machine" where
+  "tm_PHI_init G M p \<equiv>
+     tm_right 9 ;;
+     tm_length_input 11 ;;
+     tm_polynomial p 11 ;;
+     tm_copyn 15 16 ;;
+     tm_add 11 16 ;;
+     tm_incr 16 ;;
+     tm_times2 16 ;;
+     tm_copyn 16 17 ;;
+     tm_write_replicate 2 17 9 ;;
+     tm_left 9 ;;
+     tm_list_headpos G M 2 ;;
+     tm_count 4 17 4 ;;
+     tm_decr 17 ;;
+     tm_copyn 16 18 ;;
+     tm_incr 18 ;;
+     tm_add 17 18 ;;
+     tm_setn 19 (max G (length M)) ;;
+     tm_mult 18 19 20"
+
+lemma tm_PHI_init_tm:
+  fixes H k
+  assumes "turing_machine 2 G M" and "k > 20" and "H \<ge> Suc (length M)" and "H \<ge> G"
+  assumes "H \<ge> 5"
+  shows "turing_machine k H (tm_PHI_init G M p)"
+  unfolding tm_PHI_init_def
+  using assms turing_machine_sequential_turing_machine tm_right_tm tm_length_input_tm tm_polynomial_tm
+    tm_copyn_tm tm_add_tm tm_incr_tm tm_times2_tm tm_write_replicate_tm tm_left_tm tm_list_headpos_tm
+    tm_count_tm tm_decr_tm tm_setn_tm tm_mult_tm
+  by simp
+
+locale turing_machine_PHI_init =
+  fixes G :: nat and M :: machine and p :: "nat \<Rightarrow> nat"
+begin
+
+definition "tm3 \<equiv> tm_right 9"
+definition "tm4 \<equiv> tm3 ;; tm_length_input 11"
+definition "tm5 \<equiv> tm4 ;; tm_polynomial p 11"
+definition "tm6 \<equiv> tm5 ;; tm_copyn 15 16"
+definition "tm7 \<equiv> tm6 ;; tm_add 11 16"
+definition "tm8 \<equiv> tm7 ;; tm_incr 16"
+definition "tm9 \<equiv> tm8 ;; tm_times2 16"
+definition "tm10 \<equiv> tm9 ;; tm_copyn 16 17"
+definition "tm11 \<equiv> tm10 ;; tm_write_replicate 2 17 9"
+definition "tm12 \<equiv> tm11 ;; tm_left 9"
+definition "tm13 \<equiv> tm12 ;; tm_list_headpos G M 2"
+definition "tm14 \<equiv> tm13 ;; tm_count 4 17 4"
+definition "tm15 \<equiv> tm14 ;; tm_decr 17"
+definition "tm16 \<equiv> tm15 ;; tm_copyn 16 18"
+definition "tm17 \<equiv> tm16 ;; tm_incr 18"
+definition "tm18 \<equiv> tm17 ;; tm_add 17 18"
+definition "tm19 \<equiv> tm18 ;; tm_setn 19 (max G (length M))"
+definition "tm20 \<equiv> tm19 ;; tm_mult 18 19 20"
+
+lemma tm20_eq_tm_PHI_init: "tm20 = tm_PHI_init G M p"
+  unfolding tm20_def tm19_def tm18_def tm17_def tm16_def tm15_def tm14_def tm13_def tm12_def tm11_def
+  unfolding tm10_def tm9_def tm8_def tm7_def tm6_def tm5_def tm4_def tm3_def tm_PHI_init_def
+  by simp
+
+context
+  fixes k H thalt :: nat and tps0 :: "tape list" and xs zs :: "symbol list"
+  assumes poly_p: "polynomial p"
+    and M_tm: "turing_machine 2 G M"
+    and k: "k = length tps0" "20 < k"
+    and H: "H = max G (length M)"
+    and xs: "bit_symbols xs"
+    and zs: "zs = 2 # 2 # replicate (2 * length xs + 2 * p (length xs)) 2"
+  assumes thalt:
+    "\<forall>t<thalt. fst (execute M (start_config 2 zs) t) < length M"
+    "fst (execute M (start_config 2 zs) thalt) = length M"
+  assumes tps0:
+    "tps0 ! 0 = (\<lfloor>xs\<rfloor>, 1)"
+    "\<And>i. 0 < i \<Longrightarrow> i \<le> 10 \<Longrightarrow> tps0 ! i = (\<lfloor>[]\<rfloor>, 0)"
+    "\<And>i. 10 < i \<Longrightarrow> i < k \<Longrightarrow> tps0 ! i = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+lemma G: "G \<ge> 4"
+  using M_tm turing_machine_def by simp
+
+lemma H: "H \<ge> length M" "H \<ge> G"
+  using H by simp_all
+
+definition "tps3 \<equiv> tps0
+  [9 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm3 [transforms_intros]: "transforms tm3 tps0 1 tps3"
+  unfolding tm3_def by (tform tps: tps3_def tps0 k)
+
+abbreviation "n \<equiv> length xs"
+
+definition "tps4 \<equiv> tps0
+  [9 := (\<lfloor>[]\<rfloor>, 1),
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 5 + 11 * (length xs)\<^sup>2"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: tps3_def tps4_def tps0 k time: assms)
+  show "proper_symbols xs"
+    using xs by auto
+  show "tps3 ! 11 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using canrepr_0 tps3_def tps0 k by simp
+qed
+
+definition "tps5 \<equiv> tps0
+  [9 := (\<lfloor>[]\<rfloor>, 1),
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 5 + 11 * (length xs)\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength (length xs))\<^sup>2)"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def by (tform tps: canrepr_0 tps4_def tps5_def tps0 k poly_p time: assms)
+
+definition "tps6 \<equiv> tps0
+  [9 := (\<lfloor>[]\<rfloor>, 1),
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>p n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm6 [transforms_intros]:
+  assumes "ttt = 19 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) + 3 * nlength (p n)"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+proof (tform tps: tps5_def tps6_def tps0 k)
+  show "tps5 ! 16 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using canrepr_0 k tps0 tps5_def by simp
+  show "ttt = 5 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+      (14 + 3 * (nlength (p n) + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps7 \<equiv> tps0
+  [9 := (\<lfloor>[]\<rfloor>, 1),
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>n + p n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm7 [transforms_intros]:
+  assumes "ttt = 29 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n))"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def by (tform tps: tps6_def tps7_def tps0 k assms)
+
+definition "tps8 \<equiv> tps0
+  [9 := (\<lfloor>[]\<rfloor>, 1),
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>Suc (n + p n)\<rfloor>\<^sub>N, 1)]"
+
+lemma tm8 [transforms_intros]:
+  assumes "ttt = 34 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n)"
+  shows "transforms tm8 tps0 ttt tps8"
+  unfolding tm8_def by (tform tps: tps7_def tps8_def tps0 k assms)
+
+definition "tps9 \<equiv> tps0
+  [9 := (\<lfloor>[]\<rfloor>, 1),
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1)]"
+
+lemma tm9 [transforms_intros]:
+  assumes "ttt = 39 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n))"
+  shows "transforms tm9 tps0 ttt tps9"
+  unfolding tm9_def by (tform tps: tps8_def tps9_def tps0 k assms)
+
+definition "tps10 \<equiv> tps0
+  [9 := (\<lfloor>[]\<rfloor>, 1),
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1)]"
+
+lemma tm10 [transforms_intros]:
+  assumes "ttt = 53 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 3 * nlength (Suc (Suc (2 * n + 2 * p n)))"
+  shows "transforms tm10 tps0 ttt tps10"
+  unfolding tm10_def
+proof (tform tps: tps9_def tps10_def tps0 k)
+  show "tps9 ! 17 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps9_def canrepr_0 tps0 k by simp
+  show "ttt = 39 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+      3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) +
+      2 * nlength (n + p n) + 2 * nlength (Suc (n + p n)) +
+      (14 + 3 * (nlength (Suc (Suc (2 * n + 2 * p n))) + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps11 \<equiv> tps0
+  [9 := (\<lfloor>zs\<rfloor>, 1),
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm11 [transforms_intros]:
+  assumes "ttt = 57 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 3 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    Suc (Suc (2 * n + 2 * p n)) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n))))"
+  shows "transforms tm11 tps0 ttt tps11"
+  unfolding tm11_def
+proof (tform tps: tps10_def tps11_def tps0 k time: assms)
+  show "tps11 = tps10
+    [17 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     9 := (\<lfloor>replicate (Suc (Suc (2 * n + 2 * p n))) 2\<rfloor>, 1)]"
+    unfolding tps11_def tps10_def using zs by (simp add: list_update_swap[of _ 9])
+qed
+
+definition "tps12 \<equiv> tps0
+  [9 := (\<lfloor>zs\<rfloor>, 0),
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm12 [transforms_intros]:
+  assumes "ttt = 82 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 7 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n))))"
+  shows "transforms tm12 tps0 ttt tps12"
+  unfolding tm12_def
+proof (tform tps: tps11_def tps12_def tps0 k time: assms)
+  have "tps11 ! 9 |-| 1 = (\<lfloor>zs\<rfloor>, 0)"
+    using tps11_def k by simp
+  then show "tps12 = tps11[9 := tps11 ! 9 |-| 1]"
+    unfolding tps12_def tps11_def by (simp add: list_update_swap[of _ 9])
+qed
+
+abbreviation exc :: "nat \<Rightarrow> config" where
+  "exc t \<equiv> execute M (start_config 2 zs) t"
+
+definition "tps13 \<equiv> tps0
+  [9 := exc thalt <!> 0,
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   3 := (\<lfloor>exc thalt <#> 0\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   6 := (\<lfloor>exc thalt <#> 1\<rfloor>\<^sub>N, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   10 := exc thalt <!> 1]"
+
+lemma tm13 [transforms_intros]:
+  assumes "ttt = 82 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 7 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+    (27 + 27 * thalt) * (9 + 2 * nlength thalt)"
+  shows "transforms tm13 tps0 ttt tps13"
+  unfolding tm13_def
+proof (tform)
+  show "turing_machine 2 G M"
+    using M_tm .
+  show "2 + 9 \<le> length tps12"
+    using tps12_def k by simp
+  show "\<forall>t<thalt. fst (execute M (start_config 2 zs) t) < length M"
+      "fst (execute M (start_config 2 zs) thalt) = length M"
+    using thalt .
+  show "symbols_lt G zs"
+  proof -
+    have "zs = replicate (2 * n + 2 * p n + 2) 2"
+      using zs by simp
+    then have "\<forall>i<length zs. zs ! i = 2"
+      using nth_replicate by (metis length_replicate)
+    then show ?thesis
+      using G by simp
+  qed
+  show "tps13 = tps12
+    [2 + 1 := (\<lfloor>snd (exc thalt) :#: 0\<rfloor>\<^sub>N, 1),
+     2 + 2 := (\<lfloor>map (\<lambda>t. snd (exc t) :#: 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+     2 + 4 := (\<lfloor>snd (exc thalt) :#: 1\<rfloor>\<^sub>N, 1),
+     2 + 5 := (\<lfloor>map (\<lambda>t. snd (exc t) :#: 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+     2 + 7 := exc thalt <!> 0, 2 + 8 := exc thalt <!> 1]"
+    unfolding tps13_def tps12_def by (simp add: list_update_swap[of _ 9])
+  show "tps12 ! 2 = \<lceil>\<triangleright>\<rceil>"
+    using tps12_def tps0 onesie_1 by simp
+  show "tps12 ! (2 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 0)"
+    using tps12_def tps0 canrepr_0 by simp
+  show "tps12 ! (2 + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 0)"
+    using tps12_def tps0 nlcontents_Nil by simp
+  show "tps12 ! (2 + 3) = \<lceil>\<triangleright>\<rceil>"
+    using tps12_def tps0 onesie_1 by simp
+  show "tps12 ! (2 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 0)"
+    using tps12_def tps0 canrepr_0 by simp
+  show "tps12 ! (2 + 5) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 0)"
+    using tps12_def tps0 nlcontents_Nil by simp
+  show "tps12 ! (2 + 6) = \<lceil>\<triangleright>\<rceil>"
+    using tps12_def tps0 onesie_1 by simp
+  show "tps12 ! (2 + 7) = (\<lfloor>zs\<rfloor>, 0)"
+    using tps12_def k tps0 by simp
+  show "tps12 ! (2 + 8) = (\<lfloor>[]\<rfloor>, 0)"
+    using tps12_def tps0 by simp
+  show "ttt = 82 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+      3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+      2 * nlength (Suc (n + p n)) + 7 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+      (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+      27 * Suc thalt * (9 + 2 * nlength thalt)"
+    using assms by simp
+qed
+
+definition "tpsA \<equiv> tps0
+  [9 := exc thalt <!> 0,
+   3 := (\<lfloor>exc thalt <#> 0\<rfloor>\<^sub>N, 1),
+   6 := (\<lfloor>exc thalt <#> 1\<rfloor>\<^sub>N, 1),
+   10 := exc thalt <!> 1]"
+
+definition "tps14 \<equiv> tps0
+  [9 := exc thalt <!> 0,
+   11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>Suc thalt\<rfloor>\<^sub>N, 1),
+   3 := (\<lfloor>exc thalt <#> 0\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   6 := (\<lfloor>exc thalt <#> 1\<rfloor>\<^sub>N, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   10 := exc thalt <!> 1]"
+
+lemma tm14:
+  assumes "ttt = 87 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 7 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+    (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+    14 * (nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]))\<^sup>2"
+  shows "transforms tm14 tps0 ttt tps14"
+  unfolding tm14_def
+proof (tform)
+  show "4 < length tps13" "17 < length tps13"
+    using tps13_def k by (simp_all only: length_list_update)
+  show "tps13 ! 4 = (\<lfloor>map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tps13_def k by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps13 ! 17 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps13_def k by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps14 = tps13
+      [17 := (\<lfloor>length (map (\<lambda>t. snd (exc t) :#: 0) [0..<Suc thalt])\<rfloor>\<^sub>N, 1)]"
+    unfolding tps14_def tps13_def by (simp add: list_update_swap[of 17])
+  show "ttt = 82 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+      3 * nlength (p n) +
+      3 * max (nlength n) (nlength (p n)) +
+      2 * nlength (n + p n) +
+      2 * nlength (Suc (n + p n)) +
+      7 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+      (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+      (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+      (14 * (nllength (map (\<lambda>t. snd (exc t) :#: 0) [0..<Suc thalt]))\<^sup>2 + 5)"
+    using assms by simp
+qed
+
+definition "tps14' \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>Suc thalt\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tps14': "tps14' = tps14"
+  unfolding tps14'_def tps14_def tpsA_def by (simp add: list_update_swap)
+
+lemma len_tpsA: "length tpsA = k"
+  using tpsA_def k by simp
+
+lemma tm14' [transforms_intros]:
+  assumes "ttt = 87 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 7 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+    (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+    14 * (nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]))\<^sup>2"
+  shows "transforms tm14 tps0 ttt tps14'"
+  using tm14 tps14' assms by simp
+
+definition "tps15 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>thalt\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm15 [transforms_intros]:
+  assumes "ttt = 95 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 7 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+    (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+    14 * (nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]))\<^sup>2 +
+    2 * nlength (Suc thalt)"
+  shows "transforms tm15 tps0 ttt tps15"
+  unfolding tm15_def
+proof (tform tps: tps14'_def len_tpsA k time: assms)
+  show "tps15 = tps14'[17 := (\<lfloor>Suc thalt - 1\<rfloor>\<^sub>N, 1)]"
+    unfolding tps15_def tps14'_def by (simp add: list_update_swap)
+qed
+
+definition "tps16 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>thalt\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1)]"
+
+lemma tm16 [transforms_intros]:
+  assumes "ttt = 109 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 10 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+    (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+    14 * (nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]))\<^sup>2 +
+    2 * nlength (Suc thalt)"
+  shows "transforms tm16 tps0 ttt tps16"
+  unfolding tm16_def
+proof (tform tps: tps15_def tps16_def k len_tpsA)
+  have "tps15 ! 18 = tpsA ! 18"
+    using tps15_def by simp
+  also have "... = tps0 ! 18"
+    using tpsA_def by simp
+  also have "... = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps0 canrepr_0 k by simp
+  finally show "tps15 ! 18 = (\<lfloor>0\<rfloor>\<^sub>N, 1)" .
+  show "ttt = 95 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+      3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) +
+      2 * nlength (n + p n) + 2 * nlength (Suc (n + p n)) +
+      7 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+      (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) + (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+      14 * (nllength
+        (map (\<lambda>t. snd (exc t) :#: 0) [0..<thalt] @ [snd (exc thalt) :#: 0]))\<^sup>2 +
+      2 * nlength (Suc thalt) + (14 + 3 * (nlength (Suc (Suc (2 * n + 2 * p n))) + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps17 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>thalt\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>Suc (2 * Suc (n + p n))\<rfloor>\<^sub>N, 1)]"
+
+lemma tm17 [transforms_intros]:
+  assumes "ttt = 114 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 10 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+    (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+    14 * (nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]))\<^sup>2 +
+    2 * nlength (Suc thalt) + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))"
+  shows "transforms tm17 tps0 ttt tps17"
+  unfolding tm17_def by (tform tps: tps16_def tps17_def k len_tpsA time: assms)
+
+definition "tps18 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>thalt\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>thalt + Suc (2 * Suc (n + p n))\<rfloor>\<^sub>N, 1)]"
+
+lemma tm18 [transforms_intros]:
+  assumes "ttt = 124 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 10 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+    (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+    14 * (nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]))\<^sup>2 +
+    2 * nlength (Suc thalt) + 2 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    3 * max (nlength thalt) (nlength (Suc (Suc (Suc (2 * n + 2 * p n)))))"
+  shows "transforms tm18 tps0 ttt tps18"
+  unfolding tm18_def by (tform tps: tps17_def tps18_def k len_tpsA time: assms)
+
+definition "tps19 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>thalt\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>thalt + Suc (2 * Suc (n + p n))\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>max G (length M)\<rfloor>\<^sub>N, 1)]"
+
+lemma tm19 [transforms_intros]:
+  assumes "ttt = 134 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 10 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+    (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+    14 * (nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]))\<^sup>2 +
+    2 * nlength (Suc thalt) + 2 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    3 * max (nlength thalt) (nlength (Suc (Suc (Suc (2 * n + 2 * p n))))) +
+    2 * nlength (max G (length M))"
+  shows "transforms tm19 tps0 ttt tps19"
+  unfolding tm19_def
+proof (tform tps: assms nlength_0)
+  have "tps18 ! 19 = tpsA ! 19"
+    using tps18_def by simp
+  also have "... = tps0 ! 19"
+    using tpsA_def by simp
+  also have "... = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps0 canrepr_0 k by simp
+  finally show "tps18 ! 19 = (\<lfloor>0\<rfloor>\<^sub>N, 1)" .
+  show "19 < length tps18"
+    using tps18_def len_tpsA k by simp
+  show "tps19 = tps18[19 := (\<lfloor>max G (length M)\<rfloor>\<^sub>N, 1)]"
+    using tps19_def tps18_def len_tpsA k by presburger
+qed
+
+definition "tps20 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>thalt\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>thalt + Suc (2 * Suc (n + p n))\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>max G (length M)\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>(thalt + Suc (2 * Suc (n + p n))) * max G (length M)\<rfloor>\<^sub>N, 1)]"
+
+lemma tm20:
+  assumes "ttt = 138 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 10 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+    (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+    14 * (nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]))\<^sup>2 +
+    2 * nlength (Suc thalt) + 2 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    3 * max (nlength thalt) (nlength (Suc (Suc (Suc (2 * n + 2 * p n))))) +
+    2 * nlength (max G (length M)) +
+    26 * (nlength (Suc (Suc (Suc (thalt + (2 * n + 2 * p n))))) + nlength (max G (length M))) *
+     (nlength (Suc (Suc (Suc (thalt + (2 * n + 2 * p n))))) + nlength (max G (length M)))"
+  shows "transforms tm20 tps0 ttt tps20"
+  unfolding tm20_def
+proof (tform time: assms)
+  have "tps19 ! 20 = tpsA ! 20"
+    using tps19_def by simp
+  also have "... = tps0 ! 20"
+    using tpsA_def by simp
+  also have "... = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps0 canrepr_0 k by simp
+  finally show "tps19 ! 20 = (\<lfloor>0\<rfloor>\<^sub>N, 1)" .
+  show "tps20 = tps19
+      [20 := (\<lfloor>Suc (Suc (Suc (thalt + (2 * n + 2 * p n)))) * max G (length M)\<rfloor>\<^sub>N, 1)]"
+    unfolding tps20_def tps19_def by (simp add: list_update_swap)
+  show "18 < length tps19" "19 < length tps19" "20 < length tps19"
+    using tps19_def k len_tpsA by (simp_all only: length_list_update)
+  have "tps19 ! 18 = (\<lfloor>thalt + Suc (2 * Suc (n + p n))\<rfloor>\<^sub>N, 1)"
+    using tps19_def tpsA_def len_tpsA k tps0 by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps19 ! 18 = (\<lfloor>Suc (Suc (Suc (thalt + (2 * n + 2 * p n))))\<rfloor>\<^sub>N, 1)"
+    by simp
+  show "tps19 ! 19 = (\<lfloor>max G (length M)\<rfloor>\<^sub>N, 1)"
+    using tps19_def tpsA_def len_tpsA k tps0 by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+qed
+
+lemma tm20' [transforms_intros]:
+  assumes "ttt = (2 * d_polynomial p + 826) * (max G (length M) + thalt + Suc (Suc (Suc (2 * n + 2 * p n)))) ^ 4"
+  shows "transforms tm20 tps0 ttt tps20"
+proof -
+  let ?ttt = "138 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) +
+    3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 10 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) +
+    (27 + 27 * thalt) * (9 + 2 * nlength thalt) +
+    14 * (nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]))\<^sup>2 +
+    2 * nlength (Suc thalt) + 2 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    3 * max (nlength thalt) (nlength (Suc (Suc (Suc (2 * n + 2 * p n))))) +
+    2 * nlength (max G (length M)) +
+    26 * (nlength (Suc (Suc (Suc (thalt + (2 * n + 2 * p n))))) + nlength (max G (length M))) *
+     (nlength (Suc (Suc (Suc (thalt + (2 * n + 2 * p n))))) + nlength (max G (length M)))"
+  let ?a = "3 * nlength (p n) + 3 * max (nlength n) (nlength (p n)) + 2 * nlength (n + p n) +
+    2 * nlength (Suc (n + p n)) + 10 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) + (27 + 27 * thalt) * (9 + 2 * nlength thalt)"
+  let ?b = "2 * nlength (Suc thalt) + 2 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+    3 * max (nlength thalt) (nlength (Suc (Suc (Suc (2 * n + 2 * p n))))) +
+    2 * nlength (max G (length M)) +
+    26 * (nlength (Suc (Suc (Suc (thalt + (2 * n + 2 * p n))))) + nlength (max G (length M))) *
+     (nlength (Suc (Suc (Suc (thalt + (2 * n + 2 * p n))))) + nlength (max G (length M)))"
+  let ?m = "max G (length M) + thalt + Suc (Suc (Suc (2 * n + 2 * p n)))"
+  define m where "m = max G (length M) + thalt + Suc (Suc (Suc (2 * n + 2 * p n)))"
+  note m_def [simp]
+  have **: "y \<le> y * m" for y
+    by simp
+  have *: "nlength y \<le> m" if "y \<le> m" for y
+    using nlength_mono[OF that] nlength_mono by (meson dual_order.trans nlength_le_n)
+  have 1: "nlength (p n) \<le> m"
+    using * by simp
+  have 2: "max (nlength n) (nlength (p n)) \<le> m"
+    using * by simp
+  have 3: "nlength (n + p n) \<le> m"
+    using * by simp
+  have 4: "nlength (Suc (n + p n)) \<le> m"
+    using * by simp
+  have 5: "nlength (Suc (Suc (2 * n + 2 * p n))) \<le> m"
+    using * by simp
+  have 6: "nlength n \<le> m"
+    using * by simp
+  have 7: "2 * n + 2 * p n \<le> m"
+    by simp
+  have 8: "thalt \<le> m" "nlength thalt \<le> m" "nlength (Suc thalt) \<le> m"
+    using * by simp_all
+  have 10: "max (nlength thalt) (nlength (Suc (Suc (Suc (2 * n + 2 * p n))))) \<le> m"
+    using * by simp
+  have 11: "nlength (Suc (Suc (Suc (thalt + (2 * n + 2 * p n))))) \<le> m"
+    using * by simp
+  have 12: "nlength (Suc (Suc (Suc (thalt + (2 * n + 2 * p n))))) + nlength (max G (length M)) \<le> m"
+    using * nlength_le_n by (smt (verit) ab_semigroup_add_class.add_ac(1) add.commute add_Suc_right add_le_mono m_def)
+  have 13: "nlength (max G (length M)) \<le> m"
+    using 12 by simp
+  have 14: "Suc (nlength thalt) \<le> m"
+  proof -
+    have "nlength thalt \<le> nlength m"
+      using nlength_mono by simp
+    moreover have "m \<ge> 3"
+      by simp
+    ultimately have "nlength thalt < m"
+      using nlength_less_n dual_order.strict_trans2 by blast
+    then show ?thesis
+      by simp
+  qed
+  have 15: "Suc thalt \<le> m"
+    by simp
+
+  have "?a \<le> 20 * m +
+      (2 * n + 2 * p n) * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) + (27 + 27 * thalt) * (9 + 2 * nlength thalt)"
+    using 1 2 3 4 5 by linarith
+  also have "... \<le> 20 * m + m * (12 + 2 * nlength (Suc (Suc (2 * n + 2 * p n)))) + (27 + 27 * thalt) * (9 + 2 * nlength thalt)"
+    using 7 by (metis add.commute add_mono_thms_linordered_semiring(2) mult_Suc_right mult_le_cancel2)
+  also have "... \<le> 20 * m + m * (12 + 2 * m) + (27 + 27 * thalt) * (9 + 2 * nlength thalt)"
+    using 5 by (meson add_left_mono add_mono_thms_linordered_semiring(3) mult_le_mono2)
+  also have "... \<le> 20 * m + m * (12 + 2 * m) + (27 + 27 * m) * (9 + 2 * m)"
+    using 8 add_le_mono le_refl mult_le_mono by presburger
+  also have "... \<le> 20 * m + m * (12 * m + 2 * m) + (27 * m + 27 * m) * (9 + 2 * m)"
+    using ** by (meson add_le_mono add_mono_thms_linordered_semiring(2) add_mono_thms_linordered_semiring(3) mult_le_mono1 mult_le_mono2)
+  also have "... \<le> 20 * m + m * (12 * m + 2 * m) + (27 * m + 27 * m) * (9 * m + 2 * m)"
+    using ** by simp
+  also have "... = 20 * m + m * 14 * m + 54 * m * 11 * m"
+    by algebra
+  also have "... = 20 * m + 14 * m ^ 2 + 594 * m ^ 2"
+    by algebra
+  also have "... = 20 * m + 608 * m ^ 2"
+    by simp
+  also have "... \<le> 20 * m ^ 2 + 608 * m ^ 2"
+    using linear_le_pow by (meson add_le_mono1 mult_le_mono2 zero_less_numeral)
+  also have "... = 628 * m ^ 2"
+    by simp
+  finally have part1: "?a \<le> 628 * m ^ 2" .
+
+  have "nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]) \<le> Suc (nlength thalt) * Suc thalt"
+  proof -
+    have "exc t <#> 0 \<le> thalt" if "t \<le> thalt" for t
+      using that M_tm head_pos_le_halting_time thalt(2) zero_less_numeral by blast
+    then have "y \<le> thalt" if "y \<in> set (map (\<lambda>t. exc t <#> 0) [0..<Suc thalt])" for y
+      using that by force
+    then have "nllength (map (\<lambda>t. exc t <#> 0) [0..<Suc thalt]) \<le> Suc (nlength thalt) * Suc thalt"
+        (is "nllength ?ns \<le> _")
+      using nllength_le_len_mult_max[of ?ns thalt] by simp
+    then show ?thesis
+      by simp
+  qed
+  then have part2: "nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]) \<le> m * m"
+    using 14 15 by (meson le_trans mult_le_mono)
+
+  have "?b = 2 * nlength (Suc thalt) + 2 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+      3 * max (nlength thalt) (nlength (Suc (Suc (Suc (2 * n + 2 * p n))))) + 2 * nlength (max G (length M)) +
+      26 * (nlength (Suc (Suc (Suc (thalt + (2 * n + 2 * p n))))) + nlength (max G (length M))) ^ 2"
+    by algebra
+  also have "... \<le> 2 * nlength (Suc thalt) + 2 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+      3 * max (nlength thalt) (nlength (Suc (Suc (Suc (2 * n + 2 * p n))))) + 2 * nlength (max G (length M)) +
+      26 * m ^ 2"
+    using 12 by simp
+  also have "... \<le> 2 * nlength (Suc thalt) + 2 * nlength (Suc (Suc (2 * n + 2 * p n))) +
+      3 * m + 2 * nlength (max G (length M)) + 26 * m ^ 2"
+    using 10 by linarith
+  also have "... \<le> 2 * m + 2 * m + 3 * m + 2 * m + 26 * m ^ 2"
+    using 13 8 5 by simp
+  also have "... = 9 * m + 26 * m ^ 2"
+    by simp
+  also have "... \<le> 9 * m ^ 2 + 26 * m ^ 2"
+    using linear_le_pow by (meson add_le_mono1 mult_le_mono2 zero_less_numeral)
+  also have "... = 35 * m ^ 2"
+    by simp
+  finally have part3: "?b \<le> 35 * m ^ 2" .
+
+  have "?ttt = 138 + 11 * n\<^sup>2 + (d_polynomial p + d_polynomial p * (nlength n)\<^sup>2) + ?a +
+      14 * (nllength (map (\<lambda>t. exc t <#> 0) [0..<thalt] @ [exc thalt <#> 0]))\<^sup>2 + ?b"
+    by simp
+  also have "... \<le> 138 + 11 * n\<^sup>2 + d_polynomial p + d_polynomial p * (nlength n)\<^sup>2 + ?a + 14 * (m * m)\<^sup>2 + ?b"
+    using part2 by simp
+  also have "... \<le> 138 + 11 * n\<^sup>2 + d_polynomial p + d_polynomial p * (nlength n)\<^sup>2 + ?a + 14 * (m * m)\<^sup>2 + 35 * m ^ 2"
+    using part3 by linarith
+  also have "... \<le> 138 + 11 * n\<^sup>2 + d_polynomial p + d_polynomial p * (nlength n)\<^sup>2 + 628 * m ^ 2 + 14 * (m * m)\<^sup>2 + 35 * m ^ 2"
+    using part1 by linarith
+  also have "... = 138 + 11 * n\<^sup>2 + d_polynomial p + d_polynomial p * (nlength n)\<^sup>2 + 663 * m ^ 2 + 14 * m ^ 4"
+    by algebra
+  also have "... \<le> 138 + 11 * m ^ 2 + d_polynomial p + d_polynomial p * (nlength n)\<^sup>2 + 663 * m ^ 2 + 14 * m ^ 4"
+    by simp
+  also have "... \<le> 138 + 11 * m ^ 2 + d_polynomial p + d_polynomial p * m ^ 2 + 663 * m ^ 2 + 14 * m ^ 4"
+    using 6 by simp
+  also have "... = 138 + d_polynomial p + d_polynomial p * m ^ 2 + 674 * m ^ 2 + 14 * m ^ 4"
+    by simp
+  also have "... \<le> 138 + d_polynomial p + d_polynomial p * m ^ 4 + 674 * m ^ 2 + 14 * m ^ 4"
+    using pow_mono'[of 2 4] by simp
+  also have "... \<le> 138 + d_polynomial p + d_polynomial p * m ^ 4 + 674 * m ^ 4 + 14 * m ^ 4"
+    using pow_mono'[of 2 4] by simp
+  also have "... = 138 + d_polynomial p + d_polynomial p * m ^ 4 + 688 * m ^ 4"
+    by simp
+  also have "... \<le> 138 * m + d_polynomial p + d_polynomial p * m ^ 4 + 688 * m ^ 4"
+    using ** by simp
+  also have "... \<le> 138 * m ^ 4 + d_polynomial p + d_polynomial p * m ^ 4 + 688 * m ^ 4"
+    using linear_le_pow[of 4 m] by simp
+  also have "... = d_polynomial p + d_polynomial p * m ^ 4 + 826 * m ^ 4"
+    by simp
+  also have "... \<le> d_polynomial p * m + d_polynomial p * m ^ 4 + 826 * m ^ 4"
+    using ** by simp
+  also have "... \<le> d_polynomial p * m ^ 4 + d_polynomial p * m ^ 4 + 826 * m ^ 4"
+    using linear_le_pow[of 4 m] by (simp del: m_def)
+  also have "... = 2 * d_polynomial p * m ^ 4 + 826 * m ^ 4"
+    by simp
+  also have "... = (2 * d_polynomial p + 826) * m ^ 4"
+    by algebra
+  finally have "?ttt \<le> (2 * d_polynomial p + 826) * m ^ 4" .
+  then have "?ttt \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using tm20 transforms_monotone by fast
+qed
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_PHI_init *)
+
+lemma transforms_tm_PHI_initI:
+  fixes G :: nat and M :: machine and p :: "nat \<Rightarrow> nat"
+  fixes k H thalt :: nat and tps tps' :: "tape list" and xs zs :: "symbol list"
+  assumes poly_p: "polynomial p"
+    and M_tm: "turing_machine 2 G M"
+    and k: "k = length tps" "20 < k"
+    and H: "H = max G (length M)"
+    and xs: "bit_symbols xs"
+    and zs: "zs = 2 # 2 # replicate (2 * length xs + 2 * p (length xs)) 2"
+  assumes thalt:
+    "\<forall>t<thalt. fst (execute M (start_config 2 zs) t) < length M"
+    "fst (execute M (start_config 2 zs) thalt) = length M"
+  assumes tps0:
+    "tps ! 0 = (\<lfloor>xs\<rfloor>, 1)"
+    "\<And>i. 0 < i \<Longrightarrow> i \<le> 10 \<Longrightarrow> tps ! i = (\<lfloor>[]\<rfloor>, 0)"
+    "\<And>i. 10 < i \<Longrightarrow> i < k \<Longrightarrow> tps ! i = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = (2 * d_polynomial p + 826) * (max G (length M) + thalt + Suc (Suc (Suc (2 * (length xs) + 2 * p (length xs))))) ^ 4"
+  assumes "tps' = tps
+      [9 := execute M (start_config 2 zs) thalt <!> 0,
+       3 := (\<lfloor>execute M (start_config 2 zs) thalt <#> 0\<rfloor>\<^sub>N, 1),
+       6 := (\<lfloor>execute M (start_config 2 zs) thalt <#> 1\<rfloor>\<^sub>N, 1),
+       10 := execute M (start_config 2 zs) thalt <!> 1,
+       11 := (\<lfloor>length xs\<rfloor>\<^sub>N, 1),
+       15 := (\<lfloor>p (length xs)\<rfloor>\<^sub>N, 1),
+       16 := (\<lfloor>2 * Suc ((length xs) + p (length xs))\<rfloor>\<^sub>N, 1),
+       17 := (\<lfloor>thalt\<rfloor>\<^sub>N, 1),
+       4 := (\<lfloor>map (\<lambda>t. execute M (start_config 2 zs) t <#> 0) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+       7 := (\<lfloor>map (\<lambda>t. execute M (start_config 2 zs) t <#> 1) [0..<Suc thalt]\<rfloor>\<^sub>N\<^sub>L, 1),
+       18 := (\<lfloor>thalt + Suc (2 * Suc ((length xs) + p (length xs)))\<rfloor>\<^sub>N, 1),
+       19 := (\<lfloor>max G (length M)\<rfloor>\<^sub>N, 1),
+       20 := (\<lfloor>(thalt + Suc (2 * Suc ((length xs) + p (length xs)))) * max G (length M)\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_PHI_init G M p) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_PHI_init G M p .
+  note ctx = poly_p M_tm k H xs zs thalt tps0
+  have "transforms loc.tm20 tps ttt (loc.tps20 thalt tps xs zs)"
+    using assms loc.tm20'[OF ctx] loc.tps20_def[OF ctx] loc.tpsA_def[OF ctx]
+    by blast
+  then have "transforms (tm_PHI_init G M p) tps ttt (loc.tps20 thalt tps xs zs)"
+    using loc.tm20_eq_tm_PHI_init by simp
+  moreover have "loc.tps20 thalt tps xs zs = tps'"
+    using assms loc.tps20_def[OF ctx] loc.tpsA_def[OF ctx] by presburger
+  ultimately show ?thesis
+    by simp
+qed
+
+text \<open>
+Next we transfer the semantics of @{const tm_PHI_init} to the locale
+@{locale reduction_sat_x}.
+\<close>
+
+lemma (in reduction_sat_x) tm_PHI_init [transforms_intros]:
+  fixes k :: nat and tps tps' :: "tape list"
+  assumes "k = length tps" and "20 < k"
+  assumes
+      "tps ! 0 = (\<lfloor>xs\<rfloor>, 1)"
+      "\<And>i. 0 < i \<Longrightarrow> i \<le> 10 \<Longrightarrow> tps ! i = (\<lfloor>[]\<rfloor>, 0)"
+      "\<And>i. 10 < i \<Longrightarrow> i < k \<Longrightarrow> tps ! i = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = (2 * d_polynomial p + 826) * (H + T' + Suc (Suc (Suc (2 * n + 2 * p n)))) ^ 4"
+  assumes "tps' = tps
+      [9 := exc (zeros m) T' <!> 0,
+       3 := (\<lfloor>exc (zeros m) T' <#> 0\<rfloor>\<^sub>N, 1),
+       6 := (\<lfloor>exc (zeros m) T' <#> 1\<rfloor>\<^sub>N, 1),
+       10 := exc (zeros m) T' <!> 1,
+       11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+       15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+       16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+       17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+       4 := (\<lfloor>map (\<lambda>t. exc (zeros m) t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+       7 := (\<lfloor>map (\<lambda>t. exc (zeros m) t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+       18 := (\<lfloor>T' + Suc (2 * Suc (n + p n))\<rfloor>\<^sub>N, 1),
+       19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+       20 := (\<lfloor>(T' + Suc (2 * Suc (n + p n))) * H\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_PHI_init G M p) tps ttt tps'"
+proof -
+  have nx: "n = length xs"
+    by simp
+  then have zeros_zs: "zeros m = 2 # 2 # replicate (2 * length xs + 2 * p (length xs)) 2"
+    using zeros m_def by simp
+  then have thalt:
+      "\<forall>t<T' . fst (exc (zeros m) t) < length M"
+      "fst (exc (zeros m) T') = length M"
+    using less_TT TT T'_def by metis+
+  have H: "H = max G (length M)"
+    using H_def by simp
+  have ttt: "ttt = (2 * d_polynomial p + 826) *
+      (max G (length M) + T' + Suc (Suc (Suc (2 * (length xs) + 2 * p (length xs))))) ^ 4"
+    using H nx assms(6) by simp
+  have tps': "tps' = tps
+      [9 := exc (zeros m) T' <!> 0,
+      3 := (\<lfloor>snd (exc (zeros m) T') :#: 0\<rfloor>\<^sub>N, 1),
+      6 := (\<lfloor>snd (exc (zeros m) T') :#: 1\<rfloor>\<^sub>N, 1),
+      10 := exc (zeros m) T' <!> 1, 11 := (\<lfloor>length xs\<rfloor>\<^sub>N, 1),
+      15 := (\<lfloor>p (length xs)\<rfloor>\<^sub>N, 1),
+      16 := (\<lfloor>2 * Suc (length xs + p (length xs))\<rfloor>\<^sub>N, 1),
+      17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+      4 := (\<lfloor>map (\<lambda>t. snd (exc (zeros m) t) :#: 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+      7 := (\<lfloor>map (\<lambda>t. snd (exc (zeros m) t) :#: 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+      18 := (\<lfloor>T' + Suc (2 * Suc (length xs + p (length xs)))\<rfloor>\<^sub>N, 1),
+      19 := (\<lfloor>max G (length M)\<rfloor>\<^sub>N, 1),
+      20 := (\<lfloor>(T' + Suc (2 * Suc (length xs + p (length xs)))) * max G (length M)\<rfloor>\<^sub>N, 1)]"
+    using H nx assms(7) by presburger
+  show "transforms (tm_PHI_init G M p) tps ttt tps'"
+    using transforms_tm_PHI_initI[OF p tm_M assms(1,2) H bs_xs zeros_zs thalt assms(3,4,5) ttt tps'] .
+qed
+
+
+section \<open>The actual Turing machine computing the reduction\<close>
+
+text \<open>
+In this section we put everything together to build a Turing machine that given
+a string $x$ outputs the CNF formula $\Phi$ defined in Chapter~\ref{s:Reducing}.
+In principle this is just a sequence of the TMs @{const tm_PHI_init}, @{const
+tm_PHI0}, $\dots$, @{const tm_PHI9}, where @{const tm_PHI345} occurs once for
+each of the formulas $\Phi_3$, $\Phi_4$, and $\Phi_5$. All these TMs are linked
+by TMs that copy values prepared by @{const tm_PHI_init} to the tapes where the
+following TM expects them. Also as the very first step the tape heads on tapes
+$0$ and $11$ and beyond must be moved one cell to the right to meet @{const
+tm_PHI_init}'s expectations.
+
+The TM will have 110 tapes because we just allocate another batch of tapes for
+every TM computing a $\Phi_i$, rather than cleaning up and reusing tapes.
+\<close>
+
+text \<open>
+The Turing machine for computing $\Phi$ is to be defined in the locale @{locale
+reduction_sat}. We save the space to write the TM in closed form.
+\<close>
+
+context reduction_sat
+begin
+
+definition "tm1 \<equiv> tm_right_many {i. i < 1 \<or> 10 < i}"
+definition "tm2 \<equiv> tm1 ;; tm_PHI_init G M p"
+
+definition "tm3 \<equiv> tm2 ;; tm_copyn 18 21"
+definition "tm4 \<equiv> tm3 ;; tm_copyn 19 22"
+definition "tm5 \<equiv> tm4 ;; tm_right 1"
+definition "tm6 \<equiv> tm5 ;; tm_PHI0 21"
+
+definition "tm7 \<equiv> tm6 ;; tm_setn 29 H"
+definition "tm8 \<equiv> tm7 ;; tm_PHI1 28"
+
+definition "tm9 \<equiv> tm8 ;; tm_copyn 11 35"
+definition "tm10 \<equiv> tm9 ;; tm_setn 36 H"
+definition "tm11 \<equiv> tm10 ;; tm_PHI2 35"
+
+definition "tm12 \<equiv> tm11 ;; tm_setn 42 1"
+definition "tm13 \<equiv> tm12 ;; tm_setn 43 H"
+definition "tm14 \<equiv> tm13 ;; tm_setn 44 2"
+definition "tm15 \<equiv> tm14 ;; tm_copyn 11 50"
+definition "tm16 \<equiv> tm15 ;; tm_times2incr 50"
+definition "tm17 \<equiv> tm16 ;; tm_PHI345 2 42"
+
+definition "tm18 \<equiv> tm17 ;; tm_setn 52 H"
+definition "tm19 \<equiv> tm18 ;; tm_setn 53 2"
+definition "tm20 \<equiv> tm19 ;; tm_copyn 11 51"
+definition "tm21 \<equiv> tm20 ;; tm_times2 51"
+definition "tm22 \<equiv> tm21 ;; tm_plus_const 3 51"
+definition "tm23 \<equiv> tm22 ;; tm_copyn 16 59"
+definition "tm24 \<equiv> tm23 ;; tm_incr 59"
+definition "tm25 \<equiv> tm24 ;; tm_PHI345 2 51"
+
+definition "tm26 \<equiv> tm25 ;; tm_setn 61 H"
+definition "tm27 \<equiv> tm26 ;; tm_copyn 16 60"
+definition "tm28 \<equiv> tm27 ;; tm_incr 60"
+definition "tm29 \<equiv> tm28 ;; tm_copyn 60 68"
+definition "tm30 \<equiv> tm29 ;; tm_add 17 68"
+definition "tm31 \<equiv> tm30 ;; tm_PHI345 1 60"
+
+definition "tm32 \<equiv> tm31 ;; tm_setn 69 2"
+definition "tm33 \<equiv> tm32 ;; tm_setn 70 H"
+definition "tm34 \<equiv> tm33 ;; tm_PHI6 69"
+
+definition "tm35 \<equiv> tm34 ;; tm_copyn 11 77"
+definition "tm36 \<equiv> tm35 ;; tm_times2 77"
+definition "tm37 \<equiv> tm36 ;; tm_plus_const 4 77"
+definition "tm38 \<equiv> tm37 ;; tm_setn 78 H"
+definition "tm39 \<equiv> tm38 ;; tm_copyn 15 83"
+definition "tm40 \<equiv> tm39 ;; tm_PHI7 77"
+
+definition "tm41 \<equiv> tm40 ;; tm_copyn 18 84"
+definition "tm42 \<equiv> tm41 ;; tm_add 17 84"
+definition "tm43 \<equiv> tm42 ;; tm_add 17 84"
+definition "tm44 \<equiv> tm43 ;; tm_add 17 84"
+definition "tm45 \<equiv> tm44 ;; tm_incr 84"
+definition "tm46 \<equiv> tm45 ;; tm_setn 85 H"
+definition "tm47 \<equiv> tm46 ;; tm_PHI8 84"
+
+definition "tm48 \<equiv> tm47 ;; tm_copyn 20 91"
+definition "tm49 \<equiv> tm48 ;; tm_setn 92 H"
+definition "tm50 \<equiv> tm49 ;; tm_setn 93 Z"
+definition "tm51 \<equiv> tm50 ;; tm_copyn 17 94"
+definition "tm52 \<equiv> tm51 ;; tm_set 95 (numlistlist (formula_n \<psi>))"
+definition "tm53 \<equiv> tm52 ;; tm_set 96 (numlistlist (formula_n \<psi>'))"
+definition "tm54 \<equiv> tm53 ;; tm_setn 97 1"
+definition "tm55 \<equiv> tm54 ;; tm_PHI9 4 7 91"
+
+definition "tm56 \<equiv> tm55 ;; tm_cr 1"
+definition "tm57 \<equiv> tm56 ;; tm_cp_until 1 109 {0}"
+definition "tm58 \<equiv> tm57 ;; tm_erase_cr 1"
+definition "tm59 \<equiv> tm58 ;; tm_cr 109"
+definition "tm60 \<equiv> tm59 ;; tm_binencode 109 1"
+
+definition H' :: nat where
+  "H' \<equiv> Suc (Suc H)"
+
+lemma H_gr_3: "H > 3"
+  using H_def tm_M turing_machine_def by auto
+
+lemma H': "H' \<ge> Suc (length M)" "H' \<ge> G" "H' \<ge> 6"
+  using H'_def H_ge_length_M H_ge_G H_gr_3 by simp_all
+
+lemma tm40_tm: "turing_machine 110 H' tm40"
+  unfolding tm40_def tm39_def tm38_def tm37_def tm36_def tm35_def tm34_def tm33_def tm32_def tm31_def
+  unfolding tm30_def tm29_def tm28_def tm27_def tm26_def tm25_def tm24_def tm23_def tm22_def tm21_def
+  unfolding tm20_def tm19_def tm18_def tm17_def tm16_def tm15_def tm14_def tm13_def tm12_def tm11_def
+  unfolding tm10_def tm9_def tm8_def tm7_def tm6_def tm5_def tm4_def tm3_def tm2_def tm1_def
+  using H'
+    tm_copyn_tm tm_add_tm tm_incr_tm tm_times2_tm tm_setn_tm tm_times2incr_tm
+    tm_plus_const_tm tm_right_tm tm_right_many_tm
+    tm_PHI_init_tm[OF tm_M] tm_PHI0_tm tm_PHI1_tm tm_PHI2_tm tm_PHI345_tm tm_PHI6_tm tm_PHI7_tm
+  by simp
+
+lemma tm55_tm: "turing_machine 110 H' tm55"
+  unfolding tm55_def tm54_def tm53_def tm52_def tm51_def
+  unfolding tm50_def tm49_def tm48_def tm47_def tm46_def tm45_def tm44_def tm43_def tm42_def tm41_def
+  using tm40_tm H'
+    tm_copyn_tm tm_add_tm tm_incr_tm tm_setn_tm tm_set_tm[OF _ _ _ symbols_lt_numlistlist]
+    tm_PHI8_tm tm_PHI9_tm
+  by simp
+
+lemma tm60_tm: "turing_machine 110 H' tm60"
+  unfolding tm60_def tm59_def tm58_def tm57_def tm56_def
+  using tm55_tm H' tm_erase_cr_tm tm_cr_tm tm_cp_until_tm tm_binencode_tm
+  by simp
+
+end  (* locale reduction_sat *)
+
+text \<open>
+Unlike before, we prove the semantics inside locale @{locale reduction_sat_x} since we
+need not be concerned with ``polluting'' the namespace of the locale. After all there
+will not be any more Turing machines.
+\<close>
+
+context reduction_sat_x
+begin
+
+context
+  fixes tps0 :: "tape list"
+  assumes k: "110 = length tps0"
+  assumes tps0:
+      "tps0 ! 0 = (\<lfloor>xs\<rfloor>, 0)"
+      "\<And>i. 0 < i \<Longrightarrow> i < 110\<Longrightarrow> tps0 ! i = (\<lfloor>[]\<rfloor>, 0)"
+begin
+
+definition "tps1 \<equiv> map (\<lambda>j. if j < 1 \<or> 10 < j then tps0 ! j |+| 1 else tps0 ! j) [0..<110]"
+
+lemma lentps1: "length tps1 = 110"
+  using tps1_def by simp
+
+lemma tps1:
+  "0 < j \<Longrightarrow> j < 10 \<Longrightarrow> tps1 ! j = (\<lfloor>[]\<rfloor>, 0)"
+  "10 < j \<Longrightarrow> j < 110 \<Longrightarrow> tps1 ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tps1_def k tps0 by simp_all
+
+lemma tps1': "tps1 ! 0 = (\<lfloor>xs\<rfloor>, 1)"
+proof -
+  have "tps1 ! 0 = tps0 ! 0 |+| 1"
+    using tps1_def k lentps1
+    by (smt (verit, del_insts) add.right_neutral length_greater_0_conv length_map less_or_eq_imp_le list.size(3)
+      not_numeral_le_zero nth_map nth_upt zero_less_one)
+  then show ?thesis
+    using tps0 by simp
+qed
+
+lemma tm1 [transforms_intros]: "transforms tm1 tps0 1 tps1"
+  unfolding tm1_def by (tform tps: tps1_def tps0 k)
+
+abbreviation "zs \<equiv> zeros m"
+
+definition "tpsA \<equiv> tps1
+  [9 := exc zs T' <!> 0,
+   3 := (\<lfloor>exc zs T' <#> 0\<rfloor>\<^sub>N, 1),
+   6 := (\<lfloor>exc zs T' <#> 1\<rfloor>\<^sub>N, 1),
+   10 := exc zs T' <!> 1]"
+
+lemma tpsA:
+  "tpsA ! 0 = (\<lfloor>xs\<rfloor>, 1)"
+  "tpsA ! 1 = (\<lfloor>[]\<rfloor>, 0)"
+  "10 < j \<Longrightarrow> j < 110 \<Longrightarrow> tpsA ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsA_def tps1 tps1' by simp_all
+
+lemma lentpsA: "length tpsA = 110"
+  using tpsA_def tps1_def k by simp
+
+definition "tps2 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1)]"
+
+lemma lentps2: "length tps2 = 110"
+  using tps2_def lentpsA by simp
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 1 + (2 * d_polynomial p + 826) * (H + m') ^ 4"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps0 tps1_def k lentps1)
+  have m': "m' = T' + Suc (2 * Suc (n + p n))"
+    using m'_def by simp
+  show "ttt = 1 + ((2 * d_polynomial p + 826) * (H + T' + Suc (Suc (Suc (2 * n + 2 * p n)))) ^ 4)"
+    using assms m'
+    by (metis ab_semigroup_add_class.add_ac(1) add_2_eq_Suc distrib_left_numeral mult_Suc_right)
+  have m: "m = 2 * Suc (n + p n)"
+    using m_def by simp
+  show "tps2 = tps1
+    [9 := exc zs T' <!> 0,
+     3 := (\<lfloor>snd (exc zs T') :#: 0\<rfloor>\<^sub>N, 1),
+     6 := (\<lfloor>snd (exc zs T') :#: 1\<rfloor>\<^sub>N, 1),
+     10 := exc zs T' <!> 1, 11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+     15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+     16 := (\<lfloor>2 * Suc (n + p n)\<rfloor>\<^sub>N, 1),
+     17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+     4 := (\<lfloor>map (\<lambda>t. snd (exc zs t) :#: 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+     7 := (\<lfloor>map (\<lambda>t. snd (exc zs t) :#: 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+     18 := (\<lfloor>T' + Suc (2 * Suc (n + p n))\<rfloor>\<^sub>N, 1),
+     19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+     20 := (\<lfloor>(T' + Suc (2 * Suc (n + p n))) * H\<rfloor>\<^sub>N, 1)]"
+    using tps2_def tpsA_def m m' by presburger
+qed
+
+definition "tps3 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   21 := (\<lfloor>m'\<rfloor>\<^sub>N, 1)]"
+
+lemma lentps3: "length tps3 = 110"
+  using tps3_def lentpsA by simp
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 15 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m'"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: lentps2 k assms tps2_def)
+  have "tps2 ! 21 = tpsA ! 21"
+    using tps2_def by simp
+  then show "tps2 ! 21 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsA canrepr_0 k lentps1 by simp
+  show "tps3 = tps2[21 := (\<lfloor>m'\<rfloor>\<^sub>N, 1)]"
+    unfolding tps3_def tps2_def by (simp only:)
+  show "ttt = 1 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + (14 + 3 * (nlength m' + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps4 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   21 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   22 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma lentps4: "length tps4 = 110"
+  using tps4_def lentpsA by (simp only: length_list_update)
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 29 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 3 * nlength H"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform)
+  show "19 < length tps3" "22 < length tps3"
+   using lentps3 k by simp_all
+  show "tps3 ! 19 = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps3_def lentps3 k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "tps3 ! 22 = tpsA ! 22"
+    unfolding tps3_def by simp
+  then show "tps3 ! 22 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsA canrepr_0 k lentps1 by simp
+  show "tps4 = tps3[22 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+    unfolding tps4_def tps3_def by (simp only:)
+  show "ttt = 15 + (2 * d_polynomial p + 826) * (H + m') ^ 4 +
+      3 * nlength m' + (14 + 3 * (nlength H + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps5 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   21 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   22 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   1 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma lentps5: "length tps5 = 110"
+  using tps5_def lentpsA by (simp only: length_list_update)
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 30 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 3 * nlength H"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def
+proof (tform)
+  show "1 < length tps4"
+    using lentps4 k by simp
+  show "ttt = 29 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 3 * nlength H + Suc 0"
+    using assms by simp
+  have "tps4 ! 1 = tpsA ! 1"
+    using tps4_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then have "tps4 ! 1 = (\<lfloor>[]\<rfloor>, 0)"
+    using tpsA by simp
+  then have "tps4 ! 1 |+| 1 = (\<lfloor>[]\<rfloor>, 1)"
+    by simp
+  then show "tps5 = tps4[1 := tps4 ! 1 |+| 1]"
+    unfolding tps5_def tps4_def by (simp only: list_update_swap)
+qed
+
+definition "tps6 \<equiv> tpsA
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   21 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   22 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0),
+   21 := (\<lfloor>Suc (Suc m')\<rfloor>\<^sub>N, 1),
+   21 + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   21 + 6 := (\<lfloor>nll_Psi (Suc (Suc m') * H) H 0\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma lentps6: "length tps6 = 110"
+  using tps6_def lentpsA by (simp only: length_list_update)
+
+lemma tm6 [transforms_intros]:
+  assumes "ttt = 30 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 3 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+proof (tform)
+  show "21 + 8 < length tps5"
+    using k lentps5 by simp
+  show "tps5 ! 1 = (\<lfloor>[]\<rfloor>, 1)"
+    using tps5_def lentps5 k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  show "tps5 ! 21 = (\<lfloor>m'\<rfloor>\<^sub>N, 1)"
+    using tps5_def lentps5 k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have *: "21 + 1 = 22"
+    by simp
+  show "tps5 ! (21 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps5_def lentps5 k by (simp only: * length_list_update nth_list_update_eq nth_list_update_neq)
+  have "tps5 ! 23 = tpsA ! 23"
+    using tps5_def by (simp only: nth_list_update_eq nth_list_update_neq)
+  then show "tps5 ! (21 + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsA k by simp
+  have "tps5 ! 24 = tpsA ! 24"
+    using tps5_def by (simp only: nth_list_update_eq nth_list_update_neq)
+  then show "tps5 ! (21 + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsA k by simp
+  have "tps5 ! 25 = tpsA ! 25"
+    using tps5_def by (simp only: nth_list_update_eq nth_list_update_neq)
+  then show "tps5 ! (21 + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsA k by simp
+  have "tps5 ! 26 = tpsA ! 26"
+    using tps5_def by (simp only: nth_list_update_eq nth_list_update_neq)
+  then show "tps5 ! (21 + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsA k by simp
+  have "tps5 ! 27 = tpsA ! 27"
+    using tps5_def by (simp only: nth_list_update_eq nth_list_update_neq)
+  then show "tps5 ! (21 + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsA k by simp
+  have "tps5 ! 28 = tpsA ! 28"
+    using tps5_def by (simp only: nth_list_update_eq nth_list_update_neq)
+  then show "tps5 ! (21 + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsA k by simp
+  have "tps5 ! 29 = tpsA ! 29"
+    using tps5_def by (simp only: nth_list_update_eq nth_list_update_neq)
+  then show "tps5 ! (21 + 8) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsA k by simp
+  show "ttt = 30 + (2 * d_polynomial p + 826) * (H + m') ^ 4 +
+      3 * nlength m' + 3 * nlength H + 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2"
+    using assms by simp
+  show "tps6 = tps5
+    [21 := (\<lfloor>Suc (Suc m')\<rfloor>\<^sub>N, 1),
+     21 + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     21 + 6 := (\<lfloor>nll_Psi (Suc (Suc m') * H) H 0\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+     1 := nlltape (formula_n \<Phi>\<^sub>0)]"
+    unfolding tps6_def tps5_def by (simp only: list_update_swap[of 1] list_update_overwrite)
+qed
+
+definition "tpsB \<equiv> tpsA
+  [21 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   22 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   21 := (\<lfloor>Suc (Suc m')\<rfloor>\<^sub>N, 1),
+   21 + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   21 + 6 := (\<lfloor>nll_Psi (Suc (Suc m') * H) H 0\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tpsB: "j > 27 \<Longrightarrow> j < 110 \<Longrightarrow> tpsB ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsB_def tpsA by simp
+
+lemma lentpsB: "length tpsB = 110"
+  using lentpsA tpsB_def by simp
+
+lemma tps6: "tps6 = tpsB
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0)]"
+  unfolding tps6_def tpsB_def by (simp only: list_update_swap)
+
+lemma tps6': "j > 27 \<Longrightarrow> j < 110 \<Longrightarrow> tps6 ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tps6 tpsB by (simp only: nth_list_update_neq)
+
+definition "tps7 \<equiv> tpsB
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0),
+   29 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm7 [transforms_intros]:
+  assumes "ttt = 40 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 3 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 2 * nlength H"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def
+proof (tform)
+  show "29 < length tps6"
+    using lentpsB k tps6 by (simp only: length_list_update)
+  show "tps6 ! 29 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps6' canrepr_0 k by simp
+  show "tps7 = tps6[29 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+    unfolding tps7_def using tps6 by (simp only: list_update_swap)
+  show "ttt = 30 + (2 * d_polynomial p + 826) * (H + m') ^ 4 +
+      3 * nlength m' + 3 * nlength H + 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 +
+      (10 + 2 * nlength 0 + 2 * nlength H)"
+    using assms by simp
+qed
+
+definition "tps8 \<equiv> tpsB
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1),
+   29 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   28 + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   28 + 6 := (\<lfloor>nll_Psi 0 H 1\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm8 [transforms_intros]:
+  assumes "ttt = 40 + (2 * d_polynomial p + 826) * (H + m') ^ 4 +
+    3 * nlength m' + 3 * nlength H + 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 +
+    2 * nlength H + 1875 * H ^ 4"
+  shows "transforms tm8 tps0 ttt tps8"
+  unfolding tm8_def
+proof (tform)
+  show "28 + 7 < length tps7"
+    using lentpsB k tps7_def by (simp only: length_list_update)
+  show "tps7 ! 1 = nlltape (formula_n \<Phi>\<^sub>0)"
+    using tps7_def lentpsB k by (simp only: nth_list_update_eq nth_list_update_neq length_list_update)
+  show "tps7 ! 28 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsB tps7_def canrepr_0 k by (simp only: nth_list_update_neq)
+  have "tps7 ! 29 = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps7_def lentpsB k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps7 ! (28 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps7 ! 30 = tpsB ! 30"
+    using tps7_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps7 ! (28 + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsB k by simp
+  have "tps7 ! 31 = tpsB ! 31"
+    using tps7_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps7 ! (28 + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsB k by simp
+  have "tps7 ! 32 = tpsB ! 32"
+    using tps7_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps7 ! (28 + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsB k by simp
+  have "tps7 ! 33 = tpsB ! 33"
+    using tps7_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps7 ! (28 + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsB k by simp
+  have "tps7 ! 34 = tpsB ! 34"
+    using tps7_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps7 ! (28 + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsB k by simp
+  have "tps7 ! 35 = tpsB ! 35"
+    using tps7_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps7 ! (28 + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsB k by simp
+  show "ttt = 40 + (2 * d_polynomial p + 826) * (H + m') ^ 4 +
+      3 * nlength m' + 3 * nlength H + 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 +
+      2 * nlength H + 1875 * H ^ 4"
+    using assms by simp
+  show "tps8 = tps7
+    [28 + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+     28 + 6 := (\<lfloor>nll_Psi 0 H 1\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+     1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1)]"
+    unfolding tps8_def tps7_def by (simp only: list_update_swap[of 1] list_update_overwrite)
+qed
+
+definition "tpsC \<equiv> tpsB
+  [29 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   28 + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   28 + 6 := (\<lfloor>nll_Psi 0 H 1\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tpsC: "j > 34 \<Longrightarrow> j < 110 \<Longrightarrow> tpsC ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsC_def tpsB by simp
+
+lemma lentpsC: "length tpsC = 110"
+  using lentpsB tpsC_def by simp
+
+lemma tps8: "tps8 = tpsC
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1)]"
+  unfolding tps8_def tpsC_def by (simp only: list_update_swap)
+
+definition "tps9 \<equiv> tpsC
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1),
+   35 := (\<lfloor>n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm9 [transforms_intros]:
+  assumes "ttt = 54 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' +
+    5 * nlength H + 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    3 * nlength n"
+  shows "transforms tm9 tps0 ttt tps9"
+  unfolding tm9_def
+proof (tform)
+  show "11 < length tps8" "35 < length tps8"
+    using lentpsC tps8 k by (simp_all only: length_list_update)
+  show "tps8 ! 11 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    using tps8 lentpsC k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "tps8 ! 35 = tpsC ! 35"
+    using tps8 by (simp only: nth_list_update_neq)
+  then show "tps8 ! 35 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsC k canrepr_0 by simp
+  show "tps9 = tps8[35 := (\<lfloor>n\<rfloor>\<^sub>N, 1)]"
+    unfolding tps9_def tps8 by (simp only:)
+  show "ttt = 40 + (2 * d_polynomial p + 826) * (H + m') ^ 4 +
+      3 * nlength m' + 3 * nlength H + 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 +
+      2 * nlength H + 1875 * H ^ 4 + (14 + 3 * (nlength n + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps10 \<equiv> tpsC
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1),
+   35 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   36 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm10 [transforms_intros]:
+  assumes "ttt = 64 + (2 * d_polynomial p + 826) * (H + m') ^ 4 +
+    3 * nlength m' + 5 * nlength H + 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 +
+    1875 * H ^ 4 + 3 * nlength n + 2 * nlength H"
+  shows "transforms tm10 tps0 ttt tps10"
+  unfolding tm10_def
+proof (tform)
+  show "36 < length tps9"
+    using lentpsC tps9_def k by (simp_all only: length_list_update)
+  have "tps9 ! 36 = tpsC ! 36"
+    using tps9_def by (simp only: nth_list_update_neq)
+  then show "tps9 ! 36 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsC k canrepr_0 by simp
+  show "tps10 = tps9[36 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+    unfolding tps10_def tps9_def by (simp only: list_update_swap)
+  show "ttt = 54 + (2 * d_polynomial p + 826) * (H + m') ^ 4 +
+      3 * nlength m' + 5 * nlength H + 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 +
+      1875 * H ^ 4 + 3 * nlength n + (10 + 2 * nlength 0 + 2 * nlength H)"
+    using assms by simp
+qed
+
+definition "tps11 \<equiv> tpsC
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1) @ formula_n \<Phi>\<^sub>2),
+   35 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   36 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   35 := (\<lfloor>2 * n + 2\<rfloor>\<^sub>N, 1),
+   35 + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   35 + 6 := (\<lfloor>nll_Psi (Suc (Suc (2 * n)) * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm11 [transforms_intros]:
+  assumes "ttt = 64 + (2 * d_polynomial p + 826) * (H + m') ^ 4 +
+    3 * nlength m' + 7 * nlength H + 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 +
+    1875 * H ^ 4 + 3 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2"
+  shows "transforms tm11 tps0 ttt tps11"
+  unfolding tm11_def
+proof (tform)
+  show "35 + 8 < length tps10"
+    using lentpsC k tps10_def by (simp only: length_list_update)
+  show "tps10 ! 1 = nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1)"
+    using tps10_def lentpsC k by (simp only: nth_list_update_eq nth_list_update_neq length_list_update)
+  show "tps10 ! 35 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    using tps10_def lentpsC k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "tps10 ! 36 = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps10_def lentpsC k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps10 ! (35 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps10 ! 37 = tpsC ! 37"
+    using tps10_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps10 ! (35 + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsC k by simp
+  have "tps10 ! 38 = tpsC ! 38"
+    using tps10_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps10 ! (35 + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsC k by simp
+  have "tps10 ! 39 = tpsC ! 39"
+    using tps10_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps10 ! (35 + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsC k by simp
+  have "tps10 ! 40 = tpsC ! 40"
+    using tps10_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps10 ! (35 + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsC k by simp
+  have "tps10 ! 41 = tpsC ! 41"
+    using tps10_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps10 ! (35 + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsC k by simp
+  have "tps10 ! 42 = tpsC ! 42"
+    using tps10_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps10 ! (35 + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsC k by simp
+  have "tps10 ! 43 = tpsC ! 43"
+    using tps10_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps10 ! (35 + 8) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsC k by simp
+  show "tps11 = tps10
+    [35 := (\<lfloor>2 * n + 2\<rfloor>\<^sub>N, 1),
+     35 + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+     35 + 6 := (\<lfloor>nll_Psi (Suc (Suc (2 * n)) * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+     1 := nlltape ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1) @ formula_n \<Phi>\<^sub>2)]"
+    unfolding tps11_def tps10_def by (simp only: list_update_swap[of 1] list_update_overwrite)
+  show "ttt = 64 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' +
+      5 * nlength H + 5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      3 * nlength n + 2 * nlength H + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2"
+    using assms by simp
+qed
+
+definition "tpsD \<equiv> tpsC
+  [35 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   36 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   35 := (\<lfloor>2 * n + 2\<rfloor>\<^sub>N, 1),
+   35 + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   35 + 6 := (\<lfloor>nll_Psi (Suc (Suc (2 * n)) * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tpsD: "41 < j \<Longrightarrow> j < 110 \<Longrightarrow> tpsD ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsD_def tpsC by simp
+
+lemma lentpsD: "length tpsD = 110"
+  using lentpsC tpsD_def by simp
+
+lemma tps11: "tps11 = tpsD
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1) @ formula_n \<Phi>\<^sub>2)]"
+  unfolding tps11_def tpsD_def by (simp only: list_update_swap)
+
+definition "tps12 \<equiv> tpsD
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1) @ formula_n \<Phi>\<^sub>2),
+   42 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm12 [transforms_intros]:
+  assumes "ttt = 76 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 7 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    3 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2"
+  shows "transforms tm12 tps0 ttt tps12"
+  unfolding tm12_def
+proof (tform)
+  show "42 < length tps11"
+    using lentpsD tps11 k by (simp_all only: length_list_update)
+  have "tps11 ! 42 = tpsD ! 42"
+    using tps11 by (simp only: nth_list_update_neq)
+  then show "tps11 ! 42 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsD k canrepr_0 by simp
+  show "tps12 = tps11[42 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+    unfolding tps12_def tps11 by (simp only:)
+  show "ttt = 64 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 7 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      3 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      (10 + 2 * nlength 0 + 2 * nlength 1)"
+    using canrepr_1 assms by simp
+qed
+
+definition "tps13 \<equiv> tpsD
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1) @ formula_n \<Phi>\<^sub>2),
+   42 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   43 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm13 [transforms_intros]:
+  assumes "ttt = 86 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 9 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    3 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2"
+  shows "transforms tm13 tps0 ttt tps13"
+  unfolding tm13_def
+proof (tform)
+  show "43 < length tps12"
+    using lentpsD tps12_def k by (simp_all only: length_list_update)
+  have "tps12 ! 43 = tpsD ! 43"
+    using tps12_def by (simp only: nth_list_update_neq)
+  then show "tps12 ! 43 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsD k canrepr_0 by simp
+  show "tps13 = tps12[43 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+    unfolding tps13_def tps12_def by (simp only:)
+  show "ttt = 76 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 7 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 + 3 * nlength n +
+      3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      (10 + 2 * nlength 0 + 2 * nlength H)"
+    using assms by simp
+qed
+
+definition "tps14 \<equiv> tpsD
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1) @ formula_n \<Phi>\<^sub>2),
+   42 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   43 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   44 := (\<lfloor>2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm14 [transforms_intros]:
+  assumes "ttt = 100 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 9 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    3 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2"
+  shows "transforms tm14 tps0 ttt tps14"
+  unfolding tm14_def
+proof (tform)
+  show "44 < length tps13"
+    using lentpsD tps13_def k by (simp_all only: length_list_update)
+  have "tps13 ! 44 = tpsD ! 44"
+    using tps13_def by (simp only: nth_list_update_neq)
+  then show "tps13 ! 44 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsD k canrepr_0 by simp
+  show "tps14 = tps13[44 := (\<lfloor>2\<rfloor>\<^sub>N, 1)]"
+    unfolding tps14_def tps13_def by (simp only:)
+  show "ttt = 86 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 9 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      3 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      (10 + 2 * nlength 0 + 2 * nlength 2)"
+    using nlength_2 assms by simp
+qed
+
+definition "tps15 \<equiv> tpsD
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1) @ formula_n \<Phi>\<^sub>2),
+   42 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   43 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   44 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   50 := (\<lfloor>n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm15 [transforms_intros]:
+  assumes "ttt = 114 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 9 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    6 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2"
+  shows "transforms tm15 tps0 ttt tps15"
+  unfolding tm15_def
+proof (tform)
+  show "11 < length tps14" "50 < length tps14"
+    using lentpsD tps14_def k by (simp_all only: length_list_update)
+  show "tps14 ! 11 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    using tps14_def k lentpsD by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "tps14 ! 50 = tpsD ! 50"
+    using tps14_def by (simp only: nth_list_update_neq)
+  then show "tps14 ! 50 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsD k canrepr_0 by simp
+  show "tps15 = tps14[50 := (\<lfloor>n\<rfloor>\<^sub>N, 1)]"
+    unfolding tps15_def tps14_def by (simp only:)
+  show "ttt = 100 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 9 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      3 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      (14 + 3 * (nlength n + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps16 \<equiv> tpsD
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1) @ formula_n \<Phi>\<^sub>2),
+   42 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   43 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   44 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   50 := (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm16 [transforms_intros]:
+  assumes "ttt = 126 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 9 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    10 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2"
+  shows "transforms tm16 tps0 ttt tps16"
+  unfolding tm16_def
+proof (tform)
+  show "2 \<le> length tps15" "50 < length tps15"
+    using lentpsD tps15_def k by (simp_all only: length_list_update)
+  show "tps15 ! 50 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    using tps15_def k lentpsD by (simp only: length_list_update nth_list_update_eq)
+  have "tps16 = tps15[50 := (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1)]"
+    unfolding tps16_def tps15_def by (simp only: list_update_swap[of 1] list_update_overwrite)
+  then show "tps16 = tps15[50 := (\<lfloor>Suc (2 * n)\<rfloor>\<^sub>N, 1)]"
+    by simp
+  show "ttt = 114 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 9 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 + 6 * nlength n +
+      3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 + (12 + 4 * nlength n)"
+    using assms by simp
+qed
+
+definition "tps17 \<equiv> tpsD
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3),
+   42 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   43 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   44 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   50 := (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1),
+   42 := (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1),
+   42 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm17 [transforms_intros]:
+  assumes "ttt = 126 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 9 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    10 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2))"
+  shows "transforms tm17 tps0 ttt tps17"
+  unfolding tm17_def
+proof (tform transforms_intros: tm_PHI3)
+  show "42 + 8 < length tps16"
+    using lentpsD k tps16_def by (simp only: length_list_update)
+  show "tps16 ! 1 = nlltape ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1) @ formula_n \<Phi>\<^sub>2)"
+    using tps16_def lentpsD k by (simp only: nth_list_update_eq nth_list_update_neq length_list_update)
+  show "tps16 ! 42 = (\<lfloor>1\<rfloor>\<^sub>N, 1)"
+    using tps16_def lentpsD k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "tps16 ! 43 = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps16_def lentpsD k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps16 ! (42 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps16 ! 44 = (\<lfloor>2\<rfloor>\<^sub>N, 1)"
+    using tps16_def lentpsD k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps16 ! (42 + 2) = (\<lfloor>2\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps16 ! 45 = tpsD ! 45"
+    using tps16_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps16 ! (42 + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsD k by simp
+  have "tps16 ! 46 = tpsD ! 46"
+    using tps16_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps16 ! (42 + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsD k by simp
+  have "tps16 ! 47 = tpsD ! 47"
+    using tps16_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps16 ! (42 + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsD k by simp
+  have "tps16 ! 48 = tpsD ! 48"
+    using tps16_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps16 ! (42 + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsD k by simp
+  have "tps16 ! 49 = tpsD ! 49"
+    using tps16_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps16 ! (42 + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsD k by simp
+  have "tps16 ! 50 = (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1)"
+    using tps16_def lentpsD k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps16 ! (42 + 8) = (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps17 = tps16
+    [42 := (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1),
+     1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3),
+     42 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+    unfolding tps17_def tps16_def by (simp only: list_update_swap[of 1] list_update_overwrite)
+  then show "tps17 = tps16
+    [42 := (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1),
+     1 := nlltape (((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1) @ formula_n \<Phi>\<^sub>2) @ formula_n \<Phi>\<^sub>3),
+     42 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+    by simp
+  show "ttt = 126 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 9 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      10 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2))"
+    using assms by simp
+qed
+
+definition "tpsE \<equiv> tpsD
+  [42 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   43 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   44 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   50 := (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1),
+   42 := (\<lfloor>1 + 2 * n\<rfloor>\<^sub>N, 1),
+   42 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+lemma tpsE: "50 < j \<Longrightarrow> j < 110 \<Longrightarrow> tpsE ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsE_def tpsD by simp
+
+lemma lentpsE: "length tpsE = 110"
+  using lentpsD tpsE_def by simp
+
+lemma tps17: "tps17 = tpsE
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3)]"
+  unfolding tps17_def tpsE_def by (simp only: list_update_swap)
+
+definition "tps18 \<equiv> tpsE
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3),
+   52 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm18 [transforms_intros]:
+  assumes "ttt = 136 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    10 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2))"
+  shows "transforms tm18 tps0 ttt tps18"
+  unfolding tm18_def
+proof (tform)
+  show "52 < length tps17"
+    using lentpsE tps17 k by (simp_all only: length_list_update)
+  have "tps17 ! 52 = tpsE ! 52"
+    using tps17 by (simp only: nth_list_update_neq)
+  then show "tps17 ! 52 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsE k canrepr_0 by simp
+  show "tps18 = tps17[52 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+    unfolding tps18_def tps17 by (simp only:)
+  show "ttt = 126 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 9 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      10 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) +
+      (10 + 2 * nlength 0 + 2 * nlength H)"
+    using assms by simp
+qed
+
+definition "tps19 \<equiv> tpsE
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3),
+   52 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   53 := (\<lfloor>2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm19 [transforms_intros]:
+  assumes "ttt = 150 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    10 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2))"
+  shows "transforms tm19 tps0 ttt tps19"
+  unfolding tm19_def
+proof (tform)
+  show "53 < length tps18"
+    using lentpsE tps18_def k by (simp_all only: length_list_update)
+  have "tps18 ! 53 = tpsE ! 53"
+    using tps18_def by (simp only: nth_list_update_neq)
+  then show "tps18 ! 53 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsE k canrepr_0 by simp
+  show "tps19 = tps18[53 := (\<lfloor>2\<rfloor>\<^sub>N, 1)]"
+    unfolding tps19_def tps18_def by (simp only:)
+  show "ttt = 136 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      10 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) +
+      (10 + 2 * nlength 0 + 2 * nlength 2)"
+    using assms nlength_2 by simp
+qed
+
+definition "tps20 \<equiv> tpsE
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3),
+   52 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   53 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   51 := (\<lfloor>n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm20 [transforms_intros]:
+  assumes "ttt = 164 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      13 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2))"
+  shows "transforms tm20 tps0 ttt tps20"
+  unfolding tm20_def
+proof (tform)
+  show "11 < length tps19" "51 < length tps19"
+    using lentpsE tps19_def k by (simp_all only: length_list_update)
+  show "tps19 ! 11 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    using tps19_def k lentpsE by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "tps19 ! 51 = tpsE ! 51"
+    using tps19_def by (simp only: nth_list_update_neq)
+  then show "tps19 ! 51 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsE k canrepr_0 by simp
+  show "tps20 = tps19[51 := (\<lfloor>n\<rfloor>\<^sub>N, 1)]"
+    unfolding tps20_def tps19_def by (simp only:)
+  show "ttt = 150 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      10 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) +
+      (14 + 3 * (nlength n + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps21 \<equiv> tpsE
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3),
+   52 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   53 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   51 := (\<lfloor>2 * n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm21 [transforms_intros]:
+  assumes "ttt = 169 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2))"
+  shows "transforms tm21 tps0 ttt tps21"
+  unfolding tm21_def
+proof (tform time: assms)
+  show "51 < length tps20"
+    using lentpsE tps20_def k by (simp only: length_list_update)
+  show "tps20 ! 51 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    using tps20_def k lentpsE by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  show "tps21 = tps20[51 := (\<lfloor>2 * n\<rfloor>\<^sub>N, 1)]"
+    unfolding tps21_def tps20_def by (simp only: list_update_overwrite)
+qed
+
+definition "tps22 \<equiv> tpsE
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3),
+   52 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   53 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   51 := (\<lfloor>2 * n + 3\<rfloor>\<^sub>N, 1)]"
+
+lemma tm22 [transforms_intros]:
+  assumes "ttt = 184 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3)"
+  shows "transforms tm22 tps0 ttt tps22"
+  unfolding tm22_def
+proof (tform time: assms)
+  show "51 < length tps21"
+    using lentpsE tps21_def k by (simp only: length_list_update)
+  show "tps21 ! 51 = (\<lfloor>2 * n\<rfloor>\<^sub>N, 1)"
+    using tps21_def k lentpsE by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  show "tps22 = tps21[51 := (\<lfloor>2 * n + 3\<rfloor>\<^sub>N, 1)]"
+    unfolding tps22_def tps21_def by (simp only: list_update_overwrite)
+qed
+
+definition "tps23 \<equiv> tpsE
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3),
+   52 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   53 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   51 := (\<lfloor>2 * n + 3\<rfloor>\<^sub>N, 1),
+   59 := (\<lfloor>m\<rfloor>\<^sub>N, 1)]"
+
+lemma tm23 [transforms_intros]:
+  assumes "ttt = 198 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+    3 * nlength m"
+  shows "transforms tm23 tps0 ttt tps23"
+  unfolding tm23_def
+proof (tform)
+  show "16 < length tps22" "59 < length tps22"
+    using lentpsE tps22_def k by (simp_all only: length_list_update)
+  show "tps22 ! 16 = (\<lfloor>m\<rfloor>\<^sub>N, 1)"
+    using tps22_def k lentpsE by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "tps22 ! 59 = tpsE ! 59"
+    using tps22_def by (simp only: nth_list_update_neq)
+  then show "tps22 ! 59 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsE k canrepr_0 by simp
+  show "tps23 = tps22[59 := (\<lfloor>m\<rfloor>\<^sub>N, 1)]"
+    unfolding tps23_def tps22_def by (simp only:)
+  show "ttt = 184 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+      (14 + 3 * (nlength m + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps24 \<equiv> tpsE
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3),
+   52 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   53 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   51 := (\<lfloor>2 * n + 3\<rfloor>\<^sub>N, 1),
+   59 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1)]"
+
+lemma tm24 [transforms_intros]:
+  assumes "ttt = 203 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+    5 * nlength m"
+  shows "transforms tm24 tps0 ttt tps24"
+  unfolding tm24_def
+proof (tform time: assms)
+  show "59 < length tps23"
+    using lentpsE tps23_def k by (simp only: length_list_update)
+  have "tps23 ! 59 = (\<lfloor>m\<rfloor>\<^sub>N, 1)"
+    using tps23_def k lentpsE by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps23 ! 59 = (\<lfloor>m\<rfloor>\<^sub>N, 1)"
+    by simp
+  show "tps24 = tps23[59 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1)]"
+    unfolding tps24_def tps23_def by (simp only: list_update_overwrite)
+qed
+
+definition "tps25 \<equiv> tpsE
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4),
+   52 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   53 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   51 := (\<lfloor>2 * n + 3\<rfloor>\<^sub>N, 1),
+   59 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1),
+   51 := (\<lfloor>2 * n + 2 + 1 + 2 * p n\<rfloor>\<^sub>N, 1),
+   51 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm25 [transforms_intros]:
+  assumes "ttt = 203 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+      5 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2))"
+  shows "transforms tm25 tps0 ttt tps25"
+  unfolding tm25_def
+proof (tform transforms_intros: tm_PHI4)
+  show "51 + 8 < length tps24"
+    using lentpsE tps24_def k by (simp only: length_list_update)
+  show "tps24 ! 1 = nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3)"
+    using tps24_def lentpsE k by (simp only: nth_list_update_eq nth_list_update_neq length_list_update)
+  have "tps24 ! 51 = (\<lfloor>2 * n + 3\<rfloor>\<^sub>N, 1)"
+    using tps24_def lentpsE k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps24 ! 51 = (\<lfloor>2 * n + 2 + 1\<rfloor>\<^sub>N, 1)"
+    by (metis add.assoc nat_1_add_1 numeral_Bit1 numerals(1))
+  have "tps24 ! 52 = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps24_def lentpsE k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps24 ! (51 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps24 ! 53 = (\<lfloor>2\<rfloor>\<^sub>N, 1)"
+    using tps24_def lentpsE k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps24 ! (51 + 2) = (\<lfloor>2\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps24 ! 54 = tpsE ! 54"
+    using tps24_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps24 ! (51 + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsE k by simp
+  have "tps24 ! 55 = tpsE ! 55"
+    using tps24_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps24 ! (51 + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsE k by simp
+  have "tps24 ! 56 = tpsE ! 56"
+    using tps24_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps24 ! (51 + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsE k by simp
+  have "tps24 ! 57 = tpsE ! 57"
+    using tps24_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps24 ! (51 + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsE k by simp
+  have "tps24 ! 58 = tpsE ! 58"
+    using tps24_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps24 ! (51 + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsE k by simp
+  have "tps24 ! 59 = (\<lfloor>Suc m\<rfloor>\<^sub>N, 1)"
+    using tps24_def lentpsE k by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  moreover have *: "Suc m = 2 * n + 2 + 1 + 2 * p n"
+    using m_def by simp
+  ultimately show "tps24 ! (51 + 8) = (\<lfloor>2 * n + 2 + 1 + 2 * p n\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps25 = tps24
+    [51 := (\<lfloor>2 * n + 2 + 1 + 2 * p n\<rfloor>\<^sub>N, 1),
+     1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4),
+     51 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+    unfolding tps25_def tps24_def by (simp only: list_update_swap list_update_overwrite)
+  then show "tps25 = tps24
+    [51 := (\<lfloor>2 * n + 2 + 1 + 2 * p n\<rfloor>\<^sub>N, 1),
+     1 := nlltape ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3) @ formula_n \<Phi>\<^sub>4),
+     51 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+    by simp
+  show "ttt = 203 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+      5 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (2 * n + 2 + 1 + 2 * p n))\<^sup>2))"
+    using assms * by simp
+qed
+
+definition "tpsF \<equiv> tpsE
+  [52 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   53 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   51 := (\<lfloor>2 * n + 3\<rfloor>\<^sub>N, 1),
+   59 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1),
+   51 := (\<lfloor>2 * n + 2 + 1 + 2 * p n\<rfloor>\<^sub>N, 1),
+   51 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+lemma tpsF: "59 < j \<Longrightarrow> j < 110 \<Longrightarrow> tpsF ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsF_def tpsE by simp
+
+lemma lentpsF: "length tpsF = 110"
+  using lentpsE tpsF_def by simp
+
+lemma tps25: "tps25 = tpsF
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4)]"
+  unfolding tps25_def tpsF_def by (simp only: list_update_swap)
+
+definition "tps26 \<equiv> tpsF
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4),
+   61 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm26 [transforms_intros]:
+  assumes "ttt = 213 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+    5 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2))"
+  shows "transforms tm26 tps0 ttt tps26"
+  unfolding tm26_def
+proof (tform)
+  show "61 < length tps25"
+    using lentpsF tps25 k by (simp_all only: length_list_update)
+  have "tps25 ! 61 = tpsF ! 61"
+    using tps25 by (simp only: nth_list_update_neq)
+  then show "tps25 ! 61 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsF k canrepr_0 by simp
+  show "tps26 = tps25[61 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+    unfolding tps26_def tps25 by (simp only:)
+  show "ttt = 203 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 11 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+      5 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) +
+      (10 + 2 * nlength 0 + 2 * nlength H)"
+    using assms by simp
+qed
+
+definition "tps27 \<equiv> tpsF
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4),
+   61 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   60 := (\<lfloor>m\<rfloor>\<^sub>N, 1)]"
+
+lemma tm27 [transforms_intros]:
+  assumes "ttt = 227 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+    8 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2))"
+  shows "transforms tm27 tps0 ttt tps27"
+  unfolding tm27_def
+proof (tform)
+  show "16 < length tps26" "60 < length tps26"
+    using lentpsF tps26_def k by (simp_all only: length_list_update)
+  show "tps26 ! 16 = (\<lfloor>m\<rfloor>\<^sub>N, 1)"
+    using tps26_def k lentpsF by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  have "tps26 ! 60 = tpsF ! 60"
+    using tps26_def by (simp only: nth_list_update_neq)
+  then show "tps26 ! 60 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsF k canrepr_0 by simp
+  show "tps27 = tps26[60 := (\<lfloor>m\<rfloor>\<^sub>N, 1)]"
+    unfolding tps27_def tps26_def by (simp only:)
+  show "ttt = 213 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+      5 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) +
+      (14 + 3 * (nlength m + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps28 \<equiv> tpsF
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4),
+   61 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   60 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1)]"
+
+lemma tm28 [transforms_intros]:
+  assumes "ttt = 232 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+    10 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2))"
+  shows "transforms tm28 tps0 ttt tps28"
+  unfolding tm28_def
+proof (tform)
+  show "60 < length tps27"
+    using lentpsF tps27_def k by (simp_all only: length_list_update)
+  show "tps27 ! 60 = (\<lfloor>m\<rfloor>\<^sub>N, 1)"
+    using tps27_def k lentpsF by (simp only: length_list_update nth_list_update_eq)
+  show "tps28 = tps27[60 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1)]"
+    unfolding tps28_def tps27_def by (simp only: list_update_overwrite)
+  show "ttt = 227 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+      8 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) +
+      (5 + 2 * nlength m)"
+    using assms by simp
+qed
+
+definition "tps29 \<equiv> tpsF
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4),
+   61 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   60 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1),
+   68 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1)]"
+
+lemma tm29 [transforms_intros]:
+  assumes "ttt = 246 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+    10 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) +
+    3 * nlength (Suc m)"
+  shows "transforms tm29 tps0 ttt tps29"
+  unfolding tm29_def
+proof (tform)
+  show "60 < length tps28" "68 < length tps28"
+    using lentpsF tps28_def k by (simp_all only: length_list_update)
+  show "tps28 ! 60 = (\<lfloor>Suc m\<rfloor>\<^sub>N, 1)"
+    using tps28_def k lentpsF by (simp only: length_list_update nth_list_update_eq)
+  have "tps28 ! 68 = tpsF ! 68"
+    using tps28_def by (simp only: nth_list_update_neq)
+  then show "tps28 ! 68 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsF k canrepr_0 by simp
+  show "tps29 = tps28[68 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1)]"
+    unfolding tps29_def tps28_def by (simp only: list_update_overwrite)
+  show "ttt = 232 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+      10 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) +
+      (14 + 3 * (nlength (Suc m) + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps30 \<equiv> tpsF
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4),
+   61 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   60 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1),
+   68 := (\<lfloor>T' + Suc m\<rfloor>\<^sub>N, 1)]"
+
+lemma tm30 [transforms_intros]:
+  assumes "ttt = 256 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+    5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+    15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+    Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+    10 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) +
+    3 * nlength (Suc m) + 3 * max (nlength T') (nlength (Suc m))"
+  shows "transforms tm30 tps0 ttt tps30"
+  unfolding tm30_def
+proof (tform)
+  show "17 < length tps29" "68 < length tps29"
+    using lentpsF tps29_def k by (simp_all only: length_list_update)
+  show "tps29 ! 17 = (\<lfloor>T'\<rfloor>\<^sub>N, 1)"
+    using tps29_def k lentpsF by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps29 ! 68 = (\<lfloor>Suc m\<rfloor>\<^sub>N, 1)"
+    using tps29_def k lentpsF by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps30 = tps29[68 := (\<lfloor>T' + Suc m\<rfloor>\<^sub>N, 1)]"
+    unfolding tps30_def tps29_def by (simp only: list_update_overwrite)
+  show "ttt = 246 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+      10 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) +
+      3 * nlength (Suc m) + (3 * max (nlength T') (nlength (Suc m)) + 10)"
+    using assms by simp
+qed
+
+definition "tps31 \<equiv> tpsF
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+         (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+          formula_n \<Phi>\<^sub>5),
+   61 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   60 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1),
+   68 := (\<lfloor>T' + Suc m\<rfloor>\<^sub>N, 1),
+   60 := (\<lfloor>Suc m + T'\<rfloor>\<^sub>N, 1),
+   60 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+definition "ttt31 \<equiv> 256 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+  5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+  15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+  Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+  10 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) +
+  3 * nlength (Suc m) + 3 * max (nlength T') (nlength (Suc m)) +
+  Suc T' * (9 + 1891 * (H ^ 4 * (nlength (Suc m + T'))\<^sup>2))"
+
+lemma le_N: "y \<le> 2 * n + 2 * p n + 3 + T' \<Longrightarrow> y \<le> N "
+  using H_gr_2 m'_def N_eq
+  by (metis Suc_1 Suc_leI add_2_eq_Suc' add_leE le_trans mult_le_mono1 nat_mult_1)
+
+lemma n_le_N: "n \<le> N "
+  using le_N by simp
+
+lemma H_le_N: "H \<le> N "
+  using N_eq by simp
+
+lemma N_ge_1: "N \<ge> 1"
+  using H_le_N H_ge_3 by simp
+
+lemma pow2_sum_le:
+  fixes a b :: nat
+  shows "(a + b) ^ 2 \<le> a ^ 2 + (2 * a + 1) * b ^ 2"
+proof -
+  have "(a + b) ^ 2 = a ^ 2 + 2 * a * b + b ^ 2"
+    by algebra
+  also have "... \<le> a ^ 2 + 2 * a * b ^ 2 + b ^ 2"
+    by (simp add: power2_nat_le_imp_le)
+  also have "... = a ^ 2 + (2 * a + 1) * b ^ 2"
+    by simp
+  finally show ?thesis .
+qed
+
+lemma ttt31: "ttt31 \<le> (32 * d_polynomial p + 222011) * H ^ 4 * N ^ 4"
+proof -
+  have a: "Suc T' * (9 + 1891 * (H ^ 4 * (nlength (Suc m + T'))\<^sup>2)) \<le> 1900 * H ^ 4 * N ^ 4"
+  proof -
+    have "Suc (2 * n + 2 * p n + 2) + T' \<le> 2 * n + 2 * p n + 3 + T' "
+      by simp
+    also have "... \<le> H * (2 * n + 2 * p n + 3 + T')"
+      using H_gr_2 by simp
+    finally have "Suc m + T' \<le> N "
+      unfolding N_eq m_def by simp
+    then have "nlength (Suc m + T') \<le> N "
+      using nlength_le_n order.trans by auto
+    then have "(nlength (Suc m + T')) ^ 2 \<le> N ^ 2"
+      by simp
+    then have "H ^ 4 * (nlength (Suc m + T')) ^ 2 \<le> H ^ 4 * N ^ 2"
+      using mult_le_mono by simp
+    then have "9 + 1891 * (H ^ 4 * (nlength (Suc m + T'))\<^sup>2) \<le> 9 + 1891 * H ^ 4 * N ^ 2"
+      by simp
+    then have "Suc T' * (9 + 1891 * (H ^ 4 * (nlength (Suc m + T'))\<^sup>2)) \<le> Suc T' * (9 + 1891 * H ^ 4 * N ^ 2)"
+      using mult_le_mono2 by blast
+    also have "... \<le> N * (9 + 1891 * H ^ 4 * N ^ 2)"
+    proof -
+      have "Suc T' \<le> N "
+        using le_N by simp
+      then show ?thesis
+        using mult_le_mono1 by blast
+    qed
+    also have "... = 9 * N + 1891 * H ^ 4 * N ^ 3"
+      by algebra
+    also have "... \<le> 9 * N ^ 3 + 1891 * H ^ 4 * N ^ 3"
+      using linear_le_pow by simp
+    also have "... \<le> 9 * N ^ 3 + 1891 * H ^ 4 * N ^ 4"
+      using pow_mono'[of 3 4] by simp
+    also have "... \<le> 9 * N ^ 4 + 1891 * H ^ 4 * N ^ 4"
+      using pow_mono'[of 3 4] by simp
+    also have "... \<le> 9 * H ^ 4 * N ^ 4 + 1891 * H ^ 4 * N ^ 4"
+      using H_ge_3 by simp
+    also have "... = 1900 * H ^ 4 * N ^ 4"
+      by simp
+    finally show ?thesis .
+  qed
+
+  have b: "5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 \<le> 140675 * H ^ 4 * N ^ 4"
+  proof -
+    have "3 * H + m' * H \<le> 2 * N "
+      using N_eq m'_def by simp
+    then have "nlength (3 * H + m' * H) \<le> nlength (2 * N)"
+      using nlength_mono by simp
+    also have "... \<le> Suc (nlength N)"
+      using le_trans nlength_times2 by blast
+    also have "... \<le> Suc N"
+      using nlength_le_n by simp
+    finally have "nlength (3 * H + m' * H) \<le> Suc N" .
+    then have "3 + nlength (3 * H + m' * H) \<le> 4 + N "
+      by simp
+    then have "(3 + nlength (3 * H + m' * H)) ^ 2 \<le> (4 + N) ^ 2"
+      by simp
+    also have "... \<le> 16 + 9 * N ^ 2"
+      using pow2_sum_le[of 4 "N "] by simp
+    finally have "(3 + nlength (3 * H + m' * H)) ^ 2 \<le> 16 + 9 * N ^ 2" .
+    then have "5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 \<le> 5627 * H ^ 4 * (16 + 9 * N ^ 2)"
+      by simp
+    also have "... = 5627 * H ^ 4 * 16 + 5627 * H ^ 4 * 9 * N ^ 2"
+      by algebra
+    also have "... = 90032 * H ^ 4 + 50643 * H ^ 4 * N ^ 2"
+      by simp
+    also have "... \<le> 90032 * H ^ 4 * N ^ 2 + 50643 * H ^ 4 * N ^ 2"
+      using pow_mono' N_ge_1 by simp
+    also have "... = 140675 * H ^ 4 * N ^ 2"
+      by simp
+    also have "... \<le> 140675 * H ^ 4 * N ^ 4"
+      using pow_mono' by simp
+    finally show ?thesis .
+  qed
+
+  have c: "3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 \<le> 60224 * H ^ 4 * N ^ 4"
+  proof -
+    have "3 * H \<le> N " and "2 * n * H \<le> N "
+      using N_eq by simp_all
+    then have "3 * H + 2 * n * H \<le> 2 * N "
+      by simp
+    then have "nlength (3 * H + 2 * n * H) \<le> 3 * H + 2 * n * H"
+      using nlength_le_n by simp
+    then have "nlength (3 * H + 2 * n * H) \<le> H * (3 + 2 * n)"
+      by (metis distrib_right mult.commute)
+    also have "... \<le> N "
+      using N_eq by simp
+    finally have "nlength (3 * H + 2 * n * H) \<le> N " .
+    then have "3 + nlength (3 * H + 2 * n * H) \<le> 3 + N "
+      by simp
+    then have "(3 + nlength (3 * H + 2 * n * H))\<^sup>2 \<le> (3 + N) ^ 2"
+      by simp
+    also have "... \<le> 9 + 7 * N ^ 2"
+      using pow2_sum_le[of 3 "N "] by simp
+    finally have "(3 + nlength (3 * H + 2 * n * H))\<^sup>2 \<le> 9 + 7 * N ^ 2" .
+    then have "3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 \<le> 3764 * H ^ 4 * (9 + 7 * N ^ 2)"
+      by simp
+    also have "... = 3764 * H ^ 4 * 9 + 3764 * H ^ 4 * 7 * N ^ 2"
+      by algebra
+    also have "... = 33876 * H ^ 4 + 26348 * H ^ 4 * N ^ 2"
+      by simp
+    also have "... \<le> 33876 * H ^ 4 * N ^ 2 + 26348 * H ^ 4 * N ^ 2"
+      using pow_mono' N_ge_1 by simp
+    also have "... = 60224 * H ^ 4 * N ^ 2"
+      by simp
+    also have "... \<le> 60224 * H ^ 4 * N ^ 4"
+      using pow_mono' by simp
+    finally show ?thesis .
+  qed
+
+  have d: "Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) \<le> 1906 * H ^ 4 * N ^ 4"
+  proof -
+    have "Suc (p n) \<le> N "
+      using le_N by simp
+    then have "Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) \<le> N * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2))"
+      using mult_le_mono1 by blast
+    also have "... \<le> N * (9 + 1897 * (H ^ 4 * (nlength N)\<^sup>2))"
+    proof -
+      have "Suc m \<le> N "
+        using m_def le_N by simp
+      then show ?thesis
+        using H4_nlength H_ge_3 add_le_mono less_or_eq_imp_le mult_le_mono by presburger
+    qed
+    also have "... \<le> N * (9 + 1897 * (H ^ 4 * N\<^sup>2))"
+      using nlength_le_n by simp
+    also have "... = N * 9 + N * 1897 * H ^ 4 * N ^ 2"
+      by (simp add: add_mult_distrib2)
+    also have "... \<le> N ^ 3 * 9 + N * 1897 * H ^ 4 * N ^ 2"
+      using linear_le_pow by simp
+    also have "... \<le> 9 * H ^ 4 * N ^ 3 + N * 1897 * H ^ 4 * N ^ 2"
+      using H_ge_3 by simp
+    also have "... = 9 * H ^ 4 * N ^ 3 + 1897 * H ^ 4 * N ^ 3"
+      by algebra
+    also have "... = 1906 * H ^ 4 * N ^ 3"
+      by simp
+    also have "... \<le> 1906 * H ^ 4 * N ^ 4"
+      using pow_mono' by simp
+    finally show ?thesis .
+  qed
+
+  have e: "Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) \<le> 1906 * H ^ 4 * N ^ 4"
+  proof -
+    have "nlength (1 + 2 * n) \<le> N "
+      using le_N nlength_le_n[of "1 + 2 * n "] by simp
+    then have "(nlength (1 + 2 * n)) ^ 2 \<le> N ^ 2"
+      by simp
+    then have "Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) \<le> Suc n * (9 + 1897 * (H ^ 4 * N\<^sup>2))"
+      using add_le_mono less_or_eq_imp_le mult_le_mono2 by presburger
+    also have "... = Suc n * (9 + 1897 * H ^ 4 * N\<^sup>2)"
+      by simp
+    also have "... \<le> N * (9 + 1897 * H ^ 4 * N ^ 2)"
+      using mult_le_mono1[OF le_N[of "Suc n"]] by simp
+    also have "... = N * 9 + 1897 * H ^ 4 * N ^ 3"
+      by algebra
+    also have "... \<le> 9 * N ^ 3 + 1897 * H ^ 4 * N ^ 3"
+      using linear_le_pow by simp
+    also have "... \<le> 9 * H ^ 4 * N ^ 3 + 1897 * H ^ 4 * N ^ 3"
+      using H_ge_3 by simp
+    also have "... = 1906 * H ^ 4 * N ^ 3"
+      by simp
+    also have "... \<le> 1906 * H ^ 4 * N ^ 4"
+      using pow_mono' by simp
+    finally show ?thesis .
+  qed
+
+  have nlength_le_GN: "y \<le> N \<Longrightarrow> nlength y \<le> H ^ 4 * N ^ 4" for y
+  proof -
+    assume "y \<le> N "
+    then have "nlength y \<le> N ^ 4"
+      using nlength_le_n linear_le_pow H_ge_3 by (meson dual_order.trans zero_less_numeral)
+    also have "... \<le> H ^ 4 * N ^ 4"
+      using H_gr_2 by simp
+    finally show ?thesis .
+  qed
+
+  have f: "13 * nlength H \<le> 13 * H ^ 4 * N ^ 4"
+    using nlength_le_GN[of H] N_eq by simp
+  have g: "15 * nlength n \<le> 15 * H ^ 4 * N ^ 4"
+    using nlength_le_GN[OF n_le_N] by simp
+  have h: "6 * nlength (2 * n + 3) \<le> 6 * H ^ 4 * N ^ 4"
+    using nlength_le_GN le_N by simp
+  have i: "10 * nlength m \<le> 10 * H ^ 4 * N ^ 4"
+    using m_def nlength_le_GN le_N by simp
+  have j: "3 * nlength (Suc m) \<le> 3 * H ^ 4 * N ^ 4"
+    using m_def nlength_le_GN le_N by simp
+  have k: "3 * max (nlength T') (nlength (Suc m)) \<le> 3 * H ^ 4 * N ^ 4"
+  proof -
+    have "nlength T' \<le> H ^ 4 * N ^ 4"
+      using nlength_le_GN le_N by simp
+    moreover have "nlength (Suc m) \<le> H ^ 4 * N ^ 4"
+      using m_def nlength_le_GN le_N by simp
+    ultimately show ?thesis
+      by simp
+  qed
+  have l: "1875 * H ^ 4 \<le> 1875 * H ^ 4 * N ^ 4"
+    using N_ge_1 by simp
+  have m: "3 * nlength m' \<le> 3 * H ^ 4 * N ^ 4"
+    using m'_def le_N le_refl nat_mult_le_cancel_disj nlength_le_GN by simp
+
+  have "ttt31 \<le> 256 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 1928 * H ^ 4 * N ^ 4 +
+      140675 * H ^ 4 * N ^ 4 + 60224 * H ^ 4 * N ^ 4 + 1906 * H ^ 4 * N ^ 4 + 1906 * H ^ 4 * N ^ 4 + 1900 * H ^ 4 * N ^ 4"
+    using ttt31_def a b c d e m l k f h i g j by linarith
+  also have "... = 256 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 208539 * H ^ 4 * N ^ 4"
+    by simp
+  also have "... \<le> 256 + (2 * d_polynomial p + 826) * (N + N) ^ 4 + 208539 * H ^ 4 * N ^ 4"
+  proof -
+    have "H \<le> N "
+      using N_eq by simp
+    then show ?thesis
+      using le_N[of "m'"] m'_def by simp
+  qed
+  also have "... = 256 + (2 * d_polynomial p + 826) * (2 * N) ^ 4 + 208539 * H ^ 4 * N ^ 4"
+    by algebra
+  also have "... = 256 + (2 * d_polynomial p + 826) * 16 * N ^ 4 + 208539 * H ^ 4 * N ^ 4"
+    by simp
+  also have "... \<le> 256 + (2 * d_polynomial p + 826) * 16 * H ^ 4 * N ^ 4 + 208539 * H ^ 4 * N ^ 4"
+    using H_ge_3 by simp
+  also have "... = 256 + (32 * d_polynomial p + 13216) * H ^ 4 * N ^ 4 + 208539 * H ^ 4 * N ^ 4"
+    by simp
+  also have "... = 256 + (32 * d_polynomial p + 221755) * H ^ 4 * N ^ 4"
+    by algebra
+  also have "... \<le> 256 * H ^ 4 + (32 * d_polynomial p + 221755) * H ^ 4 * N ^ 4"
+    using H_gr_2 by simp
+  also have "... \<le> 256 * H ^ 4 * N ^ 4 + (32 * d_polynomial p + 221755) * H ^ 4 * N ^ 4"
+    using N_ge_1 by simp
+  also have "... = (32 * d_polynomial p + 222011) * H ^ 4 * N ^ 4"
+    by algebra
+  finally show ?thesis .
+qed
+
+lemma tm31 [transforms_intros]: "transforms tm31 tps0 ttt31 tps31"
+  unfolding tm31_def
+proof (tform transforms_intros: tm_PHI5)
+  show "60 + 8 < length tps30"
+    using lentpsF tps30_def k by (simp_all only: length_list_update)
+  show "tps30 ! 1 = nlltape (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4)"
+    using tps30_def k lentpsF by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have *: "2 * n + 2 * p n + 3 = Suc m"
+    using m_def One_nat_def Suc_1 add_Suc_right numeral_3_eq_3 by presburger
+  have "tps30 ! 60 = (\<lfloor>Suc m\<rfloor>\<^sub>N, 1)"
+    using tps30_def k lentpsF by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps30 ! 60 = (\<lfloor>2 * n + 2 * p n + 3\<rfloor>\<^sub>N, 1)"
+    using * by presburger
+  have "tps30 ! 61 = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps30_def k lentpsF by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps30 ! (60 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps30 ! 62 = tpsF ! 62"
+    using tps30_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps30 ! (60 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsF k canrepr_0 by simp
+  have "tps30 ! 63 = tpsF ! 63"
+    using tps30_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps30 ! (60 + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsF k by simp
+  have "tps30 ! 64 = tpsF ! 64"
+    using tps30_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps30 ! (60 + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsF k by simp
+  have "tps30 ! 65 = tpsF ! 65"
+    using tps30_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps30 ! (60 + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsF k by simp
+  have "tps30 ! 66 = tpsF ! 66"
+    using tps30_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps30 ! (60 + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsF k by simp
+  have "tps30 ! 67 = tpsF ! 67"
+    using tps30_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps30 ! (60 + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsF k by simp
+  have "tps30 ! 68 = (\<lfloor>T' + Suc m\<rfloor>\<^sub>N, 1)"
+    using tps30_def k lentpsF by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then have "tps30 ! (60 + 8) = (\<lfloor>Suc m + 1 * T'\<rfloor>\<^sub>N, 1)"
+    by (metis add.commute add_One_commute nat_mult_1 numeral_plus_numeral semiring_norm(2) semiring_norm(4) semiring_norm(6) semiring_norm(7))
+  then show "tps30 ! (60 + 8) = (\<lfloor>2 * n + 2 * p n + 3 + T'\<rfloor>\<^sub>N, 1)"
+    using * nat_mult_1 by presburger
+  have "tps31 = tps30
+    [60 := (\<lfloor>Suc m + T'\<rfloor>\<^sub>N, 1),
+     1 := nlltape
+           (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+            formula_n \<Phi>\<^sub>5),
+     60 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+    unfolding tps31_def tps30_def by (simp only: list_update_swap list_update_overwrite)
+  then show "tps31 = tps30
+    [60 := (\<lfloor>2 * n + 2 * p n + 3 + T'\<rfloor>\<^sub>N, 1),
+     1 := nlltape
+           ((formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4) @
+            formula_n \<Phi>\<^sub>5),
+     60 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+    using * by (metis append_eq_appendI)
+  show "ttt31 = 256 + (2 * d_polynomial p + 826) * (H + m') ^ 4 + 3 * nlength m' + 13 * nlength H +
+      5627 * H ^ 4 * (3 + nlength (3 * H + m' * H))\<^sup>2 + 1875 * H ^ 4 +
+      15 * nlength n + 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * n * H))\<^sup>2 +
+      Suc n * (9 + 1897 * (H ^ 4 * (nlength (1 + 2 * n))\<^sup>2)) + 6 * nlength (2 * n + 3) +
+      10 * nlength m + Suc (p n) * (9 + 1897 * (H ^ 4 * (nlength (Suc m))\<^sup>2)) +
+      3 * nlength (Suc m) + 3 * max (nlength T') (nlength (Suc m)) +
+      Suc T' * (9 + 1891 * (H ^ 4 * (nlength (2 * n + 2 * p n + 3 + T'))\<^sup>2))"
+    using ttt31_def m_def One_nat_def Suc_1 add_Suc_right numeral_3_eq_3 by presburger
+qed
+
+definition "tpsG \<equiv> tpsF
+  [61 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   60 := (\<lfloor>Suc m\<rfloor>\<^sub>N, 1),
+   68 := (\<lfloor>T' + Suc m\<rfloor>\<^sub>N, 1),
+   60 := (\<lfloor>Suc m + T'\<rfloor>\<^sub>N, 1),
+   60 + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+lemma tpsG: "68 < j \<Longrightarrow> j < 110 \<Longrightarrow> tpsG ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsG_def tpsF by simp
+
+lemma lentpsG: "length tpsG = 110"
+  using lentpsF tpsG_def by simp
+
+lemma tps31: "tps31 = tpsG
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5)]"
+  unfolding tps31_def tpsG_def by (simp only: list_update_swap)
+
+definition "tps32 \<equiv> tpsG
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+         (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+          formula_n \<Phi>\<^sub>5),
+   69 := (\<lfloor>2\<rfloor>\<^sub>N, 1)]"
+
+lemma tm32 [transforms_intros]:
+  assumes "ttt = ttt31 + 14"
+  shows "transforms tm32 tps0 ttt tps32"
+  unfolding tm32_def
+proof (tform)
+  show "69 < length tps31"
+    using lentpsF tps31_def k by (simp_all only: length_list_update)
+  have "tps31 ! 69 = tpsF ! 69"
+    using tps31_def by (simp only: nth_list_update_neq)
+  then show "tps31 ! 69 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsF k canrepr_0 by simp
+  show "tps32 = tps31[69 := (\<lfloor>2\<rfloor>\<^sub>N, 1)]"
+    unfolding tps32_def tps31 by (simp only:)
+  show "ttt = ttt31 + (10 + 2 * nlength 0 + 2 * nlength 2)"
+    using assms nlength_2 by simp
+qed
+
+definition "tps33 \<equiv> tpsG
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+         (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+          formula_n \<Phi>\<^sub>5),
+   69 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   70 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm33 [transforms_intros]:
+  assumes "ttt = ttt31 + 24 + 2 * nlength H"
+  shows "transforms tm33 tps0 ttt tps33"
+  unfolding tm33_def
+proof (tform)
+  show "70 < length tps32"
+    using lentpsG tps32_def k by (simp_all only: length_list_update)
+  have "tps32 ! 70 = tpsG ! 70"
+    using tps32_def by (simp only: nth_list_update_neq)
+  then show "tps32 ! 70 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsG k canrepr_0 by simp
+  show "tps33 = tps32[70 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+    unfolding tps33_def tps32_def by (simp only:)
+  show "ttt = ttt31 + 14 + (10 + 2 * nlength 0 + 2 * nlength H)"
+    using assms by simp
+qed
+
+definition "tps34 \<equiv> tpsG
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+         (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+          formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6),
+   69 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   70 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   0 := (\<lfloor>xs\<rfloor>, Suc n),
+   69 := (\<lfloor>2 + 2 * n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm34 [transforms_intros]:
+  assumes "ttt = ttt31 + 24 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1)"
+  shows "transforms tm34 tps0 ttt tps34"
+  unfolding tm34_def
+proof (tform)
+  show "69 + 7 < length tps33"
+    using lentpsG tps33_def k by (simp_all only: length_list_update)
+  let ?nss = "(formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @
+   formula_n \<Phi>\<^sub>4 @ formula_n \<Phi>\<^sub>5)"
+  show "tps33 ! 1 = nlltape ?nss"
+    using tps33_def k lentpsG by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps33 ! 0 = tps1 ! 0"
+    unfolding tps33_def tpsG_def tpsF_def tpsE_def tpsD_def tpsC_def tpsB_def tpsA_def
+    by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps33 ! 0 = (\<lfloor>xs\<rfloor>, 1)"
+    using tps1' by simp
+  show "tps33 ! 69 = (\<lfloor>2\<rfloor>\<^sub>N, 1)"
+    using tps33_def k lentpsG by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps33 ! 70 = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps33_def k lentpsG by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps33 ! (69 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps33 ! 71 = tpsG ! 71"
+    using tps33_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps33 ! (69 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsG k canrepr_0 by simp
+  have "tps33 ! 72 = tpsG ! 72"
+    using tps33_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps33 ! (69 + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsG k by simp
+  have "tps33 ! 73 = tpsG ! 73"
+    using tps33_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps33 ! (69 + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsG k by simp
+  have "tps33 ! 74 = tpsG ! 74"
+    using tps33_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps33 ! (69 + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsG k by simp
+  have "tps33 ! 75 = tpsG ! 75"
+    using tps33_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps33 ! (69 + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsG k by simp
+  have "tps33 ! 76 = tpsG ! 76"
+    using tps33_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps33 ! (69 + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsG k by simp
+  show "tps34 = tps33
+    [0 := (\<lfloor>xs\<rfloor>, Suc n),
+     69 := (\<lfloor>2 + 2 * n\<rfloor>\<^sub>N, 1),
+     1 := nlltape (?nss @ formula_n \<Phi>\<^sub>6)]"
+    unfolding tps34_def tps33_def by (simp only: list_update_swap list_update_overwrite append_assoc)
+  show "ttt = ttt31 + 24 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1)"
+    using assms by simp
+qed
+
+definition "tpsH \<equiv> tpsG
+  [69 := (\<lfloor>2\<rfloor>\<^sub>N, 1),
+   70 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   0 := (\<lfloor>xs\<rfloor>, Suc n),
+   69 := (\<lfloor>2 + 2 * n\<rfloor>\<^sub>N, 1)]"
+
+lemma tpsH: "76 < j \<Longrightarrow> j < 110 \<Longrightarrow> tpsH ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsH_def tpsG by simp
+
+lemma lentpsH: "length tpsH = 110"
+  using lentpsG tpsH_def by simp
+
+lemma tps34: "tps34 = tpsH
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6)]"
+  unfolding tps34_def tpsH_def by (simp only: list_update_swap)
+
+definition "tps35 \<equiv> tpsH
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6),
+   77 := (\<lfloor>n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm35 [transforms_intros]:
+  assumes "ttt = ttt31 + 38 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 3 * nlength n"
+  shows "transforms tm35 tps0 ttt tps35"
+  unfolding tm35_def
+proof (tform)
+  show "11 < length tps34" "77 < length tps34"
+    using lentpsH tps34 k by (simp_all only: length_list_update)
+  show "tps34 ! 11 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    using tps34 k lentpsH by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps34 ! 77 = tpsH ! 77"
+    using tps34 by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps34 ! 77 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsH k canrepr_0 by simp
+  show "tps35 = tps34[77 := (\<lfloor>n\<rfloor>\<^sub>N, 1)]"
+    unfolding tps35_def tps34 by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt31 + 24 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) +
+      (14 + 3 * (nlength n + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps36 \<equiv> tpsH
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6),
+   77 := (\<lfloor>2 * n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm36 [transforms_intros]:
+  assumes "ttt = ttt31 + 43 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n"
+  shows "transforms tm36 tps0 ttt tps36"
+  unfolding tm36_def
+proof (tform time: assms)
+  show "77 < length tps35"
+    using lentpsH tps35_def k by (simp_all only: length_list_update)
+  show "tps35 ! 77 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    using tps35_def k lentpsH by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps36 = tps35[77 := (\<lfloor>2 * n\<rfloor>\<^sub>N, 1)]"
+    unfolding tps36_def tps35_def by (simp only: list_update_swap[of 77] list_update_overwrite)
+qed
+
+definition "tps37 \<equiv> tpsH
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6),
+   77 := (\<lfloor>2 * n + 4\<rfloor>\<^sub>N, 1)]"
+
+lemma tm37 [transforms_intros]:
+  assumes "ttt = ttt31 + 63 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+    8 * nlength (2 * n + 4)"
+  shows "transforms tm37 tps0 ttt tps37"
+  unfolding tm37_def
+proof (tform)
+  show "77 < length tps36"
+    using lentpsH tps36_def k by (simp_all only: length_list_update)
+  show "tps36 ! 77 = (\<lfloor>2 * n\<rfloor>\<^sub>N, 1)"
+    using tps36_def k lentpsH by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps37 = tps36[77 := (\<lfloor>2 * n + 4\<rfloor>\<^sub>N, 1)]"
+    unfolding tps37_def tps36_def by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt31 + 43 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) +
+      5 * nlength n + 4 * (5 + 2 * nlength (2 * n + 4))"
+    using assms by simp
+qed
+
+definition "tps38 \<equiv> tpsH
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6),
+   77 := (\<lfloor>2 * n + 4\<rfloor>\<^sub>N, 1),
+   78 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm38 [transforms_intros]:
+  assumes "ttt = ttt31 + 73 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) +
+    5 * nlength n + 8 * nlength (2 * n + 4) + 2 * nlength H"
+  shows "transforms tm38 tps0 ttt tps38"
+  unfolding tm38_def
+proof (tform)
+  show "78 < length tps37"
+    using lentpsH tps37_def k by (simp_all only: length_list_update)
+  have "tps37 ! 78 = tpsH ! 78"
+    using tps37_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps37 ! 78 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsH k canrepr_0 by simp
+  show "tps38 = tps37[78 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+    unfolding tps38_def tps37_def by (simp only: list_update_swap)
+  show "ttt = ttt31 + 63 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) +
+      5 * nlength n + 8 * nlength (2 * n + 4) + (10 + 2 * nlength 0 + 2 * nlength H)"
+    using assms by simp
+qed
+
+definition "tps39 \<equiv> tpsH
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6),
+   77 := (\<lfloor>2 * n + 4\<rfloor>\<^sub>N, 1),
+   78 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   83 := (\<lfloor>p n\<rfloor>\<^sub>N, 1)]"
+
+lemma tm39 [transforms_intros]:
+  assumes "ttt = ttt31 + 87 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+    8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n)"
+  shows "transforms tm39 tps0 ttt tps39"
+  unfolding tm39_def
+proof (tform)
+  show "15 < length tps38" "83 < length tps38"
+    using lentpsH tps38_def k by (simp_all only: length_list_update)
+  show "tps38 ! 15 = (\<lfloor>p n\<rfloor>\<^sub>N, 1)"
+    using tps38_def k lentpsH by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps38 ! 83 = tpsH ! 83"
+    using tps38_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps38 ! 83 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsH k canrepr_0 by simp
+  show "tps39 = tps38[83 := (\<lfloor>p n\<rfloor>\<^sub>N, 1)]"
+    unfolding tps39_def tps38_def by (simp only: list_update_swap)
+  show "ttt = ttt31 + 73 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+      8 * nlength (2 * n + 4) + 2 * nlength H + (14 + 3 * (nlength (p n) + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps40 \<equiv> tpsH
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7),
+   77 := (\<lfloor>2 * n + 4\<rfloor>\<^sub>N, 1),
+   78 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   83 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   77 := (\<lfloor>2 * n + 4 + 2 * p n\<rfloor>\<^sub>N, 1),
+   77 + 6 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm40 [transforms_intros]:
+  assumes "ttt = ttt31 + 88 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+    8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+    p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2"
+  shows "transforms tm40 tps0 ttt tps40"
+  unfolding tm40_def
+proof (tform)
+  show "77 + 6 < length tps39"
+    using lentpsH tps39_def k by (simp_all only: length_list_update)
+  let ?nss = "formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+      formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6"
+  show "tps39 ! 1 = nlltape ?nss"
+    using tps39_def k lentpsH by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps39 ! 77 = (\<lfloor>2 * n + 4\<rfloor>\<^sub>N, 1)"
+    using tps39_def k lentpsH by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps39 ! 78 = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps39_def k lentpsH by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps39 ! (77 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps39 ! 79 = tpsH ! 79"
+    using tps39_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps39 ! (77 + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsH k by simp
+  have "tps39 ! 80 = tpsH ! 80"
+    using tps39_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps39 ! (77 + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsH k by simp
+  have "tps39 ! 81 = tpsH ! 81"
+    using tps39_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps39 ! (77 + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsH k by simp
+  have "tps39 ! 82 = tpsH ! 82"
+    using tps39_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps39 ! (77 + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsH k by simp
+  have "tps39 ! 83 = (\<lfloor>p n\<rfloor>\<^sub>N, 1)"
+    using tps39_def k lentpsH by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps39 ! (77 + 6) = (\<lfloor>p n\<rfloor>\<^sub>N, 1)"
+    by simp
+  show "tps40 = tps39
+    [77 := (\<lfloor>2 * n + 4 + 2 * p n\<rfloor>\<^sub>N, 1),
+     77 + 6 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     1 := nlltape (?nss @ formula_n \<Phi>\<^sub>7)]"
+    unfolding tps40_def tps39_def by (simp only: list_update_swap list_update_overwrite append_assoc)
+  show "ttt = ttt31 + 87 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+      8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+      (p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 1)"
+    using assms by simp
+qed
+
+definition "tpsI \<equiv> tpsH
+  [77 := (\<lfloor>2 * n + 4\<rfloor>\<^sub>N, 1),
+   78 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   83 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   77 := (\<lfloor>2 * n + 4 + 2 * p n\<rfloor>\<^sub>N, 1),
+   77 + 6 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tpsI: "83 < j \<Longrightarrow> j < 110 \<Longrightarrow> tpsI ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsI_def tpsH by simp
+
+lemma lentpsI: "length tpsI = 110"
+  using lentpsH tpsI_def by simp
+
+lemma tps40: "tps40 = tpsI
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7)]"
+  unfolding tps40_def tpsI_def by (simp only: list_update_swap)
+
+definition "tps41 \<equiv> tpsI
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7),
+   84 := (\<lfloor>m'\<rfloor>\<^sub>N, 1)]"
+
+lemma tm41 [transforms_intros]:
+  assumes "ttt = ttt31 + 102 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+    8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+    p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 +
+    3 * nlength m'"
+  shows "transforms tm41 tps0 ttt tps41"
+  unfolding tm41_def
+proof (tform)
+  show "18 < length tps40" "84 < length tps40"
+    using lentpsI tps40 k by (simp_all only: length_list_update)
+  show "tps40 ! 18 = (\<lfloor>m'\<rfloor>\<^sub>N, 1)"
+    using tps40_def k lentpsH by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps40 ! 84 = tpsI ! 84"
+    using tps40 by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps40 ! 84 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsI k canrepr_0 by simp
+  show "tps41 = tps40[84 := (\<lfloor>m'\<rfloor>\<^sub>N, 1)]"
+    unfolding tps41_def tps40 by (simp only: list_update_swap)
+  show "ttt = ttt31 + 88 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+      8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+      p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 +
+      (14 + 3 * (nlength m' + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps42 \<equiv> tpsI
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7),
+   84 := (\<lfloor>T' + m'\<rfloor>\<^sub>N, 1)]"
+
+lemma tm42 [transforms_intros]:
+  assumes "ttt = ttt31 + 112 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+    8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+    p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 3 * nlength m' +
+    3 * max (nlength T') (nlength m')"
+  shows "transforms tm42 tps0 ttt tps42"
+  unfolding tm42_def
+proof (tform)
+  show "17 < length tps41" "84 < length tps41"
+    using lentpsI tps41_def k by (simp_all only: length_list_update)
+  show "tps41 ! 17 = (\<lfloor>T'\<rfloor>\<^sub>N, 1)"
+    using tps41_def k lentpsI by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps41 ! 84 = (\<lfloor>m'\<rfloor>\<^sub>N, 1)"
+    using tps41_def k lentpsI by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps42 = tps41[84 := (\<lfloor>T' + m'\<rfloor>\<^sub>N, 1)]"
+    unfolding tps42_def tps41_def by (simp only: list_update_overwrite)
+  show "ttt = ttt31 + 102 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+      8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+      p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 +
+      3 * nlength m' + (3 * max (nlength T') (nlength m') + 10)"
+    using assms by simp
+qed
+
+definition "tps43 \<equiv> tpsI
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7),
+   84 := (\<lfloor>2 * T' + m'\<rfloor>\<^sub>N, 1)]"
+
+lemma tm43 [transforms_intros]:
+  assumes "ttt = ttt31 + 122 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+    8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+    p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 3 * nlength m' +
+    3 * max (nlength T') (nlength m') +
+    3 * max (nlength T') (nlength (T' + m'))"
+  shows "transforms tm43 tps0 ttt tps43"
+  unfolding tm43_def
+proof (tform)
+  show "17 < length tps42" "84 < length tps42"
+    using lentpsI tps42_def k by (simp_all only: length_list_update)
+  show "tps42 ! 17 = (\<lfloor>T'\<rfloor>\<^sub>N, 1)"
+    using tps42_def k lentpsI by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps42 ! 84 = (\<lfloor>T' + m'\<rfloor>\<^sub>N, 1)"
+    using tps42_def k lentpsI by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps43 = tps42[84 := (\<lfloor>2 * T' + m'\<rfloor>\<^sub>N, 1)]"
+    unfolding tps43_def tps42_def by (simp only: list_update_overwrite)
+  then show "tps43 = tps42[84 := (\<lfloor>T' + (T' + m')\<rfloor>\<^sub>N, 1)]"
+    by (simp add: left_add_twice)
+  show "ttt = ttt31 + 112 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+      8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+      p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 3 * nlength m' +
+      3 * max (nlength T') (nlength m') +
+      (3 * max (nlength T') (nlength (T' + m')) + 10)"
+    using assms by simp
+qed
+
+definition "tps44 \<equiv> tpsI
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7),
+   84 := (\<lfloor>3 * T' + m'\<rfloor>\<^sub>N, 1)]"
+
+lemma tm44 [transforms_intros]:
+  assumes "ttt = ttt31 + 132 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+    8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+    p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 3 * nlength m' +
+    3 * max (nlength T') (nlength m') +
+    3 * max (nlength T') (nlength (T' + m')) +
+    3 * max (nlength T') (nlength (2 * T' + m'))"
+  shows "transforms tm44 tps0 ttt tps44"
+  unfolding tm44_def
+proof (tform)
+  show "17 < length tps43" "84 < length tps43"
+    using lentpsI tps43_def k by (simp_all only: length_list_update)
+  show "tps43 ! 17 = (\<lfloor>T'\<rfloor>\<^sub>N, 1)"
+    using tps43_def k lentpsI by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps43 ! 84 = (\<lfloor>2 * T' + m'\<rfloor>\<^sub>N, 1)"
+    using tps43_def k lentpsI by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps44 = tps43[84 := (\<lfloor>3 * T' + m'\<rfloor>\<^sub>N, 1)]"
+    unfolding tps44_def tps43_def by (simp only: list_update_overwrite)
+  then show "tps44 = tps43[84 := (\<lfloor>T' + (2 * T' + m')\<rfloor>\<^sub>N, 1)]"
+    by (simp add: left_add_twice)
+  show "ttt = ttt31 + 122 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+      8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+      p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 3 * nlength m' +
+      3 * max (nlength T') (nlength m') +
+      3 * max (nlength T') (nlength (T' + m')) +
+      (3 * max (nlength T') (nlength (2 * T' + m')) + 10)"
+    using assms by simp
+qed
+
+definition "tps45 \<equiv> tpsI
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7),
+   84 := (\<lfloor>1 + 3 * T' + m'\<rfloor>\<^sub>N, 1)]"
+
+lemma tm45 [transforms_intros]:
+  assumes "ttt = ttt31 + 137 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+    8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+    p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 3 * nlength m' +
+    3 * max (nlength T') (nlength m') +
+    3 * max (nlength T') (nlength (T' + m')) +
+    3 * max (nlength T') (nlength (2 * T' + m')) +
+    2 * nlength (3 * T' + m')"
+  shows "transforms tm45 tps0 ttt tps45"
+  unfolding tm45_def
+proof (tform)
+  show "84 < length tps44"
+    using lentpsI tps44_def k by (simp_all only: length_list_update)
+  show "tps44 ! 84 = (\<lfloor>3 * T' + m'\<rfloor>\<^sub>N, 1)"
+    using tps44_def k lentpsI by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps45 = tps44[84 := (\<lfloor>1 + 3 * T' + m'\<rfloor>\<^sub>N, 1)]"
+    unfolding tps45_def tps44_def by (simp only: list_update_overwrite)
+  then show "tps45 = tps44[84 := (\<lfloor>Suc (3 * T' + m')\<rfloor>\<^sub>N, 1)]"
+    by simp
+  show "ttt = ttt31 + 132 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+      8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+      p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 3 * nlength m' +
+      3 * max (nlength T') (nlength m') +
+      3 * max (nlength T') (nlength (T' + m')) +
+      3 * max (nlength T') (nlength (2 * T' + m')) +
+      (5 + 2 * nlength (3 * T' + m'))"
+    using assms by simp
+qed
+
+definition "tps46 \<equiv> tpsI
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7),
+   84 := (\<lfloor>1 + 3 * T' + m'\<rfloor>\<^sub>N, 1),
+   85 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm46 [transforms_intros]:
+  assumes "ttt = ttt31 + 147 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+    8 * nlength (2 * n + 4) + 4 * nlength H + 3 * nlength (p n) +
+    p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 3 * nlength m' +
+    3 * max (nlength T') (nlength m') +
+    3 * max (nlength T') (nlength (T' + m')) +
+    3 * max (nlength T') (nlength (2 * T' + m')) +
+    2 * nlength (3 * T' + m')"
+  shows "transforms tm46 tps0 ttt tps46"
+  unfolding tm46_def
+proof (tform)
+  show "85 < length tps45"
+    using lentpsI tps45_def k by (simp_all only: length_list_update)
+  have "tps45 ! 85 = tpsI ! 85"
+    using tps45_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps45 ! 85 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsI k canrepr_0 by simp
+  show "tps46 = tps45[85 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+    unfolding tps46_def tps45_def by (simp only:)
+  show "ttt = ttt31 + 137 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+      8 * nlength (2 * n + 4) + 2 * nlength H + 3 * nlength (p n) +
+      p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 3 * nlength m' +
+      3 * max (nlength T') (nlength m') +
+      3 * max (nlength T') (nlength (T' + m')) +
+      3 * max (nlength T') (nlength (2 * T' + m')) +
+      2 * nlength (3 * T' + m') +
+      (10 + 2 * nlength 0 + 2 * nlength H)"
+    using assms by simp
+qed
+
+definition "tps47 \<equiv> tpsI
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7 @ formula_n \<Phi>\<^sub>8),
+   84 := (\<lfloor>1 + 3 * T' + m'\<rfloor>\<^sub>N, 1),
+   85 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   84 + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   84 + 6 := (\<lfloor>formula_n \<Phi>\<^sub>8\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+definition "ttt47 \<equiv> ttt31 + 166 +
+    6 * nlength H +
+    133650 * H ^ 6 * n ^ 3 +
+    5 * nlength n +
+    8 * nlength (2 * n + 4) +
+    3 * nlength (p n) +
+    p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 +
+    3 * nlength m' +
+    3 * max (nlength T') (nlength m') +
+    3 * max (nlength T') (nlength (T' + m')) +
+    3 * max (nlength T') (nlength (2 * T' + m')) +
+    2 * nlength (3 * T' + m') +
+    1861 * H ^ 4 * (nlength (Suc (1 + 3 * T' + m')))\<^sup>2"
+
+lemma ttt47: "ttt47 \<le> (32 * d_polynomial p + 364343) * H ^ 6 * N ^ 4"
+proof -
+  have nlength_le_GN: "y \<le> N \<Longrightarrow> nlength y \<le> H ^ 6 * N ^ 3" for y
+  proof -
+    assume "y \<le> N "
+    then have "nlength y \<le> N ^ 3"
+      using nlength_le_n linear_le_pow H_ge_3 by (meson dual_order.trans zero_less_numeral)
+    also have "... \<le> H ^ 6 * N ^ 3"
+      using H_gr_2 by simp
+    finally show ?thesis .
+  qed
+
+  have h: "6 * nlength H \<le> 6 * H ^ 6 * N ^ 3"
+    using nlength_le_GN[OF H_le_N] by simp
+  have i: "5 * nlength n \<le> 5 * H ^ 6 * N ^ 3"
+    using nlength_le_GN[OF n_le_N] by simp
+  have j: "8 * nlength (2 * n + 4) \<le> 8 * H ^ 6 * N ^ 3"
+  proof -
+    have "2 * n + 4 \<le> 2 * n + H * 3"
+      using H_ge_3 by simp
+    also have "... \<le> H * 2 * n + H * 3"
+      using H_ge_3 by simp
+    also have "... = H * (2 * n + 3)"
+      by algebra
+    also have "... \<le> N "
+      using N_eq by simp
+    finally have "2 * n + 4 \<le> N " .
+    then have "8 * nlength (2 * n + 4) \<le> 8 * nlength N"
+      using nlength_mono by simp
+    also have "... \<le> 8 * N "
+      using nlength_le_n by simp
+    also have "... \<le> 8 * H ^ 6 * N "
+      using H_ge_3 by simp
+    also have "... \<le> 8 * H ^ 6 * N ^ 3"
+      using linear_le_pow by simp
+    finally show ?thesis .
+  qed
+  have k: "3 * nlength (p n) \<le> 3 * H ^ 6 * N ^ 3"
+    using nlength_le_GN[OF le_N] by simp
+  have l: "3 * nlength m' \<le> 3 * H ^ 6 * N ^ 3"
+    using nlength_le_GN[OF le_N] m'_def by simp
+  have g: "3 * max (nlength T') (nlength m') \<le> 3 * H ^ 6 * N ^ 3"
+  proof -
+    have "m' \<le> N "
+      using le_N m'_def by simp
+    moreover have "T' \<le> N "
+      using le_N by simp
+    ultimately have "max (nlength T') (nlength m') \<le> nlength N"
+      using max_nlength nlength_mono by simp
+    then have "3 * max (nlength T') (nlength m') \<le> 3 * N "
+      using nlength_le_n by (meson le_trans mult_le_mono2)
+    also have "... \<le> 3 * H ^ 6 * N "
+      using H_ge_3 by simp
+    also have "... \<le> 3 * H ^ 6 * N ^ 3"
+      using linear_le_pow by simp
+    finally show ?thesis .
+  qed
+  have f: "3 * max (nlength T') (nlength (T' + m')) \<le> 6 * H ^ 6 * N ^ 3"
+  proof -
+    have "T' + m' \<le> N + N "
+      using N_eq m'_def H_gr_2 add_le_mono le_N less_or_eq_imp_le mult_le_mono trans_le_add2
+      by presburger
+    then have "T' + m' \<le> 2 * N "
+      by simp
+    moreover have "T' \<le> N "
+      using le_N by simp
+    ultimately have "max (nlength T') (nlength (T' + m')) \<le> nlength (2 * N)"
+      using max_nlength nlength_mono by simp
+    then have "3 * max (nlength T') (nlength (T' + m')) \<le> 3 * (2 * N)"
+      using nlength_le_n by (meson le_trans mult_le_mono2)
+    also have "... = 6 * N "
+      by simp
+    also have "... \<le> 6 * H ^ 6 * N "
+      using H_ge_3 by simp
+    also have "... \<le> 6 * H ^ 6 * N ^ 3"
+      using linear_le_pow by simp
+    finally show ?thesis .
+  qed
+  have e: "3 * max (nlength T') (nlength (2 * T' + m')) \<le> 6 * H ^ 6 * N ^ 3"
+  proof -
+    have "2 * T' + m' \<le> N + N "
+      using N_eq m'_def H_gr_2 add_le_mono le_N less_or_eq_imp_le mult_le_mono trans_le_add2
+      by presburger
+    then have "2 * T' + m' \<le> 2 * N "
+      by simp
+    moreover have "T' \<le> N "
+      using le_N by simp
+    ultimately have "max (nlength T') (nlength (2 * T' + m')) \<le> nlength (2 * N)"
+      using max_nlength nlength_mono by simp
+    then have "3 * max (nlength T') (nlength (2 * T' + m')) \<le> 3 * (2 * N)"
+      using nlength_le_n by (meson le_trans mult_le_mono2)
+    also have "... = 6 * N "
+      by simp
+    also have "... \<le> 6 * H ^ 6 * N "
+      using H_ge_3 by simp
+    also have "... \<le> 6 * H ^ 6 * N ^ 3"
+      using linear_le_pow by simp
+    finally show ?thesis .
+  qed
+  have d: "2 * nlength (3 * T' + m') \<le> 4 * H ^ 6 * N ^ 3"
+  proof -
+    have "3 * T' + m' \<le> N + N "
+      using N_eq H_ge_3 m'_def by (metis add_leE add_le_mono le_N le_refl mult_le_mono)
+    then have "3 * T' + m' \<le> 2 * N "
+      by simp
+    then have "nlength (3 * T' + m') \<le> 2 * N "
+      using nlength_le_n le_trans by blast
+    then have "2 * nlength (3 * T' + m') \<le> 4 * N "
+      by simp
+    also have "... \<le> 4 * H ^ 6 * N "
+      using H_ge_3 by simp
+    also have "... \<le> 4 * H ^ 6 * N ^ 3"
+      using linear_le_pow by simp
+    finally show ?thesis .
+  qed
+  have c: "6 * nlength H \<le> 6 * H ^ 6 * N ^ 3"
+  proof -
+    have "6 * nlength H \<le> 6 * H"
+      using nlength_le_n by simp
+    also have "... \<le> 6 * H ^ 6"
+      using linear_le_pow by simp
+    also have "... \<le> 6 * H ^ 6 * N ^ 3"
+      using N_ge_1 by simp
+    finally show ?thesis .
+  qed
+  have a: "p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 \<le> 1028 * H ^ 6 * N ^ 3"
+  proof -
+    have "nlength (2 * n + 4 + 2 * p n) = nlength (2 * (n + 2 + p n))"
+      by (metis distrib_left_numeral mult_2_right numeral_Bit0)
+    also have "... \<le> Suc (nlength (n + 2 + p n))"
+      using nlength_times2 by blast
+    also have "... \<le> Suc (n + 2 + p n)"
+      by (simp add: nlength_le_n)
+    also have "... \<le> N "
+      using le_N by simp
+    finally have "nlength (2 * n + 4 + 2 * p n) \<le> N " .
+    then have "(nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 \<le> (N + nlength H) ^ 2"
+      by simp
+    also have "... \<le> (N + N) ^ 2"
+      using H_le_N nlength_le_n by (meson add_left_mono le_trans power2_nat_le_eq_le)
+    also have "... = (2 * N) ^ 2"
+      by algebra
+    also have "... = 4 * N ^ 2"
+      by simp
+    finally have "(nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 \<le> 4 * N ^ 2" .
+    then have "p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 \<le> p n * 257 * H * (4 * N ^ 2)"
+      by simp
+    also have "... \<le> N * 257 * H * (4 * N ^ 2)"
+      using le_N by simp
+    also have "... = 1028 * H * N ^ 3"
+      by algebra
+    also have "... \<le> 1028 * H ^ 6 * N ^ 3"
+      using linear_le_pow by simp
+    finally show ?thesis .
+  qed
+  have b: "1861 * H ^ 4 * (nlength (Suc (1 + 3 * T' + m')))\<^sup>2 \<le> 7444 * H ^ 6 * N ^ 3"
+  proof -
+    have "Suc (1 + 3 * T' + m') \<le> 3 * (2 * n + 2 * p n + 3 + T') + m' "
+      by simp
+    also have "... \<le> N + N "
+      using N_eq H_ge_3 m'_def add_le_mono le_N le_refl mult_le_mono1 by presburger
+    also have "... \<le> 2 * N "
+      by simp
+    finally have "Suc (1 + 3 * T' + m') \<le> 2 * N " .
+    then have "nlength (Suc (1 + 3 * T' + m')) \<le> 2 * N "
+      using nlength_le_n le_trans by blast
+    then have "(nlength (Suc (1 + 3 * T' + m'))) ^ 2 \<le> (2 * N) ^ 2"
+      using power2_nat_le_eq_le by presburger
+    then have "(nlength (Suc (1 + 3 * T' + m'))) ^ 2 \<le> 4 * N ^ 2"
+      by simp
+    then have "1861 * H ^ 4 * (nlength (Suc (1 + 3 * T' + m')))\<^sup>2 \<le> 1861 * H ^ 4 * (4 * N ^ 2)"
+      by simp
+    also have "... = 7444 * H ^ 4 * N ^ 2"
+      by simp
+    also have "... \<le> 7444 * H ^ 6 * N ^ 2"
+      using pow_mono' by simp
+    also have "... \<le> 7444 * H ^ 6 * N ^ 3"
+      using pow_mono' by simp
+    finally show ?thesis .
+  qed
+  have m: "133650 * H ^ 6 * n ^ 3 \<le> 133650 * H ^ 6 * N ^ 3"
+    using n_le_N by simp
+
+  have "ttt47 \<le> ttt31 + 166 +
+      6 * H ^ 6 * N ^ 3 + 133650 * H ^ 6 * N ^ 3 + 5 * H ^ 6 * N ^ 3 +
+      8 * H ^ 6 * N ^ 3 + 3 * H ^ 6 * N ^ 3 + 1028 * H ^ 6 * N ^ 3 +
+      3 * H ^ 6 * N ^ 3 + 3 * H ^ 6 * N ^ 3 + 6 * H ^ 6 * N ^ 3 +
+      6 * H ^ 6 * N ^ 3 + 4 * H ^ 6 * N ^ 3 + 7444 * H ^ 6 * N ^ 3"
+    using ttt47_def a b c d e f g h i j k l m by linarith
+  also have "... = ttt31 + 166 + 142166 * H ^ 6 * N ^ 3"
+    by simp
+  also have "... \<le> ttt31 + 166 * H ^ 6 + 142166 * H ^ 6 * N ^ 3"
+    using H_ge_3 by simp
+  also have "... \<le> ttt31 + 166 * H ^ 6 * N ^ 3 + 142166 * H ^ 6 * N ^ 3"
+    using N_ge_1 by simp
+  also have "... = ttt31 + 142332 * H ^ 6 * N ^ 3"
+    by simp
+  also have "... \<le> ttt31 + 142332 * H ^ 6 * N ^ 4"
+    using pow_mono' by simp
+  also have "... \<le> (32 * d_polynomial p + 222011) * H ^ 4 * N ^ 4 + 142332 * H ^ 6 * N ^ 4"
+    using ttt31 by simp
+  also have "... \<le> (32 * d_polynomial p + 222011) * H ^ 6 * N ^ 4 + 142332 * H ^ 6 * N ^ 4"
+    using pow_mono' by simp
+  also have "... = (32 * d_polynomial p + 364343) * H ^ 6 * N ^ 4"
+    by algebra
+  finally show ?thesis .
+qed
+
+lemma tm47 [transforms_intros]: "transforms tm47 tps0 ttt47 tps47"
+  unfolding tm47_def
+proof (tform)
+  show "84 + 7 < length tps46"
+    using lentpsI tps46_def k by (simp_all only: length_list_update)
+  let ?nss = "formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7"
+  show "tps46 ! 1 = nlltape ?nss"
+    using tps46_def k lentpsI by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps46 ! 84 = (\<lfloor>1 + 3 * T' + m'\<rfloor>\<^sub>N, 1)"
+    using tps46_def k lentpsI by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps46 ! 85 = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps46_def k lentpsI by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps46 ! (84 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps46 ! 86 = tpsI ! 86"
+    using tps46_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps46 ! (84 + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsI k by simp
+  have "tps46 ! 87 = tpsI ! 87"
+    using tps46_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps46 ! (84 + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsI k by simp
+  have "tps46 ! 88 = tpsI ! 88"
+    using tps46_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps46 ! (84 + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsI k by simp
+  have "tps46 ! 89 = tpsI ! 89"
+    using tps46_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps46 ! (84 + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsI k by simp
+  have "tps46 ! 90 = tpsI ! 90"
+    using tps46_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps46 ! (84 + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsI k by simp
+  have "tps46 ! 91 = tpsI ! 91"
+    using tps46_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps46 ! (84 + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsI k by simp
+  show "tps47 = tps46
+      [1 := nlltape (?nss @ formula_n \<Phi>\<^sub>8),
+       84 + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+       84 + 6 := (\<lfloor>formula_n \<Phi>\<^sub>8\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+    unfolding tps47_def tps46_def by (simp only: list_update_swap list_update_overwrite append_assoc)
+  show "ttt47 = ttt31 + 147 + 2 * nlength H + (133650 * H ^ 6 * n ^ 3 + 1) + 5 * nlength n +
+      8 * nlength (2 * n + 4) + 4 * nlength H + 3 * nlength (p n) +
+      p n * 257 * H * (nlength (2 * n + 4 + 2 * p n) + nlength H)\<^sup>2 + 3 * nlength m' +
+      3 * max (nlength T') (nlength m') +
+      3 * max (nlength T') (nlength (T' + m')) +
+      3 * max (nlength T') (nlength (2 * T' + m')) +
+      2 * nlength (3 * T' + m') +
+      (18 + 1861 * H ^ 4 * (nlength (Suc (1 + 3 * T' + m')))\<^sup>2)"
+    using ttt47_def by simp
+qed
+
+definition "tpsJ \<equiv> tpsI
+  [84 := (\<lfloor>1 + 3 * T' + m'\<rfloor>\<^sub>N, 1),
+   85 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   84 + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   84 + 6 := (\<lfloor>formula_n \<Phi>\<^sub>8\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tpsJ: "90 < j \<Longrightarrow> j < 110 \<Longrightarrow> tpsJ ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsJ_def tpsI by simp
+
+lemma lentpsJ: "length tpsJ = 110"
+  using lentpsI tpsJ_def by simp
+
+lemma tps47: "tps47 = tpsJ
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7 @ formula_n \<Phi>\<^sub>8)]"
+  unfolding tps47_def tpsJ_def by (simp only: list_update_swap)
+
+definition "tps48 \<equiv> tpsJ
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7 @ formula_n \<Phi>\<^sub>8),
+   91 := (\<lfloor>N\<rfloor>\<^sub>N, 1)]"
+
+lemma tm48 [transforms_intros]:
+  assumes "ttt = ttt47 + 14 + 3 * nlength N"
+  shows "transforms tm48 tps0 ttt tps48"
+  unfolding tm48_def
+proof (tform)
+  show "20 < length tps47" "91 < length tps47"
+    using lentpsJ tps47 k by (simp_all only: length_list_update)
+  have "tps47 ! 20 = (\<lfloor>m' * H\<rfloor>\<^sub>N, 1)"
+    using tps47 k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps47 ! 20 = (\<lfloor>N\<rfloor>\<^sub>N, 1)"
+    using m' by simp
+  have "tps47 ! 91 = tpsJ ! 91"
+    using tps47 by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps47 ! 91 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsJ k canrepr_0 by simp
+  show "tps48 = tps47[91 := (\<lfloor>N\<rfloor>\<^sub>N, 1)]"
+    unfolding tps48_def tps47 by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt47 + (14 + 3 * (nlength N + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps49 \<equiv> tpsJ
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7 @ formula_n \<Phi>\<^sub>8),
+   91 := (\<lfloor>N\<rfloor>\<^sub>N, 1),
+   92 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+
+lemma tm49 [transforms_intros]:
+  assumes "ttt = ttt47 + 24 + 3 * nlength N + 2 * nlength H"
+  shows "transforms tm49 tps0 ttt tps49"
+  unfolding tm49_def
+proof (tform)
+  show "92 < length tps48"
+    using lentpsJ tps48_def k by (simp_all only: length_list_update)
+  have "tps48 ! 92 = tpsJ ! 92"
+    using tps48_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps48 ! 92 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsJ k canrepr_0 by simp
+  show "tps49 = tps48[92 := (\<lfloor>H\<rfloor>\<^sub>N, 1)]"
+    unfolding tps49_def tps48_def by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt47 + 14 + 3 * nlength N + (10 + 2 * nlength 0 + 2 * nlength H)"
+    using assms by simp
+qed
+
+definition "tps50 \<equiv> tpsJ
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7 @ formula_n \<Phi>\<^sub>8),
+   91 := (\<lfloor>N\<rfloor>\<^sub>N, 1),
+   92 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   93 := (\<lfloor>Z\<rfloor>\<^sub>N, 1)]"
+
+lemma tm50 [transforms_intros]:
+  assumes "ttt = ttt47 + 34 + 3 * nlength N + 2 * nlength H + 2 * nlength Z"
+  shows "transforms tm50 tps0 ttt tps50"
+  unfolding tm50_def
+proof (tform)
+  show "93 < length tps49"
+    using lentpsJ tps49_def k by (simp_all only: length_list_update)
+  have "tps49 ! 93 = tpsJ ! 93"
+    using tps49_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps49 ! 93 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsJ k canrepr_0 by simp
+  show "tps50 = tps49[93 := (\<lfloor>Z\<rfloor>\<^sub>N, 1)]"
+    unfolding tps50_def tps49_def by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt47 + 24 + 3 * nlength N + 2 * nlength H + (10 + 2 * nlength 0 + 2 * nlength Z)"
+    using assms by simp
+qed
+
+definition "tps51 \<equiv> tpsJ
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7 @ formula_n \<Phi>\<^sub>8),
+   91 := (\<lfloor>N\<rfloor>\<^sub>N, 1),
+   92 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   93 := (\<lfloor>Z\<rfloor>\<^sub>N, 1),
+   94 := (\<lfloor>T'\<rfloor>\<^sub>N, 1)]"
+
+lemma tm51 [transforms_intros]:
+  assumes "ttt = ttt47 + 48 + 3 * nlength N + 2 * nlength H + 2 * nlength Z + 3 * nlength T'"
+  shows "transforms tm51 tps0 ttt tps51"
+  unfolding tm51_def
+proof (tform)
+  show "17 < length tps50" "94 < length tps50"
+    using lentpsJ tps50_def k by (simp_all only: length_list_update)
+  show "tps50 ! 17 = (\<lfloor>T'\<rfloor>\<^sub>N, 1)"
+    using tps50_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps50 ! 94 = tpsJ ! 94"
+    using tps50_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps50 ! 94 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsJ k canrepr_0 by simp
+  show "tps51 = tps50[94 := (\<lfloor>T'\<rfloor>\<^sub>N, 1)]"
+    unfolding tps51_def tps50_def by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt47 + 34 + 3 * nlength N + 2 * nlength H + 2 * nlength Z +
+      (14 + 3 * (nlength T' + nlength 0))"
+    using assms by simp
+qed
+
+definition "tps52 \<equiv> tpsJ
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7 @ formula_n \<Phi>\<^sub>8),
+   91 := (\<lfloor>N\<rfloor>\<^sub>N, 1),
+   92 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   93 := (\<lfloor>Z\<rfloor>\<^sub>N, 1),
+   94 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   95 := (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm52 [transforms_intros]:
+  assumes "ttt = ttt47 + 58 + 3 * nlength N + 2 * nlength H + 2 * nlength Z +
+    3 * nlength T' + 2 * nlllength (formula_n \<psi>)"
+  shows "transforms tm52 tps0 ttt tps52"
+  unfolding tm52_def
+proof (tform)
+  show "95 < length tps51"
+    using lentpsJ tps51_def k by (simp_all only: length_list_update)
+  have "tps51 ! 95 = tpsJ ! 95"
+    using tps51_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then have *: "tps51 ! 95 = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsJ k by simp
+  then show "tps51 ::: 95 = \<lfloor>[]\<rfloor>"
+    by simp
+  show "clean_tape (tps51 ! 95)"
+    using * by simp
+  show "proper_symbols []"
+    by simp
+  show "proper_symbols (numlistlist (formula_n \<psi>))"
+    using proper_symbols_numlistlist by simp
+  have "tps52 = tps51[95 := (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+    unfolding tps52_def tps51_def by (simp only: list_update_swap list_update_overwrite)
+  then show "tps52 = tps51[95 := (\<lfloor>numlistlist (formula_n \<psi>)\<rfloor>, 1)]"
+    using nllcontents_def by simp
+  show "ttt = ttt47 + 48 + 3 * nlength N + 2 * nlength H + 2 * nlength Z +
+      3 * nlength T' + (8 + tps51 :#: 95 + 2 * length [] +
+      Suc (2 * length (numlistlist (formula_n \<psi>))))"
+    using assms * nlllength_def by simp
+qed
+
+definition "tps53 \<equiv> tpsJ
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7 @ formula_n \<Phi>\<^sub>8),
+   91 := (\<lfloor>N\<rfloor>\<^sub>N, 1),
+   92 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   93 := (\<lfloor>Z\<rfloor>\<^sub>N, 1),
+   94 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   95 := (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   96 := (\<lfloor>formula_n \<psi>'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm53 [transforms_intros]:
+  assumes "ttt = ttt47 + 68 + 3 * nlength N + 2 * nlength H + 2 * nlength Z + 3 * nlength T' +
+    2 * nlllength (formula_n \<psi>) + 2 * length (numlistlist (formula_n \<psi>'))"
+  shows "transforms tm53 tps0 ttt tps53"
+  unfolding tm53_def
+proof (tform)
+  show "96 < length tps52"
+    using lentpsJ tps52_def k by (simp_all only: length_list_update)
+  have "tps52 ! 96 = tpsJ ! 96"
+    using tps52_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then have *: "tps52 ! 96 = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsJ k by simp
+  then show "tps52 ::: 96 = \<lfloor>[]\<rfloor>"
+    by simp
+  show "clean_tape (tps52 ! 96)"
+    using * by simp
+  show "proper_symbols []"
+    by simp
+  show "proper_symbols (numlistlist (formula_n \<psi>'))"
+    using proper_symbols_numlistlist by simp
+  have "tps53 = tps52[96 := (\<lfloor>formula_n \<psi>'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+    unfolding tps53_def tps52_def by (simp only: list_update_swap list_update_overwrite)
+  then show "tps53 = tps52[96 := (\<lfloor>numlistlist (formula_n \<psi>')\<rfloor>, 1)]"
+    using nllcontents_def by simp
+  show "ttt = ttt47 + 58 + 3 * nlength N + 2 * nlength H + 2 * nlength Z + 3 * nlength T' +
+      2 * nlllength (formula_n \<psi>) +
+      (8 + tps52 :#: 96 + 2 * length [] + Suc (2 * length (numlistlist (formula_n \<psi>'))))"
+    using assms * nlllength_def by simp
+qed
+
+definition "tps54 \<equiv> tpsJ
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape
+      (formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7 @ formula_n \<Phi>\<^sub>8),
+   91 := (\<lfloor>N\<rfloor>\<^sub>N, 1),
+   92 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   93 := (\<lfloor>Z\<rfloor>\<^sub>N, 1),
+   94 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   95 := (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   96 := (\<lfloor>formula_n \<psi>'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   97 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm54 [transforms_intros]:
+  assumes "ttt = ttt47 + 80 + 3 * nlength N + 2 * nlength H + 2 * nlength Z + 3 * nlength T' +
+    2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>')"
+  shows "transforms tm54 tps0 ttt tps54"
+  unfolding tm54_def
+proof (tform)
+  show "97 < length tps53"
+    using lentpsJ tps53_def k by (simp_all only: length_list_update)
+  have "tps53 ! 97 = tpsJ ! 97"
+    using tps53_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then show "tps53 ! 97 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsJ k canrepr_0 by simp
+  show "tps54 = tps53[97 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+    unfolding tps54_def tps53_def by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt47 + 68 + 3 * nlength N + 2 * nlength H + 2 * nlength Z + 3 * nlength T' +
+      2 * nlllength (formula_n \<psi>) + 2 * length (numlistlist (formula_n \<psi>')) +
+      (10 + 2 * nlength 0 + 2 * nlength 1)"
+    using assms canrepr_1 nlllength_def by simp
+qed
+
+definition "tps55 \<equiv> tpsJ
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n PHI),
+   91 := (\<lfloor>N\<rfloor>\<^sub>N, 1),
+   92 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   93 := (\<lfloor>Z\<rfloor>\<^sub>N, 1),
+   94 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   95 := (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   96 := (\<lfloor>formula_n \<psi>'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   97 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   91 + 6 := (\<lfloor>Suc T'\<rfloor>\<^sub>N, 1),
+   91 + 3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+definition "ttt55 \<equiv> ttt47 + 80 + 3 * nlength N + 2 * nlength H + 2 * nlength Z +
+  3 * nlength T' + 2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') +
+  16114767 * 2 ^ (16 * Z) * N ^ 7"
+
+lemma ttt55: "ttt55 \<le> ttt47 + 2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') +
+      16114857 * 2 ^ (16 * Z) * N ^ 7"
+proof -
+  have nlength_le_ZN: "y \<le> N \<Longrightarrow> nlength y \<le> 2 ^ (16*Z)* N ^ 7" for y
+  proof -
+    assume "y \<le> N "
+    then have "nlength y \<le> N ^ 7"
+      using nlength_le_n linear_le_pow H_ge_3 by (meson dual_order.trans zero_less_numeral)
+    also have "... \<le> 2 ^ (16*Z) * N ^ 7"
+      by simp
+    finally show ?thesis .
+  qed
+
+  have "3 * nlength N \<le> 3 * 2 ^ (16*Z) * N ^ 7"
+    using nlength_le_ZN by simp
+  moreover have "2 * nlength H \<le> 2 * 2 ^ (16*Z) * N ^ 7"
+    using nlength_le_ZN[OF H_le_N] by simp
+  moreover have "2 * nlength Z \<le> 2 * 2 ^ (16*Z) * N ^ 7"
+  proof -
+    have "Z \<le> N "
+      using N_eq Z_def by simp
+    then show ?thesis
+      using nlength_le_ZN by simp
+  qed
+  moreover have "3 * nlength T' \<le> 3 * 2 ^ (16*Z) * N ^ 7"
+    using nlength_le_ZN[OF le_N] by simp
+  moreover have "80 \<le> 80 * 2 ^ (16*Z) * N ^ 7"
+    using N_ge_1 by simp
+  ultimately have "ttt55 \<le> ttt47 + 80 * 2 ^ (16*Z) * N ^ 7 + 3 * 2 ^ (16*Z) * N ^ 7 +
+      2 * 2 ^ (16*Z) * N ^ 7 + 2 * 2 ^ (16*Z) * N ^ 7 + 3 * 2 ^ (16*Z) * N ^ 7 +
+      2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') +
+      16114767 * 2 ^ (16 * Z) * N ^ 7"
+    using ttt55_def by linarith
+  also have "... = ttt47 + 2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') +
+      16114857 * 2 ^ (16 * Z) * N ^ 7"
+    by simp
+  finally show ?thesis .
+qed
+
+lemma tm55 [transforms_intros]: "transforms tm55 tps0 ttt55 tps55"
+  unfolding tm55_def
+proof (tform)
+  show "91 + 17 < length tps54"
+    using lentpsJ tps54_def k by (simp_all only: length_list_update)
+  let ?nss = "formula_n \<Phi>\<^sub>0 @ formula_n \<Phi>\<^sub>1 @ formula_n \<Phi>\<^sub>2 @ formula_n \<Phi>\<^sub>3 @ formula_n \<Phi>\<^sub>4 @
+       formula_n \<Phi>\<^sub>5 @ formula_n \<Phi>\<^sub>6 @ formula_n \<Phi>\<^sub>7 @ formula_n \<Phi>\<^sub>8"
+  show "tps54 ! 1 = nlltape ?nss"
+    using tps54_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps54 ! 4 = (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tps54_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps54 ! 7 = (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tps54_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps54 ! 91 = (\<lfloor>N\<rfloor>\<^sub>N, 1)"
+    using tps54_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  have "tps54 ! 92 = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    using tps54_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps54 ! (91 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps54 ! 93 = (\<lfloor>Z\<rfloor>\<^sub>N, 1)"
+    using tps54_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps54 ! (91 + 2) = (\<lfloor>Z\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps54 ! 94 = (\<lfloor>T'\<rfloor>\<^sub>N, 1)"
+    using tps54_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps54 ! (91 + 3) = (\<lfloor>T'\<rfloor>\<^sub>N, 1)"
+    by simp
+  have "tps54 ! 95 = (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    using tps54_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps54 ! (91 + 4) = (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    by simp
+  have "tps54 ! 96 = (\<lfloor>formula_n \<psi>'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    using tps54_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps54 ! (91 + 5) = (\<lfloor>formula_n \<psi>'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    by simp
+  have "tps54 ! 97 = (\<lfloor>1\<rfloor>\<^sub>N, 1)"
+    using tps54_def k lentpsJ by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "tps54 ! (91 + 6) = (\<lfloor>1\<rfloor>\<^sub>N, 1)"
+    by simp
+  show "tps54 ! (91 + i) = (\<lfloor>[]\<rfloor>, 1)" if "6 < i" "i < 17" for i
+  proof -
+    have "tps54 ! (91 + i) = tpsJ ! (91 + i)"
+      using tps54_def that by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+    then show "tps54 ! (91 + i) = (\<lfloor>[]\<rfloor>, 1)"
+      using tpsJ k that by simp
+  qed
+  have "tps55 = tps54
+      [1 := nlltape (formula_n PHI),
+       91 + 6 := (\<lfloor>Suc T'\<rfloor>\<^sub>N, 1),
+       91 + 3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    unfolding tps55_def tps54_def by (simp only: list_update_swap list_update_overwrite)
+  then show "tps55 = tps54
+      [1 := nlltape (?nss @ formula_n (PHI9)),
+       91 + 6 := (\<lfloor>Suc T'\<rfloor>\<^sub>N, 1),
+       91 + 3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    using PHI_def formula_n_def by simp
+  show "ttt55 = ttt47 + 80 + 3 * nlength N + 2 * nlength H + 2 * nlength Z +
+      3 * nlength T' + 2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') +
+      16114767 * 2 ^ (16 * Z) * N ^ 7"
+    using ttt55_def by simp
+qed
+
+lemma tps0_start_config: "(0, tps0) = start_config 110 xs"
+proof
+  show "fst (0, tps0) = fst (start_config 110 xs)"
+    using start_config_def by simp
+  let ?tps = "(\<lambda>i. if i = 0 then \<triangleright> else if i \<le> length xs then xs ! (i - 1) else \<box>, 0) #
+        replicate (110 - 1) (\<lambda>i. if i = 0 then \<triangleright> else \<box>, 0)"
+  have "tps0 = ?tps"
+  proof (rule nth_equalityI)
+    show "length tps0 = length ?tps"
+      using k by simp
+    show "tps0 ! j = ?tps ! j" if "j < length tps0" for j
+      using tps0 contents_def k that by (cases "j = 0") auto
+  qed
+  then show "snd (0, tps0) = snd (start_config 110 xs)"
+    using start_config_def by auto
+qed
+
+lemma tm55': "snd (execute tm55 (start_config 110 xs) ttt55) = tps55"
+  using tps0_start_config transforms_def transits_def tm55
+  by (smt (verit, best) execute_after_halting_ge prod.sel(1) prod.sel(2))
+
+definition "tpsK \<equiv> tpsJ
+  [91 := (\<lfloor>N\<rfloor>\<^sub>N, 1),
+   92 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   93 := (\<lfloor>Z\<rfloor>\<^sub>N, 1),
+   94 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   95 := (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   96 := (\<lfloor>formula_n \<psi>'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   97 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   91 + 6 := (\<lfloor>Suc T'\<rfloor>\<^sub>N, 1),
+   91 + 3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tpsK: "97 < j \<Longrightarrow> j < 110 \<Longrightarrow> tpsK ! j = (\<lfloor>[]\<rfloor>, 1)"
+  using tpsK_def tpsJ by simp
+
+lemma lentpsK: "length tpsK = 110"
+  using lentpsJ tpsK_def by simp
+
+lemma tps55: "tps55 = tpsK
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n PHI)]"
+  unfolding tps55_def tpsK_def by (simp only: list_update_swap)
+
+definition "tps56 \<equiv> tpsK
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm56 [transforms_intros]:
+  assumes "ttt = ttt55 + tps55 :#: 1 + 2"
+  shows "transforms tm56 tps0 ttt tps56"
+  unfolding tm56_def
+proof (tform)
+  show "1 < length tps55"
+    using lentpsJ tps55_def k by (simp_all only: length_list_update)
+  have *: "tps55 ! 1 = nlltape (formula_n PHI)"
+    using tps55 k lentpsK by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "clean_tape (tps55 ! 1)"
+    using clean_tape_nllcontents by simp
+  have "tps55 ! 1 |#=| 1 = (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    using * by simp
+  then show "tps56 = tps55[1 := tps55 ! 1 |#=| 1]"
+    unfolding tps56_def tps55 by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt55 + (tps55 :#: 1 + 2)"
+    using assms by simp
+qed
+
+definition "tps57 \<equiv> tpsK
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := nlltape (formula_n PHI),
+   109 := nlltape (formula_n PHI)]"
+
+lemma tm57 [transforms_intros]:
+  assumes "ttt = ttt55 + tps55 :#: 1 + 2 + Suc (nlllength (formula_n PHI))"
+  shows "transforms tm57 tps0 ttt tps57"
+  unfolding tm57_def
+proof (tform)
+  show "1 < length tps56" "109 < length tps56"
+    using lentpsK tps56_def k by (simp_all only: length_list_update)
+  have *: "tps56 ! 1 = (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    using tps56_def k lentpsK by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  let ?n = "nlllength (formula_n PHI)"
+  show "rneigh (tps56 ! 1) {0} ?n"
+  proof (rule rneighI)
+    show "(tps56 ::: 1) (tps56 :#: 1 + nlllength (formula_n PHI)) \<in> {0}"
+      using proper_symbols_numlistlist nllcontents_def * contents_outofbounds nlllength_def
+      by simp
+    have "\<And>n'. n' < ?n \<Longrightarrow> (tps56 ::: 1) (1 + n') > 0"
+      using proper_symbols_numlistlist nllcontents_def * contents_inbounds nlllength_def
+      by fastforce
+    then show "\<And>n'. n' < ?n \<Longrightarrow> (tps56 ::: 1) (tps56 :#: 1 + n') \<notin> {0}"
+      using * by simp
+  qed
+  have "tps56 ! 109 = tpsK ! 109"
+    using tps56_def by (simp only: length_list_update nth_list_update_eq nth_list_update_neq)
+  then have **: "tps56 ! 109 = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsK k by simp
+  have "implant (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1) (\<lfloor>[]\<rfloor>, 1) ?n =
+    (\<lfloor>[] @
+       take (nlllength (formula_n PHI))
+        (drop (1 - 1) (numlistlist (formula_n PHI)))\<rfloor>,
+     Suc (length []) + nlllength (formula_n PHI))"
+    using implant_contents[of 1 ?n "numlistlist (formula_n PHI)" "[]"] nlllength_def nllcontents_def
+    by simp
+  then have "implant (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1) (\<lfloor>[]\<rfloor>, 1) ?n =
+     (\<lfloor>take ?n (numlistlist (formula_n PHI))\<rfloor>, Suc ?n)"
+    by simp
+  also have "... = (\<lfloor>numlistlist (formula_n PHI)\<rfloor>, Suc ?n)"
+    using nlllength_def by simp
+  also have "... = (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, Suc ?n)"
+    using nllcontents_def by simp
+  finally have "implant (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1) (\<lfloor>[]\<rfloor>, 1) ?n = (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, Suc ?n)" .
+  then have "implant (tps56 ! 1) (tps56 ! 109) ?n = (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, Suc ?n)"
+    using * ** by simp
+  then have "implant (tps56 ! 1) (tps56 ! 109) ?n = nlltape (formula_n PHI)"
+    by simp
+  moreover have "tps56 ! 1 |+| nlllength (formula_n PHI) = nlltape (formula_n PHI)"
+    using * by simp
+  moreover have "tps57 = tps56
+    [1 := nlltape (formula_n PHI),
+     109 := nlltape (formula_n PHI)]"
+    unfolding tps57_def tps56_def by (simp only: list_update_swap[of 1] list_update_overwrite)
+  ultimately show "tps57 = tps56
+    [1 := tps56 ! 1 |+| nlllength (formula_n PHI),
+     109 := implant (tps56 ! 1) (tps56 ! 109) (nlllength (formula_n PHI))]"
+    by simp
+  show "ttt = ttt55 + tps55 :#: 1 + 2 + Suc (nlllength (formula_n PHI))"
+    using assms by simp
+qed
+
+definition "tps58 \<equiv> tpsK
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := (\<lfloor>[]\<rfloor>, 1),
+   109 := nlltape (formula_n PHI)]"
+
+lemma tm58 [transforms_intros]:
+  assumes "ttt = ttt55 + 9 + tps55 :#: 1 + 3 * nlllength (formula_n PHI) + tps57 :#: 1"
+  shows "transforms tm58 tps0 ttt tps58"
+  unfolding tm58_def
+proof (tform)
+  show "1 < length tps57"
+    using lentpsK tps57_def k by (simp_all only: length_list_update)
+  let ?zs = "numlistlist (formula_n PHI)"
+  show "proper_symbols ?zs"
+    using proper_symbols_numlistlist by simp
+  have "tps57 ! 1 = nlltape (formula_n PHI)"
+    using tps57_def k lentpsK by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then have "tps57 ! 1 = (\<lfloor>numlistlist (formula_n PHI)\<rfloor>, Suc (nlllength (formula_n PHI)))"
+    using nlllength_def nllcontents_def by auto
+  then show "tps57 ::: 1 = \<lfloor>numlistlist (formula_n PHI)\<rfloor>"
+    by simp
+  show "tps58 = tps57[1 := (\<lfloor>[]\<rfloor>, 1)]"
+    unfolding tps58_def tps57_def by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt55 + tps55 :#: 1 + 2 + Suc (nlllength (formula_n PHI)) +
+      (tps57 :#: 1 + 2 * length (numlistlist (formula_n PHI)) + 6)"
+    using assms nlllength_def by simp
+qed
+
+definition "tps59 \<equiv> tpsK
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := (\<lfloor>[]\<rfloor>, 1),
+   109 := (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm59 [transforms_intros]:
+  assumes "ttt = ttt55 + 11 + tps55 :#: 1 + 3 * nlllength (formula_n PHI) + tps57 :#: 1 + tps58 :#: 109"
+  shows "transforms tm59 tps0 ttt tps59"
+  unfolding tm59_def
+proof (tform)
+  show "109 < length tps58"
+    using lentpsK tps58_def k by (simp_all only: length_list_update)
+  have *: "tps58 ! 109 = nlltape (formula_n PHI)"
+    using tps58_def k lentpsK by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then show "clean_tape (tps58 ! 109)"
+    by (simp add: clean_tape_nllcontents)
+  have "tps58 ! 109 |#=| 1 = (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    using * by simp
+  then show "tps59 = tps58[109 := tps58 ! 109 |#=| 1]"
+    unfolding tps59_def tps58_def by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt55 + 9 + tps55 :#: 1 + 3 * nlllength (formula_n PHI) + tps57 :#: 1 +
+      (tps58 :#: 109 + 2)"
+    using assms by simp
+qed
+
+definition "tps60 \<equiv> tpsK
+  [11 := (\<lfloor>n\<rfloor>\<^sub>N, 1),
+   15 := (\<lfloor>p n\<rfloor>\<^sub>N, 1),
+   16 := (\<lfloor>m\<rfloor>\<^sub>N, 1),
+   17 := (\<lfloor>T'\<rfloor>\<^sub>N, 1),
+   4 := (\<lfloor>map (\<lambda>t. exc zs t <#> 0) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   7 := (\<lfloor>map (\<lambda>t. exc zs t <#> 1) [0..<Suc T']\<rfloor>\<^sub>N\<^sub>L, 1),
+   18 := (\<lfloor>m'\<rfloor>\<^sub>N, 1),
+   19 := (\<lfloor>H\<rfloor>\<^sub>N, 1),
+   20 := (\<lfloor>m' * H\<rfloor>\<^sub>N, 1),
+   1 := (\<lfloor>[]\<rfloor>, 1),
+   109 := (\<lfloor>formula_n PHI\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   109 := (\<lfloor>numlistlist (formula_n PHI)\<rfloor>,
+       Suc (length (numlistlist (formula_n PHI)))),
+   1 := (\<lfloor>binencode (numlistlist (formula_n PHI))\<rfloor>,
+       Suc (2 * length (numlistlist (formula_n PHI))))]"
+
+lemma tm60:
+  assumes "ttt = ttt55 + 12 + tps55 :#: 1 + 12 * nlllength (formula_n PHI) + tps57 :#: 1 + tps58 :#: 109"
+  shows "transforms tm60 tps0 ttt tps60"
+  unfolding tm60_def
+proof (tform)
+  show "109 < length tps59" "1 < length tps59"
+    using lentpsK tps59_def k by (simp_all only: length_list_update)
+  let ?zs = "numlistlist (formula_n PHI)"
+  show "binencodable ?zs"
+    using proper_symbols_numlistlist symbols_lt_numlistlist by fastforce
+  show "tps59 ! 109 = (\<lfloor>numlistlist (formula_n PHI)\<rfloor>, 1)"
+    using tps59_def k lentpsK nllcontents_def
+    by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps59 ! 1 = (\<lfloor>[]\<rfloor>, 1)"
+    using tps59_def k lentpsK by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  show "tps60 \<equiv> tps59
+    [109 := (\<lfloor>numlistlist (formula_n PHI)\<rfloor>,
+        Suc (length (numlistlist (formula_n PHI)))),
+     1 := (\<lfloor>binencode (numlistlist (formula_n PHI))\<rfloor>,
+           Suc (2 * length (numlistlist (formula_n PHI))))]"
+    unfolding tps60_def tps59_def by (simp only: list_update_swap list_update_overwrite)
+  show "ttt = ttt55 + 11 + tps55 :#: 1 + 3 * nlllength (formula_n PHI) + tps57 :#: 1 +
+      tps58 :#: 109 + (9 * length (numlistlist (formula_n PHI)) + 1)"
+    using assms nlllength_def by simp
+qed
+
+definition "ttt60 \<equiv> 16 * ttt55"
+
+lemma tm60': "transforms tm60 tps0 ttt60 tps60"
+proof -
+  have tps55_head_1: "tps55 :#: 1 \<le> ttt55"
+  proof -
+    have *: "(1::nat) < 110"
+      using k by simp
+    show ?thesis
+      using head_pos_le_time[OF tm55_tm *, of "xs " ttt55] tm55' k by simp
+  qed
+
+  let ?ttt = "ttt55 + 12 + tps55 :#: 1 + 12 * nlllength (formula_n PHI) + tps57 :#: 1 + tps58 :#: 109"
+  have 55: "tps55 :#: 1 = Suc (nlllength (formula_n PHI))"
+  proof -
+    have "tps55 ! 1 = nlltape (formula_n PHI)"
+      using tps55 k lentpsK by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+    then show ?thesis
+      by simp
+  qed
+  moreover have "tps57 :#: 1 = Suc (nlllength (formula_n PHI))"
+  proof -
+    have "tps57 ! 1 = nlltape (formula_n PHI)"
+      using tps57_def k lentpsK by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+    then show ?thesis
+      by simp
+  qed
+  moreover have "tps58 :#: 109 = Suc (nlllength (formula_n PHI))"
+  proof -
+    have "tps58 ! 109 = nlltape (formula_n PHI)"
+      using tps58_def k lentpsK by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+    then show ?thesis
+      by simp
+  qed
+  ultimately have "?ttt = ttt55 + 12 + 3 * (Suc (nlllength (formula_n PHI))) + 12 * nlllength (formula_n PHI)"
+    by simp
+  also have "... = ttt55 + 15 + 15 * (nlllength (formula_n PHI))"
+    by simp
+  also have "... = ttt55 + 15 * (Suc (nlllength (formula_n PHI)))"
+    by simp
+  also have "... \<le> ttt55 + 15 * ttt55"
+    using tps55_head_1 55 by simp
+  also have "... = 16 * ttt55"
+    by simp
+  finally have "?ttt \<le> 16 * ttt55" .
+  then show ?thesis
+    using tm60 transforms_monotone ttt60_def by simp
+qed
+
+lemma tm60_start_config: "transforms tm60 (snd (start_config 110 (string_to_symbols x))) ttt60 tps60"
+  using tm60' tps0_start_config by (metis prod.sel(2))
+
+end  (* context tps *)
+
+end  (* locale reduction_sat_x *)
+
+text \<open>
+The time bound @{term ttt60} formally depends on the string $x$. But we need a bound
+depending only on the length.
+\<close>
+
+context reduction_sat
+begin
+
+definition T60 :: "nat \<Rightarrow> nat" where
+  "T60 nn \<equiv> reduction_sat_x.ttt60 M G p (replicate nn True)"
+
+lemma T60:
+  fixes x :: string
+  shows "T60 (length x) = reduction_sat_x.ttt60 M G p x"
+proof -
+  interpret x: reduction_sat_x L M G T p x
+    by (simp add: reduction_sat_axioms reduction_sat_x.intro)
+
+  define tpsx :: "tape list" where "tpsx = snd (start_config 110 (x.xs))"
+  have x1: "110 = length tpsx"
+    using start_config_def tpsx_def by auto
+  have x2: "tpsx ! 0 = (\<lfloor>x.xs\<rfloor>, 0)"
+    using start_config_def tpsx_def by auto
+  have x3: "\<And>i. 0 < i \<Longrightarrow> i < 110 \<Longrightarrow> tpsx ! i = (\<lfloor>[]\<rfloor>, 0)"
+    using start_config_def tpsx_def by auto
+
+  let ?y = "replicate (length x) True"
+  interpret y: reduction_sat_x L M G T p ?y
+    by (simp add: reduction_sat_axioms reduction_sat_x.intro)
+  define tpsy :: "tape list" where "tpsy = snd (start_config 110 (y.xs))"
+  have y1: "110 = length tpsy"
+    using start_config_def tpsy_def by auto
+  have y2: "tpsy ! 0 = (\<lfloor>y.xs\<rfloor>, 0)"
+    using start_config_def tpsy_def by auto
+  have y3: "\<And>i. 0 < i \<Longrightarrow> i < 110 \<Longrightarrow> tpsy ! i = (\<lfloor>[]\<rfloor>, 0)"
+    using start_config_def tpsy_def by auto
+
+  have m: "x.m = y.m"
+    using x.m_def y.m_def by simp
+  have T': "x.T' = y.T'"
+    using x.T'_def y.T'_def m by simp
+  have m': "x.m' = y.m'"
+    using x.m'_def y.m'_def T' by simp
+  have N: "x.N = y.N"
+    using x.N_eq y.N_eq T' by simp
+
+  have "x.ttt31 = y.ttt31"
+    using x.ttt31_def[OF x1 x2 x3] y.ttt31_def[OF y1 y2 y3] T' m m' by simp
+  then have "x.ttt47 = y.ttt47"
+    using x.ttt47_def[OF x1 x2 x3] y.ttt47_def[OF y1 y2 y3] T' m m' by simp
+  then have "x.ttt55 = y.ttt55"
+    using x.ttt55_def[OF x1 x2 x3] y.ttt55_def[OF y1 y2 y3] T' m m' N by simp
+  then have "x.ttt60 = y.ttt60"
+    using x.ttt60_def[OF x1 x2 x3] y.ttt60_def[OF y1 y2 y3] by simp
+  then show "T60 (length x) = reduction_sat_x.ttt60 M G p x"
+  unfolding T60_def by simp
+qed
+
+lemma poly_T60: "big_oh_poly T60"
+proof -
+  define fN :: "nat \<Rightarrow> nat" where
+    "fN = (\<lambda>nn. H * (2 * nn + 2 * p nn + 3 + TT (2 * nn + 2 * p nn + 2)))"
+  define f where
+    "f = (\<lambda>nn. 16 * ((32 * d_polynomial p + 364343) * H ^ 6 * fN nn ^ 4 +
+      2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') + 16114857 * 2 ^ (16 * Z) * fN nn ^ 7))"
+  have T60_upper: "T60 nn \<le> f nn" for nn
+  proof -
+    define y where "y = replicate nn True"
+    then have leny: "length y = nn"
+      by simp
+    interpret y: reduction_sat_x _ _ _ _ _ y
+      by (simp add: reduction_sat_axioms reduction_sat_x.intro)
+    define tps0 :: "tape list" where "tps0 = snd (start_config 110 y.xs)"
+    have 1: "110 = length tps0"
+      using start_config_def tps0_def by auto
+    have 2: "tps0 ! 0 = (\<lfloor>y.xs\<rfloor>, 0)"
+      using start_config_def tps0_def by auto
+    have 3: "\<And>i. 0 < i \<Longrightarrow> i < 110 \<Longrightarrow> tps0 ! i = (\<lfloor>[]\<rfloor>, 0)"
+      using start_config_def tps0_def by auto
+
+    have "T60 nn = y.ttt60"
+      by (simp add: y_def T60_def)
+    also have "... \<le> 16 * y.ttt55"
+      using y.ttt60_def[OF 1 2 3] by simp
+    also have "... \<le> 16 * (y.ttt47 + 2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') + 16114857 * 2 ^ (16 * Z) * y.N ^ 7)"
+      using y.ttt55[OF 1 2 3] by simp
+    also have "... \<le> 16 * ((32 * d_polynomial p + 364343) * H ^ 6 * y.N ^ 4 +
+        2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') + 16114857 * 2 ^ (16 * Z) * y.N ^ 7)"
+      using y.ttt47[OF 1 2 3] by simp
+    also have "... = 16 * ((32 * d_polynomial p + 364343) * H ^ 6 * fN nn ^ 4 +
+        2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') + 16114857 * 2 ^ (16 * Z) * fN nn ^ 7)"
+    proof -
+      have "y.N = fN nn"
+        using y.N_eq y.T'_def y.m_def y_def fN_def by simp
+      then show ?thesis
+        by simp
+    qed
+    finally have "T60 nn \<le> 16 * ((32 * d_polynomial p + 364343) * H ^ 6 * fN nn ^ 4 +
+        2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') + 16114857 * 2 ^ (16 * Z) * fN nn ^ 7)" .
+    then show ?thesis
+      using f_def by simp
+  qed
+
+  have *: "big_oh_poly fN"
+  proof -
+    have 5: "big_oh_poly p"
+      using big_oh_poly_polynomial[OF p] by simp
+    have 6: "big_oh_poly TT"
+      using T big_oh_poly_le TT_le by simp
+    have "big_oh_poly (\<lambda>nn. 2 * p nn + 2)"
+      using 5 big_oh_poly_sum big_oh_poly_prod big_oh_poly_const
+      by presburger
+    moreover have "big_oh_poly (\<lambda>nn. 2 * nn)"
+      using big_oh_poly_prod big_oh_poly_const big_oh_poly_id by simp
+    ultimately have "big_oh_poly (\<lambda>nn. 2 * nn + 2 * p nn + 2)"
+      using big_oh_poly_sum by fastforce
+    then have "big_oh_poly (TT \<circ> (\<lambda>nn. 2 * nn + 2 * p nn + 2))"
+      using big_oh_poly_composition[OF _ 6] by simp
+    moreover have "TT \<circ> (\<lambda>nn. 2 * nn + 2 * p nn + 2) = (\<lambda>nn. TT (2 * nn + 2 * p nn + 2))"
+      by auto
+    ultimately have "big_oh_poly (\<lambda>nn. TT (2 * nn + 2 * p nn + 2))"
+      by simp
+    moreover have "big_oh_poly (\<lambda>nn. 2 * nn + 2 * p nn + 3)"
+      using 5 big_oh_poly_prod big_oh_poly_const big_oh_poly_sum big_oh_poly_id by simp
+    ultimately have "big_oh_poly (\<lambda>nn. 2 * nn + 2 * p nn + 3 + TT (2 * nn + 2 * p nn + 2))"
+      using big_oh_poly_sum by simp
+    then have "big_oh_poly (\<lambda>nn. H * (2 * nn + 2 * p nn + 3 + TT (2 * nn + 2 * p nn + 2)))"
+      using big_oh_poly_prod big_oh_poly_const by simp
+    then show ?thesis
+      using fN_def by simp
+  qed
+  then have "big_oh_poly (\<lambda>n. fN n ^ 4)"
+    using big_oh_poly_pow by simp
+  moreover have "big_oh_poly (\<lambda>n. (32 * d_polynomial p + 364343) * H ^ 6)"
+    using big_oh_poly_prod big_oh_poly_const big_oh_poly_sum by simp
+  ultimately have "big_oh_poly (\<lambda>n. (32 * d_polynomial p + 364343) * H ^ 6 * fN n ^ 4)"
+    using big_oh_poly_prod by simp
+  moreover have "big_oh_poly (\<lambda>n. 2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') + 16114857 * 2 ^ (16 * Z) * fN n ^ 7)"
+    using big_oh_poly_pow * big_oh_poly_sum big_oh_poly_prod big_oh_poly_const
+    by simp
+  ultimately have "big_oh_poly (\<lambda>n. ((32 * d_polynomial p + 364343) * H ^ 6 * fN n ^ 4) +
+      (2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') + 16114857 * 2 ^ (16 * Z) * fN n ^ 7))"
+    using big_oh_poly_sum by simp
+  moreover have "(\<lambda>n. ((32 * d_polynomial p + 364343) * H ^ 6 * fN n ^ 4) +
+      (2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') + 16114857 * 2 ^ (16 * Z) * fN n ^ 7)) =
+      (\<lambda>n. (32 * d_polynomial p + 364343) * H ^ 6 * fN n ^ 4 +
+        2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') + 16114857 * 2 ^ (16 * Z) * fN n ^ 7)"
+    by auto
+  ultimately have "big_oh_poly (\<lambda>n. (32 * d_polynomial p + 364343) * H ^ 6 * fN n ^ 4 +
+      2 * nlllength (formula_n \<psi>) + 2 * nlllength (formula_n \<psi>') + 16114857 * 2 ^ (16 * Z) * fN n ^ 7)"
+    by simp
+  then have "big_oh_poly f"
+    using f_def big_oh_poly_prod big_oh_poly_const by blast
+  then show "big_oh_poly T60"
+    using T60_upper big_oh_poly_le by simp
+qed
+
+text \<open>
+This is the function, in terms of bit strings, that maps $x$ to $\Phi$.
+\<close>
+
+definition freduce :: "string \<Rightarrow> string" ("f\<^bsub>reduce\<^esub>") where
+  "f\<^bsub>reduce\<^esub> x \<equiv> formula_to_string (reduction_sat_x.PHI M G p x)"
+
+text \<open>
+The function $f_{reduce}$ many-one reduces $L$ to \SAT{}.
+\<close>
+
+lemma x_in_L: "x \<in> L \<longleftrightarrow> f\<^bsub>reduce\<^esub> x \<in> SAT"
+proof
+  interpret x: reduction_sat_x
+    by (simp add: reduction_sat_axioms reduction_sat_x.intro)
+  show "x \<in> L \<Longrightarrow> f\<^bsub>reduce\<^esub> x \<in> SAT"
+    using freduce_def SAT_def x.L_iff_satisfiable by auto
+  show "f\<^bsub>reduce\<^esub> x \<in> SAT \<Longrightarrow> x \<in> L"
+  proof -
+    assume "f\<^bsub>reduce\<^esub> x \<in> SAT"
+    then obtain phi where
+      phi: "satisfiable phi" "f\<^bsub>reduce\<^esub> x = formula_to_string phi "
+      using SAT_def freduce_def by auto
+
+    have "formula_to_string (reduction_sat_x.PHI M G p x) = formula_to_string phi"
+      using phi(2) freduce_def by simp
+    then have "reduction_sat_x.PHI M G p x = phi"
+      using formula_to_string_inj by simp
+    then have "satisfiable (reduction_sat_x.PHI M G p x)"
+      using phi(1) by simp
+    then show "x \<in> L"
+      using x.L_iff_satisfiable by simp
+  qed
+qed
+
+text \<open>
+The Turing machine @{const tm60} computes $f_{reduce}$ with time bound $T60$.
+\<close>
+
+lemma computes_in_time_tm60: "computes_in_time 110 tm60 f\<^bsub>reduce\<^esub> T60"
+proof
+  fix x :: string
+
+  interpret x: reduction_sat_x _ _ _ _ _ x
+    by (simp add: reduction_sat_axioms reduction_sat_x.intro)
+
+  have "binencodable (numlistlist (formula_n x.PHI))"
+    by (metis One_nat_def Suc_1 Suc_leI le_refl proper_symbols_numlistlist symbols_lt_numlistlist)
+  then have *: "bit_symbols (binencode (numlistlist (formula_n x.PHI)))"
+    using bit_symbols_binencode by simp
+
+  define tps0 :: "tape list" where "tps0 = snd (start_config 110 x.xs)"
+  have 1: "110 = length tps0"
+    using start_config_def tps0_def by auto
+  have 2: "tps0 ! 0 = (\<lfloor>x.xs\<rfloor>, 0)"
+    using start_config_def tps0_def by auto
+  have 3: "\<And>i. 0 < i \<Longrightarrow> i < 110 \<Longrightarrow> tps0 ! i = (\<lfloor>[]\<rfloor>, 0)"
+    using start_config_def tps0_def by auto
+  let ?tps = "x.tps60 tps0"
+  have "length ?tps = 110"
+    using x.tps60_def[OF 1 2 3] x.lentpsK[OF 1 2 3] by (simp_all only: length_list_update)
+  then have "?tps ! 1 = (\<lfloor>binencode (numlistlist (formula_n (x.PHI)))\<rfloor>,
+      Suc (2 * length (numlistlist (formula_n x.PHI))))"
+    using x.tps60_def[OF 1 2 3] by (simp only: length_list_update nth_list_update_neq nth_list_update_eq)
+  then have "?tps ::: 1 = \<lfloor>binencode (numlistlist (formula_n x.PHI))\<rfloor>"
+    by simp
+  also have "... = string_to_contents (symbols_to_string (binencode (numlistlist (formula_n x.PHI))))"
+    using bit_symbols_to_contents[OF *] by simp
+  also have "... = string_to_contents (f\<^bsub>reduce\<^esub> x)"
+    using freduce_def by auto
+  finally have **: "?tps ::: 1 = string_to_contents (f\<^bsub>reduce\<^esub> x)" .
+
+  have "transforms tm60 tps0 x.ttt60 ?tps"
+    using tps0_def x.tm60_start_config[OF 1 2 3] by simp
+  then have "transforms tm60 (snd (start_config 110 x.xs)) (T60 (length x)) ?tps"
+    using T60 tps0_def by simp
+
+  then show "\<exists>tps.
+      tps ::: 1 = string_to_contents (f\<^bsub>reduce\<^esub> x) \<and>
+      transforms tm60 (snd (start_config 110 (string_to_symbols x))) (T60 (length x)) tps"
+    using ** by auto
+qed
+
+text \<open>
+Since $T60$ is bounded by a polynomial, the previous three lemmas imply that $L$
+is polynomial-time many-one reducible to \SAT{}.
+\<close>
+
+lemma L_reducible_SAT: "L \<le>\<^sub>p SAT"
+  using reducible_def tm60_tm poly_T60 computes_in_time_tm60 x_in_L by fastforce
+
+end  (* locale reduction_sat *)
+
+text \<open>
+In the locale @{locale reduction_sat} the language $L$ was chosen arbitrarily
+with properties that we have proven $\NP$ languages have. So we can now show
+that \SAT{} is $\NP$-hard.
+
+\null
+\<close>
+
+theorem NP_hard_SAT:
+  assumes "L \<in> \<N>\<P>"
+  shows "L \<le>\<^sub>p SAT"
+proof -
+  obtain M G T p where
+    T: "big_oh_poly T" and
+    p: "polynomial p" and
+    tm_M: "turing_machine 2 G M" and
+    oblivious_M: "oblivious M" and
+    T_halt: "\<And>y. bit_symbols y \<Longrightarrow> fst (execute M (start_config 2 y) (T (length y))) = length M" and
+    cert: "\<And>x. x \<in> L \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> execute M (start_config 2 \<langle>x; u\<rangle>) (T (length \<langle>x; u\<rangle>)) <.> 1 = \<one>)"
+    using NP_imp_oblivious_2tape[OF assms] by metis
+
+  interpret red: reduction_sat L M G T p
+    using T p tm_M oblivious_M T_halt cert reduction_sat.intro by simp
+
+  show ?thesis
+    using red.L_reducible_SAT by simp
+qed
+
+
+section \<open>\SAT{} is $\NP$-complete\label{s:complete}\<close>
+
+text \<open>
+The time has come to reap the fruits of our labor and show that \SAT{} is
+$\NP$-complete.
+
+\null
+\<close>
+
+theorem NP_complete_SAT: "NP_complete SAT"
+  using NP_hard_SAT SAT_in_NP NP_complete_def by simp
+
+end
diff --git a/thys/Cook_Levin/Sat_TM_CNF.thy b/thys/Cook_Levin/Sat_TM_CNF.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Sat_TM_CNF.thy
@@ -0,0 +1,4579 @@
+section \<open>Turing machines for the parts of $\Phi$\label{s:tmcnf}\<close>
+
+theory Sat_TM_CNF
+  imports Aux_TM_Reducing
+begin
+
+text \<open>
+In this section we build Turing machines for all parts $\Phi_0,\dots,\Phi_9$ of
+the CNF formula $\Phi$. Some of them ($\Phi_0$, $\Phi_1$, $\Phi_2$, and
+$\Phi_8$) are just fixed-length sequences of $\Psi$ formulas constructible by
+fixed-length sequences of @{const tm_Psigamma} machines.  Others ($\Phi_3$,
+$\Phi_4$, $\Phi_5$, $\Phi_6$) are variable-length and require looping over a
+@{const tm_Psigamma} machine. The TM for $\Phi_7$ is a loop over @{const
+tm_Upsilongamma}. Lastly, the TM for $\Phi_9$ is a loop over a TM that generates
+the formulas $\chi_t$.
+
+Ideally we would want to prove the semantics of the TMs inside the locale
+@{locale reduction_sat}, in which $\Phi$ was defined. However, we use locales to
+prove the semantics of TMs, and locales cannot be nested. For this reason we
+have to define the TMs on the theory level and prove their semantics there, too,
+just as we have done with all TMs until now. In the next chapter the semantics
+lemmas will be transferred to the locale @{locale reduction_sat}.
+
+Unlike most TMs so far, the TMs in this section are not meant to be reusable
+but serve a special purpose, namely to be combined into one large TM computing
+$\Phi$. For this reason the TMs are somewhat peculiar. For example, they write
+their output to the fixed tape~$1$ rather than having a parameter for the output
+tape. They also often expect the tapes to be initialized in a very special way.
+Moreover, the TMs often leave the work tapes in a ``dirty'' state with remnants
+of intermediate calculations. The combined TM for all of $\Phi$ will simply
+allocate a new batch of work tapes for every individual TM.
+\<close>
+
+
+subsection \<open>A Turing machine for $\Phi_0$\<close>
+
+text \<open>
+The next Turing machine expects a number $i$ on tape $j$ and a number $H$ on
+tape $j + 1$ and outputs to tape $1$ the formula $\Psi([i\dots H, (i+1)\dots H),
+1) \land \Psi([(i+1)\dots H, (i+2)\dots H), 1) \land \Psi([(i+2)\dots H,
+(i+3)\dots H), 0)$, which is just $\Phi_0$ for suitable values of $i$ and $H$.
+\<close>
+
+definition tm_PHI0 :: "tapeidx \<Rightarrow> machine" where
+  "tm_PHI0 j \<equiv>
+    tm_setn (j + 2) 1 ;;
+    tm_Psigamma j ;;
+    tm_extendl_erase 1 (j + 6) ;;
+    tm_incr j ;;
+    tm_Psigamma j ;;
+    tm_extendl_erase 1 (j + 6) ;;
+    tm_incr j ;;
+    tm_setn (j + 2) 0 ;;
+    tm_Psigamma j ;;
+    tm_extendl 1 (j + 6)"
+
+lemma tm_PHI0_tm:
+  assumes "0 < j" and "j + 8 < k" and "G \<ge> 6"
+  shows "turing_machine k G (tm_PHI0 j)"
+  unfolding tm_PHI0_def
+  using assms tm_Psigamma_tm tm_extendl_tm tm_erase_cr_tm tm_times2_tm tm_incr_tm tm_setn_tm tm_cr_tm
+    tm_extendl_erase_tm
+  by simp
+
+locale turing_machine_PHI0 =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_setn (j + 2) 1"
+definition "tm2 \<equiv> tm1 ;; tm_Psigamma j"
+definition "tm3 \<equiv> tm2 ;; tm_extendl_erase 1 (j + 6)"
+definition "tm5 \<equiv> tm3 ;; tm_incr j"
+definition "tm6 \<equiv> tm5 ;; tm_Psigamma j"
+definition "tm7 \<equiv> tm6 ;; tm_extendl_erase 1 (j + 6)"
+definition "tm9 \<equiv> tm7 ;; tm_incr j"
+definition "tm10 \<equiv> tm9 ;; tm_setn (j + 2) 0"
+definition "tm11 \<equiv> tm10 ;; tm_Psigamma j"
+definition "tm12 \<equiv> tm11 ;; tm_extendl 1 (j + 6)"
+
+lemma tm12_eq_tm_PHI0: "tm12 = tm_PHI0 j"
+  using tm12_def tm11_def tm10_def tm9_def tm7_def tm6_def tm5_def
+  using tm3_def tm2_def tm1_def tm_PHI0_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k idx H :: nat
+  assumes jk: "length tps0 = k" "1 < j" "j + 8 < k"
+    and H: "H \<ge> 3"
+  assumes tps0:
+    "tps0 ! 1 = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 8) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 12"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps0 tps1_def jk)
+  show "tps0 ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps0 jk canrepr_0 by simp
+  show "ttt = 10 + 2 * nlength 0 + 2 * nlength 1"
+    using assms canrepr_1 by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi (idx * H) H 1\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 12 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: assms tps0 H tps1_def tps2_def jk)
+
+definition "tps3 \<equiv> tps0
+  [j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   1 := nlltape (nll_Psi (idx * H) H (Suc 0)),
+   j + 6 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 23 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * nlllength (nll_Psi (idx * H) H (Suc 0))"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps0 H tps2_def tps3_def jk time: assms)
+  show "tps2 ! 1 = nlltape []"
+    using tps2_def jk nllcontents_Nil tps0 by simp
+  show "tps3 = tps2
+      [1 := nlltape ([] @ nll_Psi (idx * H) H (Suc 0)),
+       j + 6 := (\<lfloor>[]\<rfloor>, 1)]"
+    unfolding tps3_def tps2_def using jk by (simp add: list_update_swap)
+qed
+
+definition "tps5 \<equiv> tps0
+  [j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   1 := nlltape (nll_Psi (idx * H) H (Suc 0)),
+   j + 6 := (\<lfloor>[]\<rfloor>, 1),
+   j := (\<lfloor>Suc idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 28 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * nlllength (nll_Psi (idx * H) H 1) +
+      2 * nlength idx"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def by (tform tps: tps0 H tps3_def tps5_def jk time: assms)
+
+definition "tps6 \<equiv> tps0
+  [j := (\<lfloor>Suc idx\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi (Suc idx * H) H (Suc 0)\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   1 := nlltape (nll_Psi (idx * H) H 1)]"
+
+lemma tm6 [transforms_intros]:
+  assumes "ttt = 28 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * nlllength (nll_Psi (idx * H) H 1) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+proof (tform tps: tps0 H tps5_def tps6_def jk time: assms)
+  show "tps6 = tps5[j + 6 := (\<lfloor>nll_Psi (Suc idx * H) H (Suc 0)\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+    unfolding tps5_def tps6_def using jk
+    by (simp add: list_update_swap[of j] list_update_swap[of _ "j + 6"])
+qed
+
+definition "tps7 \<equiv> tps0
+  [j := (\<lfloor>Suc idx\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>[]\<rfloor>, 1),
+   1 := nlltape (nll_Psi (idx * H) H 1 @ nll_Psi (H + idx * H) H 1)]"
+
+lemma tm7 [transforms_intros]:
+  assumes "ttt = 39 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+    4 * nlllength (nll_Psi (idx * H) H 1) +
+    2 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 +
+    4 * nlllength (nll_Psi (H + idx * H) H 1)"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def by (tform tps: assms tps6_def tps7_def jk)
+
+definition "tps9 \<equiv> tps0
+  [j := (\<lfloor>Suc (Suc idx)\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>[]\<rfloor>, 1),
+   1 := nlltape (nll_Psi (idx * H) H 1 @ nll_Psi (H + idx * H) H 1)]"
+
+lemma tm9 [transforms_intros]:
+  assumes "ttt = 44 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * nlllength (nll_Psi (idx * H) H 1) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 + 4 * nlllength (nll_Psi (H + idx * H) H 1) +
+      2 * nlength (Suc idx)"
+  shows "transforms tm9 tps0 ttt tps9"
+  unfolding tm9_def
+proof (tform tps: tps0 H tps7_def tps9_def jk time: assms)
+  show "tps9 = tps7[j := (\<lfloor>Suc (Suc idx)\<rfloor>\<^sub>N, 1)]"
+    using tps9_def tps7_def jk by (simp add: list_update_swap)
+qed
+
+definition "tps10 \<equiv> tps0
+  [j := (\<lfloor>Suc (Suc idx)\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>[]\<rfloor>, 1),
+   1 := nlltape (nll_Psi (idx * H) H 1 @ nll_Psi (H + idx * H) H 1)]"
+
+lemma tm10 [transforms_intros]:
+  assumes "ttt = 56 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * nlllength (nll_Psi (idx * H) H 1) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 + 4 * nlllength (nll_Psi (H + idx * H) H 1) +
+      2 * nlength (Suc idx)"
+  shows "transforms tm10 tps0 ttt tps10"
+  unfolding tm10_def
+proof (tform tps: tps0 H tps9_def tps10_def jk)
+  show "ttt = 44 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * nlllength (nll_Psi (idx * H) H 1) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 + 4 * nlllength (nll_Psi (H + idx * H) H 1) +
+      2 * nlength (Suc idx) + (10 + 2 * nlength (Suc 0) + 2 * nlength 0) "
+    using assms canrepr_1 by simp
+qed
+
+definition "tps11 \<equiv> tps0
+  [j := (\<lfloor>Suc (Suc idx)\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi (Suc (Suc idx) * H) H 0\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   1 := nlltape (nll_Psi (idx * H) H 1 @ nll_Psi (H + idx * H) H 1)]"
+
+lemma tm11 [transforms_intros]:
+  assumes "ttt = 56 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * nlllength (nll_Psi (idx * H) H 1) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 + 4 * nlllength (nll_Psi (H + idx * H) H 1) +
+      2 * nlength (Suc idx) + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2"
+  shows "transforms tm11 tps0 ttt tps11"
+  unfolding tm11_def by (tform tps: tps0 H tps10_def tps11_def jk time: assms)
+
+definition "tps12 \<equiv> tps0
+  [j := (\<lfloor>Suc (Suc idx)\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi (Suc (Suc idx) * H) H 0\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   1 := nlltape (nll_Psi (idx * H) H 1 @ nll_Psi (H + idx * H) H 1 @ nll_Psi (Suc (Suc idx) * H) H 0)]"
+
+lemma tm12:
+  assumes "ttt = 60 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * nlllength (nll_Psi (idx * H) H 1) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 + 4 * nlllength (nll_Psi (H + idx * H) H 1) +
+      2 * nlength (Suc idx) + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 +
+      2 * nlllength (nll_Psi (H + (H + idx * H)) H 0)"
+  shows "transforms tm12 tps0 ttt tps12"
+  unfolding tm12_def by (tform tps: tps11_def tps12_def jk assms)
+
+lemma tm12':
+  assumes "ttt = 5627 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2"
+  shows "transforms tm12 tps0 ttt tps12"
+proof -
+  let ?ttt = "60 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * nlllength (nll_Psi (idx * H) H 1) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 + 4 * nlllength (nll_Psi (H + idx * H) H 1) +
+      2 * nlength (Suc idx) + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 +
+      2 * nlllength (nll_Psi (H + (H + idx * H)) H 0)"
+  have "?ttt \<le> 60 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * H * (3 + nlength (3 * H + idx * H)) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 + 4 * nlllength (nll_Psi (H + idx * H) H 1) +
+      2 * nlength (Suc idx) + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 +
+      2 * nlllength (nll_Psi (H + (H + idx * H)) H 0)"
+    using nlllength_nll_Psi_le'[of "idx * H" "2 * H + idx * H" "H"] by simp
+  also have "... \<le> 60 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * H * (3 + nlength (3 * H + idx * H)) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 + 4 * H * (3 + nlength (3 * H + idx * H)) +
+      2 * nlength (Suc idx) + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 +
+      2 * nlllength (nll_Psi (H + (H + idx * H)) H 0)"
+    using nlllength_nll_Psi_le'[of "H + idx * H" "2 * H + idx * H" "H"] by simp
+  also have "... \<le> 60 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      4 * H * (3 + nlength (3 * H + idx * H)) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 + 4 * H * (3 + nlength (3 * H + idx * H)) +
+      2 * nlength (Suc idx) + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 +
+      2 * H * (3 + nlength (3 * H + idx * H))"
+    using nlllength_nll_Psi_le'[of "H + (H + idx * H)" "2 * H + idx * H" "H"] by simp
+  also have "... = 60 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+      10 * H * (3 + nlength (3 * H + idx * H)) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 + 2 * nlength (Suc idx) +
+      1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2"
+    by simp
+  also have "... \<le> 60 + 1851 * H ^ 4 * (nlength (Suc (Suc idx)))\<^sup>2 +
+      10 * H * (3 + nlength (3 * H + idx * H)) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 + 2 * nlength (Suc idx) +
+      1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2"
+    using nlength_mono linear_le_pow by simp
+  also have "... \<le> 60 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 +
+      10 * H * (3 + nlength (3 * H + idx * H)) + 2 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 + 2 * nlength (Suc idx) +
+      1851 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2"
+    using nlength_mono linear_le_pow by simp
+  also have "... = 60 + 5553 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 +
+      10 * H * (3 + nlength (3 * H + idx * H)) + 2 * nlength idx + 2 * nlength (Suc idx)"
+    by simp
+  also have "... \<le> 60 + 5553 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 +
+      10 * H * (3 + nlength (3 * H + idx * H)) + 2 * nlength (Suc idx) + 2 * nlength (Suc idx)"
+    using nlength_mono by simp
+  also have "... = 60 + 5553 * H ^ 4 * (nlength (Suc (Suc (Suc idx))))\<^sup>2 +
+      10 * H * (3 + nlength (3 * H + idx * H)) + 4 * nlength (Suc idx)"
+    by simp
+  also have "... \<le> 60 + 5553 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2 +
+      10 * H * (3 + nlength (3 * H + idx * H)) + 4 * nlength (Suc idx)"
+  proof -
+    have "Suc (Suc (Suc idx)) \<le> 3 * H + idx * H"
+    proof (cases "idx = 0")
+      case True
+      then show ?thesis
+        using H by simp
+    next
+      case False
+      then show ?thesis
+        using H
+        by (metis One_nat_def Suc3_eq_add_3 comm_semiring_class.distrib le_Suc_eq less_eq_nat.simps(1) mult.commute
+          mult_1 mult_le_mono1 nle_le not_numeral_le_zero)
+    qed
+    then have "nlength (Suc (Suc (Suc idx))) \<le> 3 + nlength (3 * H + idx * H)"
+      using nlength_mono trans_le_add2 by presburger
+    then have "nlength (Suc (Suc (Suc idx))) ^ 2 \<le> (3 + nlength (3 * H + idx * H)) ^ 2"
+      by simp
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<le> 60 + 5553 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2 +
+      10 * H ^ 4 * (3 + nlength (3 * H + idx * H)) + 4 * nlength (Suc idx)"
+    using linear_le_pow by simp
+  also have "... \<le> 60 + 5553 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2 +
+      10 * H ^ 4 * (3 + nlength (3 * H + idx * H)) ^ 2 + 4 * nlength (Suc idx)"
+    using linear_le_pow by simp
+  also have "... = 60 + 5563 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2 + 4 * nlength (Suc idx)"
+    by simp
+  also have "... \<le> 60 + 5563 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2 +
+    4 * H^4 * (3 + nlength (3 * H + idx * H))^2"
+  proof -
+    have "idx \<le> idx * H"
+      using H by simp
+    then have "Suc idx \<le> 3 * H + idx * H"
+      using H by linarith
+    then have "nlength (Suc idx) \<le> 3 + nlength (3 * H + idx * H)"
+      using nlength_mono trans_le_add2 by presburger
+    also have "... \<le> (3 + nlength (3 * H + idx * H)) ^ 2"
+      by (simp add: power2_eq_square)
+    also have "... \<le> H * (3 + nlength (3 * H + idx * H)) ^ 2"
+      using H by simp
+    also have "... \<le> H^4 * (3 + nlength (3 * H + idx * H)) ^ 2"
+      using linear_le_pow by simp
+    finally have "nlength (Suc idx) \<le> H^4 * (3 + nlength (3 * H + idx * H)) ^ 2" .
+    then show ?thesis
+      by simp
+  qed
+  also have "... = 60 + 5567 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2"
+    by simp
+  also have "... \<le> 60 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2 + 5567 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2"
+    using H linear_le_pow by simp
+  also have "... = 5627 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2"
+    by simp
+  finally have "?ttt \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using tm12 transforms_monotone by simp
+qed
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_PHI0 *)
+
+lemma transforms_tm_PHI0I:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k idx H :: nat
+  assumes "length tps = k" and "1 < j" and "j + 8 < k" and "H \<ge> 3"
+  assumes
+    "tps ! 1 = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 8) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "tps' = tps
+    [j := (\<lfloor>Suc (Suc idx)\<rfloor>\<^sub>N, 1),
+     j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>nll_Psi (Suc (Suc idx) * H) H 0\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+     1 := nlltape (nll_Psi (idx * H) H 1 @ nll_Psi (H + idx * H) H 1 @ nll_Psi (Suc (Suc idx) * H) H 0)]"
+  assumes "ttt = 5627 * H ^ 4 * (3 + nlength (3 * H + idx * H))\<^sup>2"
+  shows "transforms (tm_PHI0 j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_PHI0 j .
+  show ?thesis
+    using loc.tps12_def loc.tm12' loc.tm12_eq_tm_PHI0 assms by metis
+qed
+
+
+subsection \<open>A Turing machine for $\Phi_1$\<close>
+
+text \<open>
+The next TM expects a number $H$ on tape $j + 1$ and appends to the formula on
+tape $1$ the formula $\Psi([0, H), 1)$.
+\<close>
+
+definition tm_PHI1 :: "tapeidx \<Rightarrow> machine" where
+  "tm_PHI1 j \<equiv>
+    tm_setn (j + 2) 1 ;;
+    tm_Psigamma j ;;
+    tm_extendl 1 (j + 6)"
+
+lemma tm_PHI1_tm:
+  assumes "0 < j" and "j + 7 < k" and "G \<ge> 6"
+  shows "turing_machine k G (tm_PHI1 j)"
+  unfolding tm_PHI1_def using assms tm_Psigamma_tm tm_setn_tm tm_extendl_tm by simp
+
+locale turing_machine_PHI1 =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_setn (j + 2) 1"
+definition "tm2 \<equiv> tm1 ;; tm_Psigamma j"
+definition "tm3 \<equiv> tm2 ;; tm_extendl 1 (j + 6)"
+
+lemma tm3_eq_tm_PHI1: "tm3 = tm_PHI1 j"
+  using tm3_def tm2_def tm1_def tm_PHI1_def by simp
+
+context
+  fixes tps0 :: "tape list" and k idx H :: nat and nss :: "nat list list"
+  assumes jk: "length tps0 = k" "1 < j" "j + 7 < k"
+    and H: "H \<ge> 3"
+  assumes tps0:
+    "tps0 ! 1 = nlltape nss"
+    "tps0 ! j = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 12"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps0 tps1_def jk)
+  show "tps0 ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps0 jk canrepr_0 by simp
+  show "ttt = 10 + 2 * nlength 0 + 2 * nlength 1"
+    using assms canrepr_1 by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi 0 H 1\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 12 + 1851 * H ^ 4"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps0 H tps1_def tps2_def jk)
+  show "ttt = 12 + 1851 * H ^ 4 * (nlength (Suc 0))\<^sup>2"
+    using canrepr_1 assms by simp
+qed
+
+definition "tps3 \<equiv> tps0
+  [j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi 0 H 1\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   1 := nlltape (nss @ nll_Psi 0 H 1)]"
+
+lemma tm3:
+  assumes "ttt = 16 + 1851 * H ^ 4 + 2 * nlllength (nll_Psi 0 H 1)"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def by (tform tps: tps0 H tps2_def tps3_def jk time: assms)
+
+lemma tm3':
+  assumes "ttt = 1875 * H ^ 4"
+  shows "transforms tm3 tps0 ttt tps3"
+proof -
+  let ?ttt = "16 + 1851 * H ^ 4 + 2 * nlllength (nll_Psi 0 H 1)"
+  have "?ttt \<le> 16 + 1851 * H ^ 4 + 2 * H * (3 + nlength H)"
+    using nlllength_nll_Psi_le
+    by (metis (mono_tags, lifting) add_left_mono mult.assoc nat_mult_le_cancel1 plus_nat.add_0 rel_simps(51))
+  also have "... = 16 + 1851 * H ^ 4 + 6 * H + 2 * H * nlength H"
+    by algebra
+  also have "... \<le> 16 + 1851 * H ^ 4 + 6 * H + 2 * H * H"
+    using nlength_le_n by simp
+  also have "... \<le> 16 + 1851 * H ^ 4 + 6 * H * H + 2 * H * H"
+    by simp
+  also have "... = 16 + 1851 * H ^ 4 + 8 * H^2"
+    by algebra
+  also have "... \<le> 16 + 1851 * H ^ 4 + 8 * H^4"
+    using pow_mono'[of 2 4 H] by simp
+  also have "... = 16 + 1859 * H ^ 4"
+    by simp
+  also have "... \<le> 16 * H^4 + 1859 * H ^ 4"
+    using H by simp
+  also have "... = 1875 * H ^ 4"
+    by simp
+  finally have "?ttt \<le> 1875 * H ^ 4" .
+  then show ?thesis
+    using assms tm3 transforms_monotone by simp
+qed
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_PHI1 *)
+
+lemma transforms_tm_PHI1I:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k H :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 7 < k" and "H \<ge> 3"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "tps' = tps
+      [j + 2 := (\<lfloor>1\<rfloor>\<^sub>N, 1),
+       j + 6 := (\<lfloor>nll_Psi 0 H 1\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+       1 := nlltape (nss @ nll_Psi 0 H 1)]"
+  assumes "ttt = 1875 * H ^ 4"
+  shows "transforms (tm_PHI1 j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_PHI1 j .
+  show ?thesis
+    using loc.tps3_def loc.tm3' loc.tm3_eq_tm_PHI1 assms by metis
+qed
+
+
+subsection \<open>A Turing machine for $\Phi_2$\<close>
+
+text \<open>
+The next TM expects a number $i$ on tape $j$ and a number $H$ on tape $j + 1$.
+It appends to the formula on tape~$1$ the formula $\Psi([(2i+1)H, (2i+2)H), 3)
+\land \Psi([(2i+2)H, (2i+3)H), 3)$.
+\<close>
+
+definition tm_PHI2 :: "tapeidx \<Rightarrow> machine" where
+  "tm_PHI2 j \<equiv>
+    tm_times2 j ;;
+    tm_incr j ;;
+    tm_setn (j + 2) 3 ;;
+    tm_Psigamma j ;;
+    tm_extendl_erase 1 (j + 6) ;;
+    tm_incr j ;;
+    tm_Psigamma j ;;
+    tm_extendl 1 (j + 6)"
+
+lemma tm_PHI2_tm:
+  assumes "0 < j" and "j + 8 < k" and "G \<ge> 6"
+  shows "turing_machine k G (tm_PHI2 j)"
+  unfolding tm_PHI2_def
+  using assms tm_Psigamma_tm tm_extendl_tm tm_erase_cr_tm tm_times2_tm tm_incr_tm tm_setn_tm tm_cr_tm tm_extendl_erase_tm
+  by simp
+
+locale turing_machine_PHI2 =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_times2 j"
+definition "tm2 \<equiv> tm1 ;; tm_incr j"
+definition "tm3 \<equiv> tm2 ;; tm_setn (j + 2) 3"
+definition "tm4 \<equiv> tm3 ;; tm_Psigamma j"
+definition "tm5 \<equiv> tm4 ;; tm_extendl_erase 1 (j + 6)"
+definition "tm7 \<equiv> tm5 ;; tm_incr j"
+definition "tm8 \<equiv> tm7 ;; tm_Psigamma j"
+definition "tm9 \<equiv> tm8 ;; tm_extendl 1 (j + 6)"
+
+lemma tm9_eq_tm_PHI2: "tm9 = tm_PHI2 j"
+  using tm9_def tm8_def tm7_def tm5_def tm4_def tm3_def tm2_def tm1_def tm_PHI2_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k idx H :: nat and nss :: "nat list list"
+  assumes jk: "length tps0 = k" "1 < j" "j + 7 < k"
+    and H: "H \<ge> 3"
+  assumes tps0:
+    "tps0 ! 1 = nlltape nss"
+    "tps0 ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j := (\<lfloor>2 * idx\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 5 + 2 * nlength idx"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def by (tform tps: tps0 tps1_def jk assms)
+
+definition "tps2 \<equiv> tps0
+  [j := (\<lfloor>2 * idx + 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2:
+  assumes "ttt = 10 + 2 * nlength idx + 2 * nlength (2 * idx)"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: tps0 H tps1_def tps2_def jk assms)
+
+lemma tm2' [transforms_intros]:
+  assumes "ttt = 12 + 4 * nlength idx"
+  shows "transforms tm2 tps0 ttt tps2"
+proof -
+  have "10 + 2 * nlength idx + 2 * nlength (2 * idx) \<le> 10 + 2 * nlength idx + 2 * (Suc (nlength idx))"
+    using nlength_times2 by (meson add_left_mono mult_le_mono2)
+  then have "10 + 2 * nlength idx + 2 * nlength (2 * idx) \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using tm2 transforms_monotone by simp
+qed
+
+definition "tps3 \<equiv> tps0
+  [j := (\<lfloor>2 * idx + 1\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 26 + 4 * nlength idx"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps0 H tps2_def tps3_def jk)
+  show "tps2 ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps2_def jk canrepr_0 tps0 by simp
+  show "ttt = 12 + 4 * nlength idx + (10 + 2 * nlength 0 + 2 * nlength 3)"
+    using nlength_3 assms by simp
+qed
+
+definition "tps4 \<equiv> tps0
+  [j := (\<lfloor>2 * idx + 1\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi (Suc (2 * idx) * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 26 + 4 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def by (tform tps: tps0 H tps3_def tps4_def jk time: assms)
+
+definition "tps5 \<equiv> tps0
+  [j := (\<lfloor>2 * idx + 1\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>[]\<rfloor>, 1),
+   1 := nlltape (nss @ nll_Psi (H + 2 * idx * H) H 3)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 37 + 4 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+      4 * nlllength (nll_Psi (H + 2 * idx * H) H 3)"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def by (tform tps: tps0 H tps4_def tps5_def jk time: assms)
+
+definition "tps7 \<equiv> tps0
+  [j := (\<lfloor>2 * idx + 2\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>[]\<rfloor>, 1),
+   1 := nlltape (nss @ nll_Psi (H + 2 * idx * H) H 3)]"
+
+lemma tm7:
+  assumes "ttt = 42 + 4 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+    4 * nlllength (nll_Psi (H + 2 * idx * H) H 3) + 2 * nlength (Suc (2 * idx))"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def
+proof (tform tps: tps0 H tps5_def tps7_def jk time: assms)
+  show "tps7 = tps5[j := (\<lfloor>Suc (Suc (2 * idx))\<rfloor>\<^sub>N, 1)]"
+    using tps5_def tps7_def jk by (simp add: list_update_swap)
+qed
+
+lemma tm7' [transforms_intros]:
+  assumes "ttt = 44 + 6 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+      4 * nlllength (nll_Psi (H + 2 * idx * H) H 3)"
+  shows "transforms tm7 tps0 ttt tps7"
+proof -
+  let ?ttt = "42 + 4 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+      4 * nlllength (nll_Psi (H + 2 * idx * H) H 3) +
+      2 * nlength (Suc (2 * idx))"
+  have "?ttt \<le> 42 + 4 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+      4 * nlllength (nll_Psi (H + 2 * idx * H) H 3) +
+      2 * (Suc (nlength idx))"
+    using nlength_times2plus1 by (metis add.commute add_left_mono mult_le_mono2 plus_1_eq_Suc)
+  then have "?ttt \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using tm7 transforms_monotone by simp
+qed
+
+definition "tps8 \<equiv> tps0
+  [j := (\<lfloor>2 * idx + 2\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi (Suc (Suc (2 * idx)) * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   1 := nlltape (nss @ nll_Psi (H + 2 * idx * H) H 3)]"
+
+lemma tm8 [transforms_intros]:
+  assumes "ttt = 44 + 6 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+      4 * nlllength (nll_Psi (H + 2 * idx * H) H 3) +
+      1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * idx)))))\<^sup>2"
+  shows "transforms tm8 tps0 ttt tps8"
+  unfolding tm8_def
+proof (tform tps: tps0 H tps7_def tps8_def jk time: assms)
+  show "tps8 = tps7
+      [j + 6 := (\<lfloor>nll_Psi (Suc (Suc (2 * idx)) * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+    unfolding tps8_def tps7_def by (simp add: list_update_swap[of "j+6"])
+qed
+
+definition "tps9 \<equiv> tps0
+  [j := (\<lfloor>2 * idx + 2\<rfloor>\<^sub>N, 1),
+   j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi (Suc (Suc (2 * idx)) * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+   1 := nlltape (nss @ nll_Psi (H + 2 * idx * H) H 3 @ nll_Psi (2 * H + 2 * idx * H) H 3)]"
+
+lemma tm9:
+  assumes "ttt = 48 + 6 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+      4 * nlllength (nll_Psi (H + 2 * idx * H) H 3) +
+      1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * idx)))))\<^sup>2 +
+      2 * nlllength (nll_Psi (2 * H + 2 * idx * H) H 3)"
+  shows "transforms tm9 tps0 ttt tps9"
+  unfolding tm9_def by (tform tps: tps0 H tps9_def tps8_def jk time: assms)
+
+lemma tm9':
+  assumes "ttt = 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * idx * H))\<^sup>2"
+  shows "transforms tm9 tps0 ttt tps9"
+proof -
+  let ?ttt = "48 + 6 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+      4 * nlllength (nll_Psi (H + 2 * idx * H) H 3) + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * idx)))))\<^sup>2 +
+      2 * nlllength (nll_Psi (2 * H + 2 * idx * H) H 3)"
+  have "?ttt \<le> 48 + 6 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+      4 * H * (3 + nlength (2 * H + 2 * idx * H + H)) + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * idx)))))\<^sup>2 +
+      2 * nlllength (nll_Psi (2 * H + 2 * idx * H) H 3)"
+    using nlllength_nll_Psi_le'[of "H + 2 * idx * H" "2 * H + 2 * idx * H" H 3] by simp
+  also have "... \<le> 48 + 6 * nlength idx + 1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+      5 * H * (3 + nlength (2 * H + 2 * idx * H + H)) + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * idx)))))\<^sup>2 +
+      3 * H * (3 + nlength (2 * H + 2 * idx * H + H))"
+    using nlllength_nll_Psi_le'[of "2 * H + 2 * idx * H" "2 * H + 2 * idx * H" H 3] by simp
+  also have "... = 48 + 6 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc (2 * idx))))\<^sup>2 +
+      8 * H * (3 + nlength (2 * H + 2 * idx * H + H)) +
+      1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * idx)))))\<^sup>2"
+    by simp
+  also have "... \<le> 48 + 6 * nlength idx +
+      1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * idx)))))\<^sup>2 +
+      8 * H * (3 + nlength (2 * H + 2 * idx * H + H)) +
+      1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * idx)))))\<^sup>2"
+    using H4_nlength H by simp
+  also have "... = 48 + 6 * nlength idx + 3702 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * idx)))))\<^sup>2 +
+      8 * H * (3 + nlength (3 * H + 2 * idx * H))"
+    by simp
+  also have "... \<le> 48 + 6 * nlength idx + 3702 * H ^ 4 * (3 + nlength (3 * H + 2 * idx * H))\<^sup>2 +
+      8 * H * (3 + nlength (3 * H + 2 * idx * H))"
+  proof -
+    have "Suc (Suc (Suc (2 * idx))) \<le> 3 * H + 2 * idx * H"
+      using H
+      by (metis One_nat_def Suc3_eq_add_3 Suc_eq_plus1_left add_leD1 comm_monoid_mult_class.mult_1
+        distrib_right mult.commute mult_le_mono1)
+    then have "nlength (Suc (Suc (Suc (2 * idx)))) \<le> 3 + nlength (3 * H + 2 * idx * H)"
+      using nlength_mono trans_le_add2 by blast
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<le> 48 + 6 * nlength idx + 3702 * H ^ 4 * (3 + nlength (3 * H + 2 * idx * H))\<^sup>2 +
+      8 * H^4 * (3 + nlength (3 * H + 2 * idx * H))"
+    using linear_le_pow by simp
+  also have "... \<le> 48 + 6 * nlength idx + 3702 * H ^ 4 * (3 + nlength (3 * H + 2 * idx * H))\<^sup>2 +
+      8 * H^4 * (3 + nlength (3 * H + 2 * idx * H))^2"
+    using linear_le_pow by simp
+  also have "... = 48 + 6 * nlength idx + 3710 * H ^ 4 * (3 + nlength (3 * H + 2 * idx * H))\<^sup>2"
+    by simp
+  also have "... \<le> 48 + 3716 * H ^ 4 * (3 + nlength (3 * H + 2 * idx * H))\<^sup>2"
+  proof -
+    have "nlength idx \<le> nlength (3 * H + 2 * idx * H)"
+      using H by (intro nlength_mono) (simp add: trans_le_add2)
+    also have "... \<le> 3 + nlength (3 * H + 2 * idx * H)"
+      by simp
+    also have "... \<le> (3 + nlength (3 * H + 2 * idx * H)) ^ 2"
+      using linear_le_pow by simp
+    also have "... \<le> H ^ 4 * (3 + nlength (3 * H + 2 * idx * H)) ^ 2"
+      using H by simp
+    finally have "nlength idx \<le> H ^ 4 * (3 + nlength (3 * H + 2 * idx * H)) ^ 2" .
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<le> 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * idx * H))\<^sup>2"
+  proof -
+    have "1 \<le> nlength (3 * H + 2 * idx * H)"
+      using H nlength_0
+      by (metis One_nat_def Suc_leI add_eq_0_iff_both_eq_0 length_0_conv length_greater_0_conv mult_Suc
+        not_numeral_le_zero numeral_3_eq_3)
+    also have "... \<le> 3 + nlength (3 * H + 2 * idx * H)"
+      by simp
+    also have "... \<le> (3 + nlength (3 * H + 2 * idx * H)) ^ 2"
+      using linear_le_pow by simp
+    also have "... \<le> H ^ 4 * (3 + nlength (3 * H + 2 * idx * H)) ^ 2"
+      using H by simp
+    finally have "1 \<le> H ^ 4 * (3 + nlength (3 * H + 2 * idx * H)) ^ 2" .
+    then show ?thesis
+      by simp
+  qed
+  finally have "?ttt \<le> 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * idx * H))\<^sup>2" .
+  then show ?thesis
+    using assms tm9 transforms_monotone by simp
+qed
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_PHI2 *)
+
+lemma transforms_tm_PHI2I:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k idx H :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 8 < k"
+    and "H \<ge> 3"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 8) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 3764 * H ^ 4 * (3 + nlength (3 * H + 2 * idx * H))\<^sup>2"
+  assumes "tps' = tps
+    [j := (\<lfloor>2 * idx + 2\<rfloor>\<^sub>N, 1),
+     j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>nll_Psi (Suc (Suc (2 * idx)) * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1),
+     1 := nlltape (nss @ nll_Psi (H + 2 * idx * H) H 3 @ nll_Psi (2 * H + 2 * idx * H) H 3)]"
+  shows "transforms (tm_PHI2 j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_PHI2 j .
+  show ?thesis
+    using loc.tm9' loc.tps9_def loc.tm9_eq_tm_PHI2 assms by simp
+qed
+
+
+subsection \<open>Turing machines for $\Phi_3$, $\Phi_4$, and $\Phi_5$\<close>
+
+text \<open>
+The CNF formulas $\Phi_3$, $\Phi_4$, and $\Phi_5$ have a similar structure and
+can thus be handled by the same Turing machine. The following TM has a parameter
+$step$ and the usual tape parameter $j$. It expects on tape $j$ a number $idx$,
+on tape $j + 1$ a number $H$, on tape $j + 2$ a number $\kappa$, and on tape $j
++ 8$ the number $idx + step \cdot numiter$ for some number $numiter$. It appends
+to the CNF formula on tape~$1$ the formula $\Psi(\gamma_{idx}, \kappa) \land
+\Psi(\gamma_{idx + step\cdot (numiter - 1)}, \kappa)$, where $\gamma_i = [iH,
+(i+1)H)$.
+
+\null
+\<close>
+
+definition tm_PHI345 :: "nat \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_PHI345 step j \<equiv>
+    WHILE tm_equalsn j (j + 8) (j + 3) ; \<lambda>rs. rs ! (j + 3) = \<box> DO
+      tm_Psigamma j ;;
+      tm_extendl_erase 1 (j + 6) ;;
+      tm_plus_const step j
+    DONE"
+
+lemma tm_PHI345_tm:
+  assumes "G \<ge> 6" and "0 < j" and "j + 8 < k"
+  shows "turing_machine k G (tm_PHI345 step j)"
+  unfolding tm_PHI345_def
+  using assms tm_equalsn_tm tm_Psigamma_tm tm_extendl_erase_tm tm_plus_const_tm
+    turing_machine_loop_turing_machine
+  by simp
+
+locale turing_machine_PHI345 =
+  fixes step :: nat and j :: tapeidx
+begin
+
+definition "tmC \<equiv> tm_equalsn j (j + 8) (j + 3)"
+definition "tm1 \<equiv> tm_Psigamma j"
+definition "tm2 \<equiv> tm1 ;; tm_extendl_erase 1 (j + 6)"
+definition "tm4 \<equiv> tm2 ;; tm_plus_const step j"
+definition "tmL \<equiv> WHILE tmC ; \<lambda>rs. rs ! (j + 3) = \<box> DO tm4 DONE"
+
+lemma tmL_eq_tm_PHI345: "tmL = tm_PHI345 step j"
+  unfolding tmL_def tm4_def tm2_def tm1_def tm_PHI345_def tmC_def by simp
+
+context
+  fixes tps0 :: "tape list" and numiter H k idx kappa :: nat and nss :: "nat list list"
+  assumes jk: "length tps0 = k" "1 < j" "j + 8 < k"
+    and H: "H \<ge> 3"
+    and kappa: "kappa \<le> H"
+    and step: "step > 0"
+  assumes tps0:
+    "tps0 ! 1 = nlltape nss"
+    "tps0 ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>kappa\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 8) = (\<lfloor>idx + step * numiter\<rfloor>\<^sub>N, 1)"
+begin
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [j := (\<lfloor>idx + step * t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<t]))]"
+
+lemma tpsL_eq_tps0: "tpsL 0 = tps0"
+proof -
+  have "\<lfloor>idx\<rfloor>\<^sub>N = \<lfloor>idx + step * 0\<rfloor>\<^sub>N"
+    by simp
+  moreover have "nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<0])) = nlltape nss"
+    using nllcontents_Nil by simp
+  ultimately show ?thesis
+    using tpsL_def tps0 jk by (metis list_update_id)
+qed
+
+definition tpsC :: "nat \<Rightarrow> tape list" where
+  "tpsC t \<equiv> tps0
+    [j := (\<lfloor>idx + step * t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<t])),
+     j + 3 := (\<lfloor>t = numiter\<rfloor>\<^sub>B, 1)]"
+
+lemma tmC:
+  assumes "t \<le> numiter"
+    and "ttt = 3 * nlength (idx + step * t) + 7"
+  shows "transforms tmC (tpsL t) ttt (tpsC t)"
+  unfolding tmC_def
+proof (tform tps: tps0 tpsL_def jk)
+  show "tpsL t ! (j + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using canrepr_0 jk tpsL_def tps0 by simp
+  show "(0::nat) \<le> 1"
+    by simp
+  show "tpsC t = (tpsL t)
+      [j + 3 := (\<lfloor>idx + step * t = idx + step * numiter\<rfloor>\<^sub>B, 1)]"
+    using step tpsC_def jk tpsL_def tps0 by simp
+  show "ttt = 3 * nlength (min (idx + step * t) (idx + step * numiter)) + 7"
+    using assms by (simp add: min_def)
+qed
+
+lemma tmC' [transforms_intros]:
+  assumes "t \<le> numiter"
+    and "ttt = 3 * nlength (idx + step * numiter) + 7"
+  shows "transforms tmC (tpsL t) ttt (tpsC t)"
+proof -
+  have "3 * nlength (idx + step * t) + 7 \<le> ttt"
+    using assms nlength_mono by simp
+  then show ?thesis
+    using assms tmC transforms_monotone by blast
+qed
+
+definition tpsL0 :: "nat \<Rightarrow> tape list" where
+  "tpsL0 t \<equiv> tps0
+    [j := (\<lfloor>idx + step * t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<t]))]"
+
+lemma tpsL0_eq_tpsC:
+  assumes "t < numiter"
+  shows "tpsL0 t = tpsC t"
+  unfolding tpsL0_def tpsC_def
+  using assms jk ncontents_0 tps0 list_update_id[of tps0 "j + 3"]
+  by (simp add: list_update_swap)
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+  "tpsL1 t \<equiv> tps0
+    [j := (\<lfloor>idx + step * t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<t])),
+     j + 6 := (\<lfloor>nll_Psi ((idx+step*t) * H) H kappa\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "t < numiter"
+    and "ttt = 1851 * H ^ 4 * (nlength (Suc (idx+step*t)))\<^sup>2"
+  shows "transforms tm1 (tpsL0 t) ttt (tpsL1 t)"
+  unfolding tm1_def by (tform tps: H kappa tps0 tpsL0_def tpsL1_def jk time: assms(2))
+
+definition tpsL2 :: "nat \<Rightarrow> tape list" where
+  "tpsL2 t \<equiv> tps0
+    [j := (\<lfloor>idx + step * t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<t])),
+     j + 6 := (\<lfloor>[]\<rfloor>, 1),
+     1 := nlltape ((nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<t])) @ nll_Psi ((idx+step*t) * H) H kappa)]"
+
+lemma tm2:
+  assumes "t < numiter"
+    and "ttt = 1851 * H ^ 4 * (nlength (Suc (idx + step * t)))\<^sup>2 +
+      (11 + 4 * nlllength (nll_Psi ((idx + step * t) * H) H kappa))"
+  shows "transforms tm2 (tpsL0 t) ttt (tpsL2 t)"
+  unfolding tm2_def by (tform tps: assms H kappa tps0 tpsL1_def tpsL2_def jk)
+
+definition tpsL2' :: "nat \<Rightarrow> tape list" where
+  "tpsL2' t \<equiv> tps0
+    [j := (\<lfloor>idx + step * t\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>[]\<rfloor>, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<t]) @ nll_Psi ((idx+step*t) * H) H kappa)]"
+
+lemma tpsL2': "tpsL2 t = tpsL2' t"
+  unfolding tpsL2_def tpsL2'_def by (simp only: list_update_swap list_update_overwrite) simp
+
+lemma tm2':
+  assumes "t < numiter"
+    and "ttt = 1851 * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 +
+      (11 + 4 * nlllength (nll_Psi ((idx + step * t) * H) H kappa))"
+  shows "transforms tm2 (tpsL0 t) ttt (tpsL2' t)"
+proof -
+  let ?ttt = "1851 * H ^ 4 * (nlength (Suc (idx + step * t)))\<^sup>2 +
+      (11 + 4 * nlllength (nll_Psi ((idx + step * t) * H) H kappa))"
+  have "?ttt \<le> 1851 * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 +
+      (11 + 4 * nlllength (nll_Psi ((idx + step * t) * H) H kappa))"
+  proof -
+    have "Suc (idx + step * t) \<le> Suc (idx + step * (numiter - 1))"
+      using assms(1) step by simp
+    also have "... = Suc (idx + step * numiter - step)"
+      by (metis Nat.add_diff_assoc One_nat_def Suc_le_eq add_less_same_cancel1 assms(1) mult.right_neutral
+       nat_mult_le_cancel_disj nat_neq_iff not_add_less1 right_diff_distrib')
+    also have "... \<le> idx + step * numiter"
+      using step Suc_le_eq assms(1) by simp
+    finally have "Suc (idx + step * t) \<le> idx + step * numiter" .
+    then have "nlength (Suc (idx + step * t)) \<le> nlength (idx + step * numiter)"
+      using nlength_mono by simp
+    then show ?thesis
+      by simp
+  qed
+  then have "transforms tm2 (tpsL0 t) ttt (tpsL2 t)"
+    using assms tm2 transforms_monotone by blast
+  then show ?thesis
+    using tpsL2' by simp
+qed
+
+definition tpsL2'' :: "nat \<Rightarrow> tape list" where
+  "tpsL2'' t \<equiv> tps0
+    [j := (\<lfloor>idx + step * t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<Suc t])),
+     j + 6 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tpsL2'': "tpsL2'' t = tpsL2' t"
+proof -
+  have "nll_Psi ((idx+step*t) * H) H kappa = nll_Psi (H * (idx+step*t)) H kappa"
+    by (simp add: mult.commute)
+  then have "concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<t]) @ nll_Psi ((idx+step*t) * H) H kappa =
+      concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<Suc t])"
+    by simp
+  then show "tpsL2'' t = tpsL2' t"
+    using tpsL2'_def tpsL2''_def by (simp add: list_update_swap)
+qed
+
+lemma nlllength_nll_Psi:
+  assumes "t < numiter"
+  shows "nlllength (nll_Psi ((idx + step * t) * H) H kappa) \<le> 5 * H ^ 4 * nlength (idx + step * numiter)^2"
+proof -
+  have "nlllength (nll_Psi ((idx + step * t) * H) H kappa) \<le> H * (3 + nlength ((idx + step * t) * H + H))"
+    using nlllength_nll_Psi_le by simp
+  also have "... \<le> H * (3 + nlength ((idx + step * numiter) * H))"
+  proof -
+    have "(idx + 1 + step * t) \<le> (idx + step * Suc t)"
+      using step by simp
+    then have "(idx + 1 + step * t) \<le> (idx + step * numiter)"
+      using assms(1) Suc_le_eq by auto
+    then have "(idx + 1 + step * t) * H \<le> (idx + step * numiter) * H"
+      using mult_le_cancel2 by blast
+    then show ?thesis
+      using nlength_mono by simp
+  qed
+  also have "... = 3 * H + H * nlength ((idx + step * numiter) * H)"
+    by algebra
+  also have "... \<le> 3 * H + H * (nlength (idx + step * numiter) + nlength H)"
+    using nlength_prod by simp
+  also have "... \<le> 3 * H + H * (nlength (idx + step * numiter) + H)"
+    using nlength_le_n by simp
+  also have "... = 3 * H + H ^ 2 + H * nlength (idx + step * numiter)"
+    by algebra
+  also have "... \<le> 3 * H^4 + H ^ 2 + H * nlength (idx + step * numiter)"
+    using linear_le_pow by simp
+  also have "... \<le> 3 * H^4 + H ^ 4 + H * nlength (idx + step * numiter)"
+    using pow_mono' by simp
+  also have "... \<le> 4 * H^4 + H ^ 4 * nlength (idx + step * numiter)"
+    using linear_le_pow by simp
+  also have "... \<le> 4 * H^4 + H ^ 4 * nlength (idx + step * numiter)^2"
+    using linear_le_pow by simp
+  also have "... \<le> 5 * H ^ 4 * nlength (idx + step * numiter)^2"
+  proof -
+    have "idx + step * numiter > 0"
+      using assms(1) step by simp
+    then have "nlength (idx + step * numiter) > 0"
+      using nlength_0 by simp
+    then have "nlength (idx + step * numiter) ^ 2 > 0"
+      by simp
+    then have "H ^ 4 \<le> H ^ 4 * nlength (idx + step * numiter) ^ 2"
+      by (metis One_nat_def Suc_leI mult_numeral_1_right nat_mult_le_cancel_disj numerals(1))
+    then show ?thesis
+      by simp
+  qed
+  finally show ?thesis .
+qed
+
+lemma tm2'' [transforms_intros]:
+  assumes "t < numiter" and "ttt = 1871 * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 + 11"
+  shows "transforms tm2 (tpsL0 t) ttt (tpsL2'' t)"
+proof -
+  have "transforms tm2 (tpsL0 t) ttt (tpsL2' t)"
+    using tm2'[OF assms(1)] nlllength_nll_Psi[OF assms(1)] transforms_monotone assms(2) by simp
+  then show ?thesis
+    using tpsL2' tpsL2'' by simp
+qed
+
+definition tpsL4 :: "nat \<Rightarrow> tape list" where
+  "tpsL4 t \<equiv> tps0
+    [j := (\<lfloor>idx + step * Suc t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<Suc t])),
+     j + 6 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm4:
+  assumes "t < numiter"
+    and "ttt = 1871 * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 + 11 +
+      step * (5 + 2 * nlength (idx + step * t + step))"
+  shows "transforms tm4 (tpsL0 t) ttt (tpsL4 t)"
+  unfolding tm4_def
+proof (tform tps: assms(1) H kappa tps0 tpsL2''_def tpsL4_def jk)
+  have "idx + step * Suc t = idx + step * t + step"
+    by simp
+  then show "tpsL4 t = (tpsL2'' t)[j := (\<lfloor>idx + step * t + step\<rfloor>\<^sub>N, 1)]"
+    unfolding tpsL4_def tpsL2''_def using jk by (simp only: list_update_swap[of _ j] list_update_overwrite)
+  show "ttt = 1871 * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 + 11 +
+      step * (5 + 2 * nlength (idx + step * t + step))"
+    using assms(2) .
+qed
+
+lemma tm4':
+  assumes "t < numiter"
+    and "ttt = (6 * step + 1882) * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2"
+  shows "transforms tm4 (tpsC t) ttt (tpsL4 t)"
+proof -
+  let ?ttt = "1871 * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 + 11 +
+      step * (5 + 2 * nlength (idx + step * t + step))"
+  have "idx + step * t + step \<le> idx + step * numiter"
+    using assms(1)
+    by (metis Suc_le_eq add.assoc add.commute add_le_cancel_left add_mult_distrib2 mult_le_mono2 mult_numeral_1_right numerals(1) plus_1_eq_Suc)
+  then have "?ttt \<le> 1871 * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 + 11 +
+      step * (5 + 2 * nlength (idx + step * numiter))"
+    using nlength_mono by simp
+  also have "... = 1871 * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 + 11 +
+      step * 5 + step * 2 * nlength (idx + step * numiter)"
+    by algebra
+  also have "... \<le> 1871 * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 + 11 +
+      step * 5 + step * 2 * nlength (idx + step * numiter)^2"
+    by (simp add: linear_le_pow)
+  also have "... \<le> 1871 * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 + 11 +
+      step * 5 + step * H^4 * nlength (idx + step * numiter)^2"
+  proof -
+    have "2 < H"
+      using H by simp
+    then have "2 < H ^ 4"
+      using linear_le_pow by (meson le_trans not_less zero_less_numeral)
+    then show ?thesis
+      by simp
+  qed
+  also have "... = (step + 1871) * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 + (11 + step * 5)"
+    by algebra
+  also have "... \<le> (step + 1871) * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2 + (11 + step * 5) * H ^ 4 * (nlength (idx + step * numiter))^2"
+  proof -
+    have "H ^ 4 * (nlength (idx + step * numiter))^2 > 0"
+      using step assms(1) nlength_0 H by auto
+    then show ?thesis
+      by (smt (z3) One_nat_def Suc_leI add_mono_thms_linordered_semiring(2) mult.assoc mult_numeral_1_right nat_mult_le_cancel_disj numeral_code(1))
+  qed
+  also have "... = (6 * step + 1882) * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2"
+    by algebra
+  finally have "?ttt \<le> (6 * step + 1882) * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2" .
+  then have "transforms tm4 (tpsL0 t) ttt (tpsL4 t)"
+    using tm4 assms transforms_monotone by blast
+  then show ?thesis
+    using tpsL0_eq_tpsC assms(1) by simp
+qed
+
+lemma tm4'' [transforms_intros]:
+  assumes "t < numiter"
+    and "ttt = (6 * step + 1882) * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2"
+  shows "transforms tm4 (tpsC t) ttt (tpsL (Suc t))"
+proof -
+  have "tpsL4 t = tpsL (Suc t)"
+    using tpsL4_def tpsL_def jk tps0 list_update_id[of tps0 "j + 6"]
+    by (simp add: list_update_swap)
+  then show ?thesis
+    using tm4' assms by metis
+qed
+
+lemma tmL:
+  assumes "ttt = Suc numiter * (9 + (6 * step + 1885) * (H ^ 4 * (nlength (idx + step * numiter))\<^sup>2))"
+    and "nn = numiter"
+  shows "transforms tmL (tpsL 0) ttt (tpsC nn)"
+  unfolding tmL_def
+proof (tform tps: assms(2))
+  let ?ttt = "(6 * step + 1882) * H ^ 4 * (nlength (idx + step * numiter))\<^sup>2"
+  show "\<And>t. t < nn \<Longrightarrow> read (tpsC t) ! (j + 3) = \<box>"
+    using assms(2) tpsC_def jk read_ncontents_eq_0 by simp
+  show "read (tpsC nn) ! (j + 3) \<noteq> \<box>"
+    using assms(2) tpsC_def jk read_ncontents_eq_0 by simp
+  show "nn * (3 * nlength (idx + step * numiter) + 7 + ?ttt + 2) + (3 * nlength (idx + step * numiter) + 7) + 1 \<le> ttt"
+    (is "?lhs \<le> ttt")
+  proof -
+    let ?g = "H ^ 4 * (nlength (idx + step * numiter))\<^sup>2"
+    have "nlength (idx + step * numiter) \<le> nlength (idx + step * numiter)^2"
+      using linear_le_pow by simp
+    moreover have "H ^ 4 > 0"
+      using H by simp
+    ultimately have *: "nlength (idx + step * numiter) \<le> ?g"
+      by (metis ab_semigroup_mult_class.mult_ac(1) le_square mult.left_commute nat_mult_le_cancel_disj power2_eq_square)
+    have "?lhs = numiter * (3 * nlength (idx + step * numiter) + 9 + ?ttt) + 3 * nlength (idx + step * numiter) + 8"
+      using assms(2) by simp
+    also have "... \<le> numiter * (3 * nlength (idx + step * numiter) + 9 + ?ttt) + 3 * ?g + 8"
+      using * by simp
+    also have "... \<le> numiter * (3 * ?g + 9 + (6 * step + 1882) * ?g) + 3 * ?g + 8"
+      using * by simp
+    also have "... = numiter * (9 + (6 * step + 1885) * ?g) + 3 * ?g + 8"
+      by algebra
+    also have "... \<le> numiter * (9 + (6 * step + 1885) * ?g) + (6 * step + 1885) * ?g + 8"
+      by simp
+    also have "... \<le> numiter * (9 + (6 * step + 1885) * ?g) + (9 + (6 * step + 1885) * ?g)"
+      by simp
+    also have "... = Suc numiter * (9 + (6 * step + 1885) * ?g)"
+      by simp
+    finally show ?thesis
+      using assms(1) by simp
+  qed
+qed
+
+lemma tmL':
+  assumes "ttt = Suc numiter * (9 + (6 * step + 1885) * (H ^ 4 * (nlength (idx + step * numiter))\<^sup>2))"
+  shows "transforms tmL tps0 ttt (tpsC numiter)"
+  using assms tmL tpsL_eq_tps0 by simp
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_PHI345 *)
+
+lemma transforms_tm_PHI345I:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt step numiter H k idx kappa :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 8 < k"
+    and "H \<ge> 3"
+    and "kappa \<le> H"
+    and "step > 0"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>kappa\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 8) = (\<lfloor>idx + step * numiter\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = Suc numiter * (9 + (6 * step + 1885) * (H ^ 4 * (nlength (idx + step * numiter))\<^sup>2))"
+  assumes "tps' = tps
+    [j := (\<lfloor>idx + step * numiter\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (idx + step * i)) H kappa) [0..<numiter])),
+     j + 3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_PHI345 step j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_PHI345 step j .
+  show ?thesis
+    using assms loc.tmL' loc.tpsC_def loc.tmL_eq_tm_PHI345 by simp
+qed
+
+
+subsection \<open>A Turing machine for $\Phi_6$\<close>
+
+text \<open>
+The next Turing machine expects a symbol sequence $zs$ on input tape~$0$, the
+number~$2$ on tape $j$, and a number $H$ on tape $j + 1$. It appends to the CNF
+formula on tape~$1$ the formula $\bigwedge_{i=0}^{|zs| - 1} \Psi(\gamma_{2+2i},
+z_i)$, where $z_i$ is $2$ or $3$ if $zs_i$ is \textbf{0} or \textbf{1},
+respectively.
+\<close>
+
+definition tm_PHI6 :: "tapeidx \<Rightarrow> machine" where
+  "tm_PHI6 j \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! 0 \<noteq> \<box> DO
+      IF \<lambda>rs. rs ! 0 = \<zero> THEN
+        tm_setn (j + 2) 2
+      ELSE
+        tm_setn (j + 2) 3
+      ENDIF ;;
+      tm_Psigamma j ;;
+      tm_extendl_erase 1 (j + 6) ;;
+      tm_setn (j + 2) 0 ;;
+      tm_right 0 ;;
+      tm_plus_const 2 j
+    DONE"
+
+lemma tm_PHI6_tm:
+  assumes "G \<ge> 6" and "0 < j" and "j + 7 < k"
+  shows "turing_machine k G (tm_PHI6 j)"
+  unfolding tm_PHI6_def
+  using assms tm_Psigamma_tm tm_extendl_erase_tm tm_plus_const_tm
+    turing_machine_loop_turing_machine turing_machine_branch_turing_machine
+    tm_right_tm tm_setn_tm Nil_tm
+  by simp
+
+locale turing_machine_PHI6 =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> IF \<lambda>rs. rs ! 0 = \<zero> THEN tm_setn (j + 2) 2 ELSE tm_setn (j + 2) 3 ENDIF"
+definition "tm2 \<equiv> tm1 ;; tm_Psigamma j"
+definition "tm3 \<equiv> tm2 ;; tm_extendl_erase 1 (j + 6)"
+definition "tm4 \<equiv> tm3 ;; tm_setn (j + 2) 0"
+definition "tm5 \<equiv> tm4 ;; tm_right 0"
+definition "tm6 \<equiv> tm5 ;; tm_plus_const 2 j"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! 0 \<noteq> \<box> DO tm6 DONE"
+
+lemma tmL_eq_tm_PHI6: "tmL = tm_PHI6 j"
+  using tm6_def tm5_def tm4_def tm3_def tm2_def tm1_def tm_PHI6_def tmL_def by simp
+
+context
+  fixes tps0 :: "tape list" and k H :: nat and zs :: "symbol list" and nss :: "nat list list"
+  assumes jk: "length tps0 = k" "1 < j" "j + 7 < k"
+    and H: "H \<ge> 3"
+    and zs: "bit_symbols zs"
+  assumes tps0:
+    "tps0 ! 0 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps0 ! 1 = nlltape nss"
+    "tps0 ! j = (\<lfloor>2\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+lemma H0: "H > 0"
+  using H by simp
+
+lemma H_mult: "x \<le> H * x" "x \<le> x * H"
+  using H by simp_all
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [0 := (\<lfloor>zs\<rfloor>, Suc t),
+     j := (\<lfloor>2 + 2 * t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (2 + 2 * i)) H (zs ! i)) [0..<t]))]"
+
+lemma tpsL_eq_tps0: "tpsL 0 = tps0"
+proof -
+  have "(\<lfloor>zs\<rfloor>, 1) = (\<lfloor>zs\<rfloor>, Suc 0)"
+    by simp
+  moreover have "nlltape (concat (map (\<lambda>i. nll_Psi (H * (2 + 2 * i)) H (zs ! i)) [0..<0])) = (\<lfloor>[]\<rfloor>, 1)"
+    using nllcontents_Nil by simp
+  moreover have "2 = Suc (Suc 0)"
+    by simp
+  ultimately show ?thesis
+    using tpsL_def tps0 jk by simp (metis One_nat_def Suc_1 list_update_id)
+qed
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+  "tpsL1 t \<equiv> tps0
+    [0 := (\<lfloor>zs\<rfloor>, Suc t),
+     j := (\<lfloor>2 + 2 * t\<rfloor>\<^sub>N, 1),
+     j + 2 := (\<lfloor>zs ! t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (2 + 2 * i)) H (zs ! i)) [0..<t]))]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 16" and "t < length zs"
+  shows "transforms tm1 (tpsL t) ttt (tpsL1 t)"
+  unfolding tm1_def
+proof (tform tps: tpsL_def tps0 jk)
+  have *: "read (tpsL t) ! 0 = zs ! t"
+    using jk tpsL_def tapes_at_read'[of 0 "tpsL t"] assms(2) by simp
+  show "read (tpsL t) ! 0 = \<zero> \<Longrightarrow> tpsL1 t = (tpsL t)[j + 2 := (\<lfloor>2\<rfloor>\<^sub>N, 1)]"
+    using * tpsL_def tpsL1_def jk by (simp add: list_update_swap)
+  show "tpsL1 t = (tpsL t)[j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1)]" if "read (tpsL t) ! \<box> \<noteq> \<zero>"
+  proof -
+    have "zs ! t = \<one>"
+      using * that zs assms(2) by auto
+    then show ?thesis
+      using tpsL_def tpsL1_def jk by (simp add: list_update_swap)
+  qed
+  show "10 + 2 * nlength 0 + 2 * nlength 2 + 2 \<le> ttt"
+    using nlength_0 nlength_2 assms(1) by simp
+  show "10 + 2 * nlength 0 + 2 * nlength 3 + 1 \<le> ttt"
+    using nlength_0 nlength_3 assms(1) by simp
+qed
+
+definition tpsL2 :: "nat \<Rightarrow> tape list" where
+  "tpsL2 t \<equiv> tps0
+    [0 := (\<lfloor>zs\<rfloor>, Suc t),
+     j := (\<lfloor>2 + 2 * t\<rfloor>\<^sub>N, 1),
+     j + 2 := (\<lfloor>zs ! t\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>nll_Psi (2 * H + 2 * t * H) H (zs ! t)\<rfloor>\<^sub>N\<^sub>L\<^sub>L, Suc 0),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (2 + 2 * i)) H (zs ! i)) [0..<t]))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 16 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * t)))))\<^sup>2"
+    and "t < length zs"
+  shows "transforms tm2 (tpsL t) ttt (tpsL2 t)"
+  unfolding tm2_def
+proof (tform tps: assms(2) tps0 H tpsL1_def tpsL2_def jk time: assms(1))
+  show "zs ! t \<le> H"
+    using assms(2) H zs by auto
+qed
+
+definition tpsL3 :: "nat \<Rightarrow> tape list" where
+  "tpsL3 t \<equiv> tps0
+    [0 := (\<lfloor>zs\<rfloor>, Suc t),
+     j := (\<lfloor>2 + 2 * t\<rfloor>\<^sub>N, 1),
+     j + 2 := (\<lfloor>zs ! t\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>[]\<rfloor>, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (2 * H + H * (2 * i)) H (zs ! i)) [0..<Suc t]))]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 27 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * t)))))\<^sup>2 +
+      4 * nlllength (nll_Psi (2 * H + 2 * t * H) H (zs ! t))"
+    and "t < length zs"
+  shows "transforms tm3 (tpsL t) ttt (tpsL3 t)"
+  unfolding tm3_def
+proof (tform tps: assms(2) tps0 H tpsL2_def tpsL3_def jk time: assms(1))
+  have "nll_Psi (2 * H + H * (2 * t)) H = nll_Psi (2 * H + 2 * t * H) H"
+    by (simp add: mult.commute)
+  then have "(nss @ concat (map (\<lambda>i. nll_Psi (2 * H + H * (2 * i)) H (zs ! i)) [0..<t])) @
+            nll_Psi (2 * H + 2 * t * H) H (zs ! t) =
+        nss @ concat (map (\<lambda>i. nll_Psi (2 * H + H * (2 * i)) H (zs ! i)) [0..<Suc t])"
+    using assms(2) by simp
+  then show "tpsL3 t = (tpsL2 t)
+      [1 := nlltape
+            ((nss @ concat (map (\<lambda>i. nll_Psi (2 * H + H * (2 * i)) H (zs ! i)) [0..<t])) @
+              nll_Psi (2 * H + 2 * t * H) H (zs ! t)),
+       j + 6 := (\<lfloor>[]\<rfloor>, 1)]"
+    unfolding tpsL3_def tpsL2_def jk by (simp add: list_update_swap)
+qed
+
+definition tpsL4 :: "nat \<Rightarrow> tape list" where
+  "tpsL4 t \<equiv> tps0
+    [0 := (\<lfloor>zs\<rfloor>, Suc t),
+     j := (\<lfloor>2 + 2 * t\<rfloor>\<^sub>N, 1),
+     j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>[]\<rfloor>, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (2 * H + H * (2 * i)) H (zs ! i)) [0..<Suc t]))]"
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 41 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * t)))))\<^sup>2 +
+      4 * nlllength (nll_Psi (2 * H + 2 * t * H) H (zs ! t))"
+    and "t < length zs"
+  shows "transforms tm4 (tpsL t) ttt (tpsL4 t)"
+  unfolding tm4_def
+proof (tform tps: assms(2) tpsL3_def tpsL4_def jk)
+  have "zs ! t = 2 \<or> zs ! t = 3"
+    using zs assms(2) by auto
+  then show "ttt = 27 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * t)))))\<^sup>2 +
+      4 * nlllength (nll_Psi (2 * H + 2 * t * H) H (zs ! t)) +
+      (10 + 2 * nlength (zs ! t) + 2 * nlength 0)"
+    using nlength_2 nlength_3 assms(1) by auto
+qed
+
+definition tpsL5 :: "nat \<Rightarrow> tape list" where
+  "tpsL5 t \<equiv> tps0
+    [0 := (\<lfloor>zs\<rfloor>, Suc (Suc t)),
+     j := (\<lfloor>2 + 2 * t\<rfloor>\<^sub>N, 1),
+     j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>[]\<rfloor>, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (2 * H + H * (2 * i)) H (zs ! i)) [0..<Suc t]))]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 42 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * t)))))\<^sup>2 +
+      4 * nlllength (nll_Psi (2 * H + 2 * t * H) H (zs ! t))"
+    and "t < length zs"
+  shows "transforms tm5 (tpsL t) ttt (tpsL5 t)"
+  unfolding tm5_def
+proof (tform tps: assms(2) tps0 H tpsL4_def tpsL5_def jk time: assms(1))
+  have neq: "0 \<noteq> j"
+    using jk by simp
+  have "tpsL4 t ! 0 = (\<lfloor>zs\<rfloor>, Suc t)"
+    using tpsL4_def jk by simp
+  then show "tpsL5 t = (tpsL4 t)[0 := tpsL4 t ! 0 |+| 1]"
+    unfolding tpsL5_def tpsL4_def jk by (simp add: list_update_swap[OF neq] list_update_swap[of _ 0])
+qed
+
+definition tpsL6 :: "nat \<Rightarrow> tape list" where
+  "tpsL6 t \<equiv> tps0
+    [0 := (\<lfloor>zs\<rfloor>, Suc (Suc t)),
+     j := (\<lfloor>2 + 2 * (Suc t)\<rfloor>\<^sub>N, 1),
+     j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>[]\<rfloor>, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (2 * H + H * (2 * i)) H (zs ! i)) [0..<Suc t]))]"
+
+lemma tm6:
+  assumes "ttt = 52 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * t)))))\<^sup>2 +
+      4 * nlllength (nll_Psi (2 * H + 2 * t * H) H (zs ! t)) +
+      4 * nlength (4 + 2 * t)"
+    and "t < length zs"
+  shows "transforms tm6 (tpsL t) ttt (tpsL6 t)"
+  unfolding tm6_def
+proof (tform tps: tps0 H tpsL5_def tpsL6_def jk assms(2))
+  show "tpsL6 t = (tpsL5 t)[j := (\<lfloor>Suc (Suc (2 * t)) + 2\<rfloor>\<^sub>N, 1)]"
+    using tpsL6_def tpsL5_def jk by (simp add: list_update_swap)
+  have *: "4 + 2 * t = Suc (Suc (Suc (Suc (2 * t))))"
+    by simp
+  then show "ttt = 42 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * t)))))\<^sup>2 +
+      4 * nlllength (nll_Psi (2 * H + 2 * t * H) H (zs ! t)) +
+      2 * (5 + 2 * nlength (Suc (Suc (2 * t)) + 2))"
+    using assms(1) * by simp
+qed
+
+lemma tpsL6_eq_tpsL: "tpsL6 t = tpsL (Suc t)"
+proof -
+  have "tpsL (Suc t) ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    using tpsL_def tps0 jk by simp
+  then have "tpsL (Suc t) = (tpsL (Suc t))[j + 6 := (\<lfloor>[]\<rfloor>, 1)]"
+    using list_update_id by metis
+  moreover have "tpsL (Suc t) ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL_def tps0 jk canrepr_0 by simp
+  ultimately have "tpsL (Suc t) = (tpsL (Suc t))[j + 6 := (\<lfloor>[]\<rfloor>, 1), j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    using list_update_id by metis
+  moreover have "tpsL6 t = (tpsL (Suc t))[j + 6 := (\<lfloor>[]\<rfloor>, 1), j + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+    unfolding tpsL6_def tpsL_def by (simp add: list_update_swap)
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma tm6':
+  assumes "ttt = 133648 * H ^ 6 * length zs^2"
+    and "t < length zs"
+  shows "transforms tm6 (tpsL t) ttt (tpsL (Suc t))"
+proof -
+  have **: "Suc (2 * length zs)^2 \<le> 9 * length zs ^ 2"
+  proof -
+    have "Suc (2 * length zs)^2 = 1 + 2 * 2 * length zs + (2 * length zs)^2"
+      by (metis add.commute add_Suc_shift mult.assoc nat_mult_1_right one_power2 plus_1_eq_Suc power2_sum)
+    also have "... = 1 + 4 * length zs + 4 * length zs^2"
+      by simp
+    also have "... \<le> length zs + 4 * length zs + 4 * length zs^2"
+      using assms(2) by simp
+    also have "... = 5 * length zs + 4 * length zs^2"
+      by simp
+    also have "... \<le> 5 * length zs^2 + 4 * length zs^2"
+      using linear_le_pow by simp
+    also have "... = 9 * length zs^2"
+      by simp
+    finally show ?thesis
+      by simp
+  qed
+
+  have *: "t \<le> length zs - 1"
+    using assms(2) by simp
+
+  let ?ttt = "52 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * t)))))\<^sup>2 +
+      4 * nlllength (nll_Psi (2 * H + 2 * t * H) H (zs ! t)) +
+      4 * nlength (4 + 2 * t)"
+  have "?ttt = 52 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * t)))))\<^sup>2 +
+      4 * nlllength (nll_Psi (2 * H + H * (2 * t)) H (zs ! t)) +
+      4 * nlength (4 + 2 * t)"
+    by (simp add: mult.commute)
+  also have "... \<le> 52 + 1851 * H ^ 4 * (nlength (Suc (Suc (Suc (2 * t)))))\<^sup>2 +
+      4 * nlllength (nll_Psi (2 * H + H * (2 * t)) H (zs ! t)) +
+      4 * nlength (2 + 2 * length zs)"
+    using nlength_mono assms(2) by simp
+  also have "... \<le> 52 + 1851 * H ^ 4 * (nlength (Suc (2 * length zs)))\<^sup>2 +
+      4 * nlllength (nll_Psi (2 * H + H * (2 * t)) H (zs ! t)) +
+      4 * nlength (2 + 2 * length zs)"
+    using H4_nlength H assms(2) by simp
+  also have "... \<le> 52 + 1851 * H ^ 4 * (nlength (Suc (2 * length zs)))\<^sup>2 +
+      4 * H * (3 + nlength (3 * H + H * (2 * (length zs - 1)))) +
+      4 * nlength (2 + 2 * length zs)"
+    using nlllength_nll_Psi_le'[of "2 * H + H * (2 * t)" "2 * H + H * (2 * (length zs - 1))" H] *
+    by simp
+  also have "... = 52 + 1851 * H ^ 4 * (nlength (Suc (2 * length zs)))\<^sup>2 +
+      4 * H * (3 + nlength (H * (1 + 2 * length zs))) + 4 * nlength (2 + 2 * length zs)"
+  proof -
+    have "3 * H + H * (2 * (length zs - 1)) = H * (3 + 2 * (length zs - 1))"
+      by algebra
+    also have "... = H * (3 + 2 * length zs - 2)"
+      using assms(2)
+      by (metis Nat.add_diff_assoc Suc_pred add_mono_thms_linordered_semiring(1) le_numeral_extra(4)
+        length_greater_0_conv list.size(3) mult_2 nat_1_add_1 not_less_zero plus_1_eq_Suc
+        right_diff_distrib' trans_le_add1)
+    also have "... = H * (1 + 2 * length zs)"
+      by simp
+    finally have "3 * H + H * (2 * (length zs - 1)) = H * (1 + 2 * length zs)" .
+    then show ?thesis
+      by metis
+  qed
+  also have "... \<le> 52 + 1851 * H ^ 4 * (3 + nlength (Suc (2 * length zs)))\<^sup>2 +
+      4 * H * (3 + nlength (H * (1 + 2 * length zs))) + 4 * nlength (2 + 2 * length zs)"
+    by simp
+  also have "... \<le> 52 + 1851 * H ^ 4 * (3 + nlength (H * Suc (2 * length zs)))\<^sup>2 +
+      4 * H * (3 + nlength (H * Suc (2 * length zs))) + 4 * nlength (2 + 2 * length zs)"
+  proof -
+    have "Suc (2 * length zs) \<le> H * Suc (2 * length zs)"
+      using H_mult by blast
+    then have "nlength (Suc (2 * length zs))^2 \<le> nlength (H * Suc (2 * length zs))^2"
+      using nlength_mono by simp
+    then show ?thesis
+      by simp
+  qed
+  also have "... \<le> 52 + 1851 * H ^ 4 * (3 + nlength (H * Suc (2 * length zs)))\<^sup>2 +
+      4 * H * (3 + nlength (H * Suc (2 * length zs)))^2 + 4 * nlength (2 + 2 * length zs)"
+    using linear_le_pow by simp
+  also have "... \<le> 52 + 1851 * H ^ 4 * (3 + nlength (H * Suc (2 * length zs)))\<^sup>2 +
+      4 * H^4 * (3 + nlength (H * Suc (2 * length zs)))^2 + 4 * nlength (2 + 2 * length zs)"
+    using linear_le_pow by simp
+  also have "... = 52 + 1855 * H ^ 4 * (3 + nlength (H * Suc (2 * length zs)))\<^sup>2 +
+      4 * nlength (2 + 2 * length zs)"
+    by simp
+  also have "... \<le> 52 + 1855 * H ^ 4 * (3 + nlength (H * Suc (2 * length zs)))\<^sup>2 +
+      4 * nlength (H * Suc (2 * length zs))"
+  proof -
+    have "2 + 2 * m \<le> H * Suc (2 * m)" if "m > 0" for m
+      using H H_mult(2) by (metis Suc_leD add_mono eval_nat_numeral(3) mult.commute mult_Suc_right)
+    then have "2 + 2 * length zs \<le> H * Suc (2 * length zs)"
+      using assms(2) by (metis less_nat_zero_code not_gr_zero)
+    then show ?thesis
+      using nlength_mono by simp
+  qed
+  also have "... \<le> 52 + 1855 * H ^ 4 * (3 + H * Suc (2 * length zs))\<^sup>2 +
+      4 * nlength (H * Suc (2 * length zs))"
+    using nlength_le_n nlength_mono by simp
+  also have "... \<le> 52 + 1855 * H ^ 4 * (3 + H * Suc (2 * length zs))\<^sup>2 +
+      4 * (H * Suc (2 * length zs))"
+    using nlength_le_n nlength_mono by (meson add_left_mono mult_le_cancel1)
+  also have "... = 52 + 1855 * H ^ 4 * (3^2 + 2 * 3 * H * Suc (2 * length zs) + H^2 * Suc (2 * length zs)^2) +
+      4 * (H * Suc (2 * length zs))"
+    by algebra
+  also have "... \<le> 52 + 1855 * H ^ 4 * (72 * H^2 * length zs^2) + 4 * (H * Suc (2 * length zs))"
+  proof -
+    have "3^2 + 2 * 3 * H * Suc (2 * length zs) + H^2 * Suc (2 * length zs)^2 =
+        9 + 6 * H * Suc (2 * length zs) + H^2 * Suc (2 * length zs)^2"
+      by simp
+    also have "... \<le> 9 + 6 * H^2 * Suc (2 * length zs) + H^2 * Suc (2 * length zs)^2"
+      using H linear_le_pow by (simp add: add_mono)
+    also have "... \<le> 9 + 6 * H^2 * Suc (2 * length zs)^2 + H^2 * Suc (2 * length zs)^2"
+      using linear_le_pow by (meson add_le_mono1 add_left_mono le_refl mult_le_mono zero_less_numeral)
+    also have "... = 9 + 7 * H^2 * Suc (2 * length zs)^2"
+      by simp
+    also have "... \<le> 9 + 7 * H^2 * 9 * length zs^2"
+      using ** by simp
+    also have "... = 9 + 63 * H^2 * length zs^2"
+      by simp
+    also have "... \<le> 9 * H^2 * length zs^2 + 63 * H^2 * length zs^2"
+      using assms(2) H by simp
+    also have "... = 72 * H^2 * length zs^2"
+      by simp
+    finally have "3^2 + 2 * 3 * H * Suc (2 * length zs) + H^2 * Suc (2 * length zs)^2 \<le> 72 * H^2 * length zs^2" .
+    then show ?thesis
+      using add_le_mono le_refl mult_le_mono2 by presburger
+  qed
+  also have "... = 52 + 133560 * H ^ 6 * length zs^2 + 4 * (H * Suc (2 * length zs))"
+    by simp
+  also have "... \<le> 52 + 133560 * H ^ 6 * length zs^2 + 4 * (H * 9 * length zs ^ 2)"
+    using ** by (smt (verit) add_left_mono mult.assoc mult_le_cancel1 power2_nat_le_imp_le)
+  also have "... = 52 + 133560 * H ^ 6 * length zs^2 + 36 * H * length zs ^ 2"
+    by simp
+  also have "... \<le> 52 + 133560 * H ^ 6 * length zs^2 + 36 * H^6 * length zs ^ 2"
+    using linear_le_pow by simp
+  also have "... = 52 + 133596 * H ^ 6 * length zs^2"
+    by simp
+  also have "... \<le> 52 * H ^ 6 * length zs^2 + 133596 * H ^ 6 * length zs^2"
+    using H assms(2) by simp
+  also have "... = 133648 * H ^ 6 * length zs^2"
+    by simp
+  finally have "?ttt \<le> 133648 * H ^ 6 * length zs^2" .
+  then have "transforms tm6 (tpsL t) ttt (tpsL6 t)"
+    using tm6 assms transforms_monotone by blast
+  then show ?thesis
+    using tpsL6_eq_tpsL by simp
+qed
+
+lemma tmL:
+  assumes "ttt = 133650 * H ^ 6 * length zs ^ 3 + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (length zs))"
+  unfolding tmL_def
+proof (tform)
+  let ?t = "133648 * H ^ 6 * length zs^2"
+  show "\<And>i. i < length zs \<Longrightarrow> transforms tm6 (tpsL i) ?t (tpsL (Suc i))"
+    using tm6' by simp
+  have *: "read (tpsL t) ! 0 = \<lfloor>zs\<rfloor> (Suc t)" for t
+    using jk tapes_at_read'[symmetric, of 0 "tpsL t"] by (simp add: tpsL_def)
+  show "read (tpsL t) ! 0 \<noteq> \<box>" if "t < length zs" for t
+  proof -
+    have "read (tpsL t) ! 0 = zs ! t"
+      using that * by simp
+    then show ?thesis
+      using that zs by auto
+  qed
+  show "\<not> read (tpsL (length zs)) ! 0 \<noteq> \<box>"
+    using * by simp
+  show "length zs * (?t + 2) + 1 \<le> ttt"
+  proof (cases "length zs = 0")
+    case True
+    then show ?thesis
+      using assms(1) by simp
+  next
+    case False
+    then have "1 \<le> H^6 * length zs ^ 2"
+      using H linear_le_pow by (simp add: Suc_leI)
+    then have "?t + 2 \<le> 133650 * H ^ 6 * length zs^2"
+      by simp
+    then have "length zs * (?t + 2) \<le> length zs * 133650 * H ^ 6 * length zs^2"
+      by simp
+    then have "length zs * (?t + 2) \<le> 133650 * H ^ 6 * length zs^3"
+      by (simp add: power2_eq_square power3_eq_cube)
+    then show ?thesis
+      using assms(1) by simp
+  qed
+qed
+
+lemma tmL':
+  assumes "ttt = 133650 * H ^ 6 * length zs ^ 3 + 1"
+  shows "transforms tmL tps0 ttt (tpsL (length zs))"
+  using assms tmL tpsL_eq_tps0 by simp
+
+end
+
+end  (* locale turing_machine_PHI6 *)
+
+lemma transforms_tm_PHI6I:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k H :: nat and zs :: "symbol list" and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 7 < k"
+    and "H \<ge> 3"
+    and "bit_symbols zs"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! 0 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps ! j = (\<lfloor>2\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "tps' = tps
+    [0 := (\<lfloor>zs\<rfloor>, Suc (length zs)),
+     j := (\<lfloor>2 + 2 * length zs\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>i. nll_Psi (H * (2 + 2 * i)) H (zs ! i)) [0..<length zs]))]"
+  assumes "ttt = 133650 * H ^ 6 * length zs ^ 3 + 1"
+  shows "transforms (tm_PHI6 j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_PHI6 j .
+  show ?thesis
+    using assms loc.tpsL_def loc.tmL' loc.tmL_eq_tm_PHI6 by simp
+qed
+
+
+subsection \<open>A Turing machine for $\Phi_7$\<close>
+
+text \<open>
+The next Turing machine expects a number $idx$ on tape $j$, a number $H$ on tape
+$j + 1$, and a number $numiter$ on tape $j + 6$. It appends to the CNF formula
+on tape~$1$ the formula $\bigwedge_{t=0}^{numiter} \Upsilon(\gamma_{idx + 2t})$
+with $\gamma_i = [iH, (i+1)H)$. This equals $\Phi_7$ if $idx = 2n + 4$ and
+$numiter = p(n)$.
+\<close>
+
+definition tm_PHI7 :: "tapeidx \<Rightarrow> machine" where
+  "tm_PHI7 j \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! (j + 6) \<noteq> \<box> DO
+      tm_Upsilongamma j ;;
+      tm_extendl_erase 1 (j + 4) ;;
+      tm_plus_const 2 j ;;
+      tm_decr (j + 6)
+    DONE"
+
+lemma tm_PHI7_tm:
+  assumes "0 < j" and "j + 6 < k" and "6 \<le> G" and "2 \<le> k"
+  shows "turing_machine k G (tm_PHI7 j)"
+  unfolding tm_PHI7_def
+  using tm_Upsilongamma_tm tm_decr_tm Nil_tm tm_extendl_erase_tm tm_plus_const_tm assms turing_machine_loop_turing_machine
+  by simp
+
+locale turing_machine_tm_PHI7 =
+  fixes step :: nat and j :: tapeidx
+begin
+
+definition "tmL1 \<equiv> tm_Upsilongamma j"
+definition "tmL2 \<equiv> tmL1 ;; tm_extendl_erase 1 (j + 4)"
+definition "tmL4 \<equiv> tmL2 ;; tm_plus_const 2 j"
+definition "tmL5 \<equiv> tmL4 ;; tm_decr (j + 6)"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! (j + 6) \<noteq> \<box> DO tmL5 DONE"
+
+lemma tmL_eq_tm_PHI7: "tmL = tm_PHI7 j"
+  unfolding tmL_def tmL5_def tmL4_def tmL2_def tmL1_def tm_PHI7_def by simp
+
+context
+  fixes tps0 :: "tape list" and numiter H k idx :: nat and nss :: "nat list list"
+  assumes jk: "length tps0 = k" "1 < j" "j + 6 < k"
+    and H: "H \<ge> 3"
+  assumes tps0:
+    "tps0 ! 1 = nlltape nss"
+    "tps0 ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 6) = (\<lfloor>numiter\<rfloor>\<^sub>N, 1)"
+begin
+
+lemma nlength_H: "nlength H \<ge> 1"
+  using nlength_0 H by (metis dual_order.trans nlength_1_simp nlength_mono one_le_numeral)
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [j := (\<lfloor>idx + 2 * t\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>numiter - t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>t. nll_Upsilon (idx + 2 * t) H) [0..<t]))]"
+
+lemma tpsL_eq_tps0: "tpsL 0 = tps0"
+  using tpsL_def tps0 by auto (metis list_update_id)
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+  "tpsL1 t \<equiv> tps0
+    [j := (\<lfloor>idx + 2 * t\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>numiter - t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>t. nll_Upsilon (idx + 2 * t) H) [0..<t])),
+     j + 4 := (\<lfloor>nll_Upsilon (idx + 2 * t) H\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tmL1 [transforms_intros]:
+  assumes "t < numiter"
+    and "ttt = 205 * H * (nlength (idx + 2 * t) + nlength H)\<^sup>2"
+  shows "transforms tmL1 (tpsL t) ttt (tpsL1 t)"
+  unfolding tmL1_def by (tform tps: H tps0 tpsL_def tpsL1_def jk time: assms(2))
+
+definition tpsL2 :: "nat \<Rightarrow> tape list" where
+  "tpsL2 t \<equiv> tps0
+    [j := (\<lfloor>idx + 2 * t\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>numiter - t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>t. nll_Upsilon (idx + 2 * t) H) [0..<t]) @ (nll_Upsilon (idx + 2 * t) H)),
+     j + 4 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tmL2 [transforms_intros]:
+  assumes "t < numiter"
+    and "ttt = 11 + 205 * H * (nlength (idx + 2 * t) + nlength H)\<^sup>2 +
+      4 * nlllength (nll_Upsilon (idx + 2 * t) H)"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL2 t)"
+  unfolding tmL2_def by (tform tps: assms(1) H tps0 tpsL1_def tpsL2_def jk time: assms(2))
+
+definition tpsL4 :: "nat \<Rightarrow> tape list" where
+  "tpsL4 t \<equiv> tps0
+    [j := (\<lfloor>idx + 2 * Suc t\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>numiter - t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>t. nll_Upsilon (idx + 2 * t) H) [0..<t]) @ (nll_Upsilon (idx + 2 * t) H)),
+     j + 4 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tmL4 [transforms_intros]:
+  assumes "t < numiter"
+    and "ttt = 21 + 205 * H * (nlength (idx + 2 * t) + nlength H)\<^sup>2 +
+      4 * nlllength (nll_Upsilon (idx + 2 * t) H) + 4 * nlength (Suc (Suc (idx + 2 * t)))"
+  shows "transforms tmL4 (tpsL t) ttt (tpsL4 t)"
+  unfolding tmL4_def
+proof (tform tps: assms(1) H tps0 tpsL2_def tpsL4_def jk time: assms(2))
+  show "tpsL4 t = (tpsL2 t)[j := (\<lfloor>idx + 2 * t + 2\<rfloor>\<^sub>N, 1)]"
+    using tpsL4_def tpsL2_def jk by (simp add: list_update_swap[of j])
+qed
+
+definition tpsL5 :: "nat \<Rightarrow> tape list" where
+  "tpsL5 t \<equiv> tps0
+    [j := (\<lfloor>idx + 2 * Suc t\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>numiter - Suc t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>t. nll_Upsilon (idx + 2 * t) H) [0..<t]) @ (nll_Upsilon (idx + 2 * t) H)),
+     j + 4 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tmL5:
+  assumes "t < numiter"
+    and "ttt = 29 + 205 * H * (nlength (idx + 2 * t) + nlength H)\<^sup>2 +
+      4 * nlllength (nll_Upsilon (idx + 2 * t) H) + 4 * nlength (Suc (Suc (idx + 2 * t))) +
+      2 * nlength (numiter - t)"
+  shows "transforms tmL5 (tpsL t) ttt (tpsL5 t)"
+  unfolding tmL5_def
+proof (tform tps: assms(1) H tps0 tpsL4_def tpsL5_def jk time: assms(2))
+  show "tpsL5 t = (tpsL4 t)[j + 6 := (\<lfloor>numiter - t - 1\<rfloor>\<^sub>N, 1)]"
+    using tpsL5_def tpsL4_def jk by (simp add: list_update_swap[of "j+6"])
+qed
+
+lemma tpsL5_eq_tpsL: "tpsL5 t = tpsL (Suc t)"
+proof -
+  define tps where "tps = tps0
+    [j := (\<lfloor>idx + 2 * Suc t\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>numiter - Suc t\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>t. nll_Upsilon (idx + 2 * t) H) [0..<t]) @ (nll_Upsilon (idx + 2 * t) H))]"
+  then have "tps = tpsL (Suc t)"
+    using tpsL_def jk tps0 by simp
+  moreover have "tps = tpsL5 t"
+  proof -
+    have "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+      using tps_def jk tps0 by simp
+    then have "tps[j + 4 := (\<lfloor>[]\<rfloor>, 1)] = tps"
+      using list_update_id[of _ "j+4"] by metis
+    then show ?thesis
+      unfolding tps_def using tpsL5_def by simp
+  qed
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma tmL5' [transforms_intros]:
+  assumes "t < numiter"
+    and "ttt = 256 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2"
+  shows "transforms tmL5 (tpsL t) ttt (tpsL (Suc t))"
+proof -
+  let ?ttt = "29 + 205 * H * (nlength (idx + 2 * t) + nlength H)\<^sup>2 +
+      4 * nlllength (nll_Upsilon (idx + 2 * t) H) + 4 * nlength (Suc (Suc (idx + 2 * t))) +
+      2 * nlength (numiter - t)"
+  have "?ttt \<le> 29 + 205 * H * (nlength (idx + 2 * t) + nlength H)\<^sup>2 +
+      4 * nlllength (nll_Upsilon (idx + 2 * t) H) + 4 * nlength (Suc (Suc (idx + 2 * t))) +
+      2 * nlength numiter"
+    using nlength_mono by simp
+  also have "... \<le> 29 + 205 * H * (nlength (idx + 2 * t) + nlength H)\<^sup>2 +
+      4 * H * (4 + nlength (idx + 2 * t) + nlength H) + 4 * nlength (Suc (Suc (idx + 2 * t))) +
+      2 * nlength numiter"
+    using nlllength_nll_Upsilon_le H by simp
+  also have "... \<le> 29 + 205 * H * (nlength (idx + 2 * t) + nlength H)\<^sup>2 +
+      4 * H * (4 + nlength (idx + 2 * numiter) + nlength H) + 4 * nlength (Suc (Suc (idx + 2 * t))) +
+      2 * nlength numiter"
+    using nlength_mono assms(1) by simp
+  also have "... \<le> 29 + 205 * H * (nlength (idx + 2 * t) + nlength H)\<^sup>2 +
+      4 * H * (4 + nlength (idx + 2 * numiter) + nlength H) + 4 * nlength (idx + 2 * numiter) +
+      2 * nlength numiter"
+    using nlength_mono assms(1) by simp
+  also have "... \<le> 29 + 205 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 +
+      4 * H * (4 + nlength (idx + 2 * numiter) + nlength H) + 4 * nlength (idx + 2 * numiter) +
+      2 * nlength numiter"
+    using nlength_mono assms(1) by simp
+  also have "... \<le> 29 + 205 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 +
+      4 * H * (4 + nlength (idx + 2 * numiter) + nlength H) + 6 * nlength (idx + 2 * numiter)"
+    using nlength_mono by simp
+  also have "... \<le> 29 + 205 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 +
+      4 * H * (4 + nlength (idx + 2 * numiter) + nlength H) + 6 * (nlength (idx + 2 * numiter) + nlength H)"
+    using nlength_mono by simp
+  also have "... = 29 + 205 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 +
+      16 * H + 4 * H * (nlength (idx + 2 * numiter) + nlength H) + 6 * (nlength (idx + 2 * numiter) + nlength H)"
+    by algebra
+  also have "... \<le> 29 + 205 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 +
+      16 * H + 4 * H * (nlength (idx + 2 * numiter) + nlength H) + 2 * H * (nlength (idx + 2 * numiter) + nlength H)"
+  proof -
+    have "6 \<le> 2 * H"
+      using H by simp
+    then show ?thesis
+      using mult_le_mono1 nat_add_left_cancel_le by presburger
+  qed
+  also have "... = 29 + 205 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 +
+      16 * H + 6 * H * (nlength (idx + 2 * numiter) + nlength H)"
+    by simp
+  also have "... \<le> 29 + 205 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 +
+      16 * H + 6 * H * (nlength (idx + 2 * numiter) + nlength H)^2"
+    using linear_le_pow by simp
+  also have "... = 29 + 211 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 + 16 * H"
+    by simp
+  also have "... \<le> 29 + 227 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2"
+    using H nlength_0 by (simp add: Suc_leI)
+  also have "... \<le> 256 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2"
+    using H nlength_0 by (simp add: Suc_leI)
+  finally have "?ttt \<le> ttt"
+    using assms(2) by simp
+  then have "transforms tmL5 (tpsL t) ttt (tpsL5 t)"
+    using assms(1) tmL5 transforms_monotone by blast
+  then show ?thesis
+    using tpsL5_eq_tpsL by simp
+qed
+
+lemma tmL:
+  assumes "ttt = numiter * (257 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL numiter)"
+  unfolding tmL_def
+proof (tform)
+  show "\<And>i. i < numiter \<Longrightarrow> read (tpsL i) ! (j + 6) \<noteq> \<box>"
+    using jk tpsL_def read_ncontents_eq_0 by simp
+  show "\<not> read (tpsL numiter) ! (j + 6) \<noteq> \<box>"
+    using jk tpsL_def read_ncontents_eq_0 by simp
+  show "numiter * (256 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 + 2) + 1 \<le> ttt"
+  proof -
+    have "1 \<le> (nlength (idx + 2 * numiter) + nlength H)\<^sup>2"
+      using nlength_H by simp
+    then have "2 \<le> H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2"
+      using H by (metis add_leE mult_2 mult_le_mono nat_1_add_1 numeral_Bit1 numerals(1))
+    then show ?thesis
+      using assms by simp
+  qed
+qed
+
+lemma tmL':
+  assumes "ttt = numiter * 257 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 + 1"
+  shows "transforms tmL tps0 ttt (tpsL numiter)"
+  using assms tmL tpsL_eq_tps0 by (simp add: Groups.mult_ac(1))
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_tm_PHI7 *)
+
+lemma transforms_tm_PHI7I:
+  fixes tps tps' :: "tape list" and ttt numiter H k idx :: nat and nss :: "nat list list" and j :: tapeidx
+  assumes "length tps = k" and "1 < j" and "j + 6 < k"
+    and "H \<ge> 3"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>numiter\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = numiter * 257 * H * (nlength (idx + 2 * numiter) + nlength H)\<^sup>2 + 1"
+  assumes "tps' = tps
+    [j := (\<lfloor>idx + 2 * numiter\<rfloor>\<^sub>N, 1),
+     j + 6 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     1 := nlltape (nss @ concat (map (\<lambda>t. nll_Upsilon (idx + 2 * t) H) [0..<numiter]))]"
+  shows "transforms (tm_PHI7 j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_tm_PHI7 j .
+  show ?thesis
+    using assms loc.tmL' loc.tpsL_def loc.tmL_eq_tm_PHI7 by simp
+qed
+
+
+subsection \<open>A Turing machine for $\Phi_8$\<close>
+
+text \<open>
+The next TM expects a number $idx$ on tape $j$ and a number $H$ on tape $j + 1$.
+It appends to the formula on tape~$1$ the formula $\Psi([idx\cdot H, (idx+1)H),
+3)$.
+\<close>
+
+definition tm_PHI8 :: "tapeidx \<Rightarrow> machine" where
+  "tm_PHI8 j \<equiv>
+    tm_setn (j + 2) 3 ;;
+    tm_Psigamma j ;;
+    tm_extendl 1 (j + 6)"
+
+lemma tm_PHI8_tm:
+  assumes "0 < j" and "j + 7 < k" and "G \<ge> 6"
+  shows "turing_machine k G (tm_PHI8 j)"
+  unfolding tm_PHI8_def using assms tm_Psigamma_tm tm_setn_tm tm_extendl_tm by simp
+
+locale turing_machine_PHI8 =
+  fixes j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_setn (j + 2) 3"
+definition "tm2 \<equiv> tm1 ;; tm_Psigamma j"
+definition "tm3 \<equiv> tm2 ;; tm_extendl 1 (j + 6)"
+
+lemma tm3_eq_tm_PHI8: "tm3 = tm_PHI8 j"
+  using tm3_def tm2_def tm1_def tm_PHI8_def by simp
+
+context
+  fixes tps0 :: "tape list" and k idx H :: nat and nss :: "nat list list"
+  assumes jk: "length tps0 = k" "1 < j" "j + 7 < k"
+    and H: "H \<ge> 3"
+  assumes tps0:
+    "tps0 ! 1 = nlltape nss"
+    "tps0 ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 14"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps0 tps1_def jk)
+  show "tps0 ! (j + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps0 jk canrepr_0 by simp
+  show "ttt = 10 + 2 * nlength 0 + 2 * nlength 3"
+    using assms nlength_3 by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi (idx * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 14 + 1851 * H ^ 4 * nlength (Suc idx) ^ 2"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: tps0 H tps1_def tps2_def jk time: assms canrepr_1)
+
+definition "tps3 \<equiv> tps0
+  [1 := nlltape (nss @ nll_Psi (idx * H) H 3),
+   j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+   j + 6 := (\<lfloor>nll_Psi (idx * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+
+lemma tm3:
+  assumes "ttt = 18 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 +
+    2 * nlllength (nll_Psi (idx * H) H 3)"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def by (tform tps: tps0 H tps2_def tps3_def jk time: assms)
+
+lemma tm3':
+  assumes "ttt = 18 + 1861 * H ^ 4 * (nlength (Suc idx))\<^sup>2"
+  shows "transforms tm3 tps0 ttt tps3"
+proof -
+  have *: "(nlength (Suc idx))\<^sup>2 \<ge> 1"
+    using nlength_0 by (simp add: Suc_leI)
+  let ?ttt = "18 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 2 * nlllength (nll_Psi (idx * H) H 3)"
+  have "?ttt \<le> 18 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 2 * H * (3 + nlength (idx * H + H))"
+    using nlllength_nll_Psi_le by simp
+  also have "... = 18 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 2 * H * (3 + nlength (Suc idx * H))"
+    by (simp add: add.commute)
+  also have "... \<le> 18 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 2 * H * (3 + nlength (Suc idx) + nlength H)"
+    using nlength_prod by (metis (mono_tags, lifting) ab_semigroup_add_class.add_ac(1) add_left_mono mult_le_cancel1)
+  also have "... = 18 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 6 * H + 2 * H * nlength (Suc idx) + 2 * H * nlength H"
+    by algebra
+  also have "... \<le> 18 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 6 * H + 2 * H * nlength (Suc idx) + 2 * H * H"
+    using nlength_le_n by simp
+  also have "... \<le> 18 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 6 * H ^ 4 + 2 * H * nlength (Suc idx) + 2 * H * H"
+    using linear_le_pow[of 4 H] by simp
+  also have "... \<le> 18 + 1851 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 6 * H ^ 4 + 2 * H ^ 4 * nlength (Suc idx) + 2 * H * H"
+    using linear_le_pow[of 4 H] by simp
+  also have "... \<le> 18 + 1857 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 2 * H ^ 4 * nlength (Suc idx) + 2 * H * H"
+    using * by simp
+  also have "... \<le> 18 + 1859 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 2 * H * H"
+    using linear_le_pow[of 2 "nlength (Suc idx)"] by simp
+  also have "... = 18 + 1859 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 2 * H ^ 2"
+    by algebra
+  also have "... \<le> 18 + 1859 * H ^ 4 * (nlength (Suc idx))\<^sup>2 + 2 * H ^ 4"
+    using pow_mono'[of 2 4 H] by simp
+  also have "... \<le> 18 + 1861 * H ^ 4 * (nlength (Suc idx))\<^sup>2"
+    using * by simp
+  finally have "?ttt \<le> 18 + 1861 * H ^ 4 * (nlength (Suc idx))\<^sup>2" .
+  then show ?thesis
+    using tm3 assms transforms_monotone by simp
+qed
+
+end
+
+end  (* locale turing_machine_PHI8 *)
+
+lemma transforms_tm_PHI8I:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k idx H :: nat and nss :: "nat list list"
+  assumes "length tps = k" and "1 < j" and "j + 7 < k"
+    and "H \<ge> 3"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j = (\<lfloor>idx\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps ! (j + 2) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 3) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 4) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 5) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 6) = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j + 7) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "tps' = tps
+      [1 := nlltape (nss @ nll_Psi (idx * H) H 3),
+       j + 2 := (\<lfloor>3\<rfloor>\<^sub>N, 1),
+       j + 6 := (\<lfloor>nll_Psi (idx * H) H 3\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)]"
+  assumes "ttt = 18 + 1861 * H ^ 4 * (nlength (Suc idx))\<^sup>2"
+  shows "transforms (tm_PHI8 j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_PHI8 j .
+  show ?thesis
+    using loc.tps3_def loc.tm3' loc.tm3_eq_tm_PHI8 assms by metis
+qed
+
+
+subsection \<open>A Turing machine for $\Phi_9$\<close>
+
+text \<open>
+The CNF formula $\Phi_9 = \bigwedge_{t=1}^{T'}$ is the most complicated part of
+$\Phi$. Clearly, the main task here is to generate the formulas $\chi_t$
+\<close>
+
+
+subsubsection \<open>A Turing machine for $\chi_t$\<close>
+
+text \<open>
+A lemma that will help with some time bounds:
+\<close>
+
+lemma pow2_le_2pow2: "z ^ 2 \<le> 2 ^ (2*z)" for z :: nat
+proof (induction z)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc z)
+  show ?case
+  proof (cases "z = 0")
+    case True
+    then show ?thesis
+      by simp
+  next
+    case False
+    have "Suc z ^ 2 = z ^ 2 + 2 * z + 1"
+      by (metis Suc_eq_plus1 ab_semigroup_add_class.add_ac(1) nat_mult_1_right one_power2 plus_1_eq_Suc power2_sum)
+    also have "... \<le> z ^ 2 + 3 * z"
+      using False by simp
+    also have "... \<le> z ^ 2 + 3 * z ^ 2"
+      by (simp add: linear_le_pow)
+    also have "... = 2^2 * z ^ 2"
+      by simp
+    also have "... \<le> 2^2 * 2 ^ (2 * z)"
+      using Suc by simp
+    also have "... = 2 ^ (2 * Suc z)"
+      by (simp add: power_add)
+    finally show ?thesis .
+  qed
+qed
+
+text \<open>
+The next Turing machine can be used to generate $\chi_t$. It expects on tape~1 a
+CNF formula, on tape~$j_1$ the list of positions of $M$'s input tape head, on
+tape~$j_2$ the list of positions of $M$'s output tape head, on tapes~$j_3,
+\dots, j_3+3$ the numbers $N$, $G$, $Z$, and $T$, on tape~$j_3+4$ the formula
+$\psi$, on tape~$j_3+5$ the formula $\psi'$, and finally on tape~$j_3+6$ the
+number $t$. The TM appends the formula $\chi_t$ to the formula on tape~1, which
+should be thought of as an unfinished version of $\Phi$.
+
+The TM first computes $\prev(t)$ using @{const tm_prev} and compares it with
+$t$. Depending on the outcome of this comparison it generates either $\rho_t$ or
+$\rho'_t$ by concatenating ranges of numbers generated using @{const tm_range}.
+Then the TM uses @{const tm_relabel} to compute $\rho_t(\psi)$ or
+$\rho'_t(\psi')$. The result equals $\chi_t$ and is appended to tape~1.  Finally
+$t$ is incremented and $T$ is decremented. This is so the TM can be used inside
+a while loop that initializes $T$ with $T'$ and $t$ with $1$.
+
+\null
+\<close>
+
+definition tm_chi :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_chi j1 j2 j3 \<equiv>
+    tm_prev j2 (j3 + 6) ;;
+    tm_equalsn (j3 + 11) (j3 + 6) (j3 + 13) ;;
+    tm_decr (j3 + 6) ;;
+    tm_mult (j3 + 6) (j3 + 2) (j3 + 7) ;;
+    tm_add j3 (j3 + 7) ;;
+    tm_range (j3 + 7) (j3 + 2) (j3 + 8) ;;
+    tm_extend_erase (j3 + 12) (j3 + 8) ;;
+    tm_setn (j3 + 7) 0 ;;
+    IF \<lambda>rs. rs ! (j3 + 13) = \<box> THEN
+      tm_mult (j3 + 11) (j3 + 2) (j3 + 7) ;;
+      tm_add j3 (j3 + 7) ;;
+      tm_range (j3 + 7) (j3 + 2) (j3 + 8) ;;
+      tm_extend_erase (j3 + 12) (j3 + 8) ;;
+      tm_setn (j3 + 7) 0
+    ELSE
+      []
+    ENDIF ;;
+    tm_incr (j3 + 6) ;;
+    tm_mult (j3 + 6) (j3 + 2) (j3 + 7) ;;
+    tm_add j3 (j3 + 7) ;;
+    tm_range (j3 + 7) (j3 + 2) (j3 + 8) ;;
+    tm_extend_erase (j3 + 12) (j3 + 8) ;;
+    tm_setn (j3 + 11) 0 ;;
+    tm_nth j1 (j3 + 6) (j3 + 11) 4 ;;
+    tm_setn (j3 + 7) 0 ;;
+    tm_mult (j3 + 11) (j3 + 1) (j3 + 7) ;;
+    tm_range (j3 + 7) (j3 + 1) (j3 + 8) ;;
+    tm_extend_erase (j3 + 12) (j3 + 8) ;;
+    tm_setn (j3 + 7) 0 ;;
+    tm_erase_cr (j3 + 11) ;;
+    tm_cr (j3 + 12) ;;
+    IF \<lambda>rs. rs ! (j3 + 13) = \<box> THEN
+      tm_relabel (j3 + 4) (j3 + 11)
+    ELSE
+      tm_erase_cr (j3 + 13) ;;
+      tm_relabel (j3 + 5) (j3 + 11)
+    ENDIF ;;
+    tm_erase_cr (j3 + 12) ;;
+    tm_extendl_erase 1 (j3 + 11) ;;
+    tm_incr (j3 + 6) ;;
+    tm_decr (j3 + 3)"
+
+lemma tm_chi_tm:
+  assumes "0 < j1" and "j1 < j2" and "j2 < j3" and "j3 + 17 < k" and "G \<ge> 6"
+  shows "turing_machine k G (tm_chi j1 j2 j3)"
+  unfolding tm_chi_def
+  using tm_prev_tm tm_equalsn_tm tm_decr_tm tm_mult_tm tm_add_tm tm_range_tm tm_extend_erase_tm
+    tm_setn_tm tm_incr_tm tm_nth_tm tm_erase_cr_tm tm_relabel_tm Nil_tm tm_cr_tm tm_extendl_erase_tm
+    assms turing_machine_branch_turing_machine
+  by simp
+
+locale turing_machine_chi =
+  fixes j1 j2 j3 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_prev j2 (j3 + 6)"
+definition "tm2 \<equiv> tm1 ;; tm_equalsn (j3 + 11) (j3 + 6) (j3 + 13)"
+
+definition "tm3 \<equiv> tm2 ;; tm_decr (j3 + 6)"
+definition "tm4 \<equiv> tm3 ;; tm_mult (j3 + 6) (j3 + 2) (j3 + 7)"
+definition "tm5 \<equiv> tm4 ;; tm_add j3 (j3 + 7)"
+definition "tm6 \<equiv> tm5 ;; tm_range (j3 + 7) (j3 + 2) (j3 + 8)"
+definition "tm7 \<equiv> tm6 ;; tm_extend_erase (j3 + 12) (j3 + 8)"
+definition "tm8 \<equiv> tm7 ;; tm_setn (j3 + 7) 0"
+
+definition "tmT1 \<equiv> tm_mult (j3 + 11) (j3 + 2) (j3 + 7)"
+definition "tmT2 \<equiv> tmT1 ;; tm_add j3 (j3 + 7)"
+definition "tmT3 \<equiv> tmT2 ;; tm_range (j3 + 7) (j3 + 2) (j3 + 8)"
+definition "tmT4 \<equiv> tmT3 ;; tm_extend_erase (j3 + 12) (j3 + 8)"
+definition "tmT5 \<equiv> tmT4 ;; tm_setn (j3 + 7) 0"
+
+definition "tm89 \<equiv> IF \<lambda>rs. rs ! (j3 + 13) = \<box> THEN tmT5 ELSE [] ENDIF"
+definition "tm10 \<equiv> tm8 ;; tm89"
+
+definition "tm11 \<equiv> tm10 ;; tm_incr (j3 + 6)"
+definition "tm13 \<equiv> tm11 ;; tm_mult (j3 + 6) (j3 + 2) (j3 + 7)"
+definition "tm14 \<equiv> tm13 ;; tm_add j3 (j3 + 7)"
+definition "tm15 \<equiv> tm14 ;; tm_range (j3 + 7) (j3 + 2) (j3 + 8)"
+definition "tm16 \<equiv> tm15 ;; tm_extend_erase (j3 + 12) (j3 + 8)"
+definition "tm17 \<equiv> tm16 ;; tm_setn (j3 + 11) 0"
+definition "tm18 \<equiv> tm17 ;; tm_nth j1 (j3 + 6) (j3 + 11) 4"
+definition "tm19 \<equiv> tm18 ;; tm_setn (j3 + 7) 0"
+definition "tm20 \<equiv> tm19 ;; tm_mult (j3 + 11) (j3 + 1) (j3 + 7)"
+definition "tm21 \<equiv> tm20 ;; tm_range (j3 + 7) (j3 + 1) (j3 + 8)"
+definition "tm22 \<equiv> tm21 ;; tm_extend_erase (j3 + 12) (j3 + 8)"
+definition "tm23 \<equiv> tm22 ;; tm_setn (j3 + 7) 0"
+definition "tm24 \<equiv> tm23 ;; tm_erase_cr (j3 + 11)"
+definition "tm25 \<equiv> tm24 ;; tm_cr (j3 + 12)"
+
+definition "tmE1 \<equiv> tm_erase_cr (j3 + 13)"
+definition "tmE2 \<equiv> tmE1 ;; tm_relabel (j3 + 5) (j3 + 11)"
+definition "tmTT1 \<equiv> tm_relabel (j3 + 4) (j3 + 11)"
+
+definition "tm2526 \<equiv> IF \<lambda>rs. rs ! (j3 + 13) = \<box> THEN tmTT1 ELSE tmE2 ENDIF"
+definition "tm26 \<equiv> tm25 ;; tm2526"
+definition "tm27 \<equiv> tm26 ;; tm_erase_cr (j3 + 12)"
+definition "tm28 \<equiv> tm27 ;; tm_extendl_erase 1 (j3 + 11)"
+definition "tm29 \<equiv> tm28 ;; tm_incr (j3 + 6)"
+definition "tm30 \<equiv> tm29 ;; tm_decr (j3 + 3)"
+
+lemma tm30_eq_tm_chi: "tm30 = tm_chi j1 j2 j3"
+  unfolding tm30_def tm29_def tm28_def tm27_def tm26_def tm25_def tm24_def tm23_def tm22_def tm21_def tm20_def
+    tm19_def tm18_def tm17_def tm16_def tm15_def tm14_def tm13_def tm11_def tm10_def
+    tm8_def tm7_def tm6_def tm5_def tm4_def tm3_def tm2_def tm1_def
+    tm89_def tmE1_def tmE2_def tmTT1_def tm2526_def
+    tmT5_def tmT4_def tmT3_def tmT2_def tmT1_def
+    tm_chi_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k G N Z T' T t :: nat and hp0 hp1 :: "nat list" and \<psi> \<psi>' :: formula
+  fixes nss :: "nat list list"
+  assumes jk: "length tps0 = k" "1 < j1" "j1 < j2" "j2 < j3" "j3 + 17 < k"
+    and G: "G \<ge> 3"
+    and Z: "Z = 3 * G"
+    and N: "N \<ge> 1"
+    and len_hp0: "length hp0 = Suc T'"
+    and hp0: "\<forall>i<length hp0. hp0 ! i \<le> T'"
+    and len_hp1: "length hp1 = Suc T'"
+    and hp1: "\<forall>i<length hp1. hp1 ! i \<le> T'"
+    and t: "0 < t" "t \<le> T'"
+    and T: "0 < T" "T \<le> T'"
+    and T': "T' < N"
+    and psi: "variables \<psi> \<subseteq> {..<3*Z+G}" "fsize \<psi> \<le> (3*Z+G) * 2 ^ (3*Z+G)" "length \<psi> \<le> 2 ^ (3*Z+G)"
+    and psi': "variables \<psi>' \<subseteq> {..<2*Z+G}" "fsize \<psi>' \<le> (2*Z+G) * 2 ^ (2*Z+G)" "length \<psi>' \<le> 2 ^ (2*Z+G)"
+  assumes tps0:
+    "tps0 ! 1 = nlltape nss"
+    "tps0 ! j1 = (\<lfloor>hp0\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! j2 = (\<lfloor>hp1\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! j3 = (\<lfloor>N\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 1) = (\<lfloor>G\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 2) = (\<lfloor>Z\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 3) = (\<lfloor>T\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 4) = (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps0 ! (j3 + 5) = (\<lfloor>formula_n \<psi>'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps0 ! (j3 + 6) = (\<lfloor>t\<rfloor>\<^sub>N, 1)"
+    "\<And>i. 6 < i \<Longrightarrow> i < 17 \<Longrightarrow> tps0 ! (j3 + i) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+lemma Z_ge_1: "Z \<ge> 1"
+  using G Z by simp
+
+lemma Z_ge_9: "Z \<ge> 9"
+  using G Z by simp
+
+lemma T'_ge_1: "T' \<ge> 1"
+  using t by simp
+
+lemma tps0': "\<And>i. 1 \<le> i \<Longrightarrow> i < 11 \<Longrightarrow> tps0 ! (j3 + 6 + i) = (\<lfloor>[]\<rfloor>, 1)"
+proof -
+  fix i :: nat
+  assume i: "1 \<le> i" "i < 11"
+  then have "6 < 6 + i" "6 + i < 17"
+    by simp_all
+  then have "tps0 ! (j3 + (6 + i)) = (\<lfloor>[]\<rfloor>, 1)"
+    using tps0(11) by simp
+  then show "tps0 ! (j3 + 6 + i) = (\<lfloor>[]\<rfloor>, 1)"
+    by (metis group_cancel.add1)
+qed
+
+text \<open>The simplifier turns $j3 + 6 + 3$ into $9 + j3$. The next lemma helps with that.\<close>
+
+lemma tps0_sym: "\<And>i. 6 < i \<Longrightarrow> i < 17 \<Longrightarrow> tps0 ! (i + j3) = (\<lfloor>[]\<rfloor>, 1)"
+  using tps0(11) by (simp add: add.commute)
+
+lemma previous_hp1_le: "previous hp1 t \<le> t"
+  using len_hp1 hp1 t(2) previous_le[of hp1 t] by simp
+
+definition "tps1 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 71 + 153 * nllength hp1 ^ 3"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: canrepr_0 tps0_sym tps0 tps1_def jk t len_hp1 time: assms)
+  show "tps1 = tps0[j3 + 6 + 5 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1)]"
+    using tps1_def by (simp add: add.commute)
+qed
+
+definition "tps2 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 78 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t)"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps0 tps1_def tps2_def jk time: assms)
+  show "tps1 ! (j3 + 13) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps1_def tps0(11) canrepr_0 by simp
+  show "(0::nat) \<le> 1"
+    by simp
+qed
+
+definition "tps3 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 86 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t) + 2 * nlength t"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def by (tform tps: tps0 tps2_def tps3_def jk assms)
+
+definition "tps4 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>(t - 1) * Z\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 90 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t) + 2 * nlength t +
+    26 * (nlength (t - 1) + nlength Z) ^ 2"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: tps0 tps3_def tps4_def jk)
+  show "tps3 ! (j3 + 7) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps3_def jk canrepr_0 tps0 by simp
+  show "ttt = 86 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t) +
+    2 * nlength t + (4 + 26 * (nlength (t - Suc 0) + nlength Z) * (nlength (t - Suc 0) + nlength Z))"
+  proof -
+    have "(26 * nlength (t - Suc 0) + 26 * nlength Z) * (nlength (t - Suc 0) + nlength Z) =
+        26 * (nlength (t - Suc 0) + nlength Z) ^ 2"
+      by algebra
+    then show ?thesis
+      using assms by simp
+  qed
+qed
+
+definition "tps5 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + (t - 1) * Z\<rfloor>\<^sub>N, 1)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 100 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t) + 2 * nlength t +
+    26 * (nlength (t - 1) + nlength Z) ^ 2 + 3 * max (nlength N) (nlength ((t - 1) * Z))"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def by (tform tps: tps0 tps4_def tps5_def jk time: assms)
+
+definition "tps6 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + (t - 1) * Z\<rfloor>\<^sub>N, 1),
+   j3 + 8 := (\<lfloor>[N + (t - 1) * Z..<N + (t - 1) * Z + Z]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm6 [transforms_intros]:
+  assumes "ttt = 100 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t) + 2 * nlength t +
+    26 * (nlength (t - 1) + nlength Z) ^ 2 + 3 * max (nlength N) (nlength ((t - 1) * Z)) +
+    Suc Z * (43 + 9 * nlength (N + (t - 1) * Z + Z))"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+  by (tform tps: nlcontents_Nil canrepr_0 tps0_sym tps0 tps5_def tps6_def jk time: assms)
+
+definition "tps7 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + (t - 1) * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape [N + (t - 1) * Z..<N + (t - 1) * Z + Z]]"
+
+lemma tm7 [transforms_intros]:
+  assumes "ttt = 111 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t) + 2 * nlength t +
+    26 * (nlength (t - 1) + nlength Z) ^ 2 + 3 * max (nlength N) (nlength ((t - 1) * Z)) +
+    Suc Z * (43 + 9 * nlength (N + (t - 1) * Z + Z)) +
+    4 * nllength [N + (t - Suc 0) * Z..<N + (t - Suc 0) * Z + Z]"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def
+proof (tform tps: tps0 tps6_def tps7_def jk time: assms)
+  show "tps6 ! (j3 + 12) = nltape []"
+    using tps6_def jk nlcontents_Nil tps0 by force
+  show "tps7 = tps6
+      [j3 + 12 := nltape ([] @ [N + (t - Suc 0) * Z..<N + (t - Suc 0) * Z + Z]),
+       j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+    unfolding tps7_def tps6_def
+    using tps0 jk list_update_id[of tps0 "j3 + 8"]
+    by (simp add: list_update_swap)
+qed
+
+definition "tps8 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape [N + (t - 1) * Z..<N + (t - 1) * Z + Z]]"
+
+lemma tm8:
+  assumes "ttt = 121 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t) +
+    2 * nlength t + 26 * (nlength (t - 1) + nlength Z) ^ 2 + 3 * max (nlength N) (nlength ((t - 1) * Z)) +
+    Suc Z * (43 + 9 * nlength (N + (t - 1) * Z + Z)) + 4 * nllength [N + (t - 1) * Z..<N + (t - 1) * Z + Z] +
+    2 * nlength (N + (t - 1) * Z)"
+  shows "transforms tm8 tps0 ttt tps8"
+  unfolding tm8_def by (tform tps: tps0 tps7_def tps8_def jk time: assms)
+
+text \<open>
+For the next upper bound we have no scruples replacing $\log T'$, $\log N$, and
+$\log Z$ by $T'$, $N$ and $Z$, respectively.  All values are polynomial in $n$
+($Z$ is even a constant), so the overall polynomiality is not in jeopardy.
+\<close>
+
+lemma nllength_le:
+  fixes nmax :: nat and ns :: "nat list"
+  assumes "\<forall>n\<in>set ns. n \<le> nmax"
+  shows "nllength ns \<le> Suc nmax * length ns"
+proof -
+  have "nllength ns \<le> Suc (nlength nmax) * length ns"
+    using assms nllength_le_len_mult_max by simp
+  then show ?thesis
+    using nlength_le_n by (meson Suc_le_mono dual_order.trans mult_le_mono1)
+qed
+
+lemma nllength_upt_le:
+  fixes a b :: nat
+  shows "nllength [a..<b] \<le> Suc b * (b - a)"
+proof -
+  have "nllength [a..<b] \<le> Suc (nlength b) * (b - a)"
+    using nllength_upt_le_len_mult_max by simp
+  then show ?thesis
+    using nlength_le_n by (meson Suc_le_mono dual_order.trans mult_le_mono1)
+qed
+
+lemma nllength_hp1: "nllength hp1 \<le> Suc T' * Suc T'"
+proof -
+  have "\<forall>n\<in>set hp1. n \<le> T'"
+    using hp1 by (metis in_set_conv_nth)
+  then have "nllength hp1 \<le> Suc T' * Suc T'"
+    using nllength_le[of hp1 T'] len_hp1 by simp
+  then show ?thesis
+    by simp
+qed
+
+definition "ttt8 \<equiv> 168 + 153 * Suc T' ^ 6 + 5 * t + 26 * (t + Z) ^ 2 + 47 * Z + 15 * Z * (N + t * Z)"
+
+lemma tm8' [transforms_intros]: "transforms tm8 tps0 ttt8 tps8"
+proof -
+  let ?s = "88 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t) + 2 * nlength (N + (t - 1) * Z)"
+  let ?ttt = "121 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t) +
+    2 * nlength t + 26 * (nlength (t - 1) + nlength Z) ^ 2 + 3 * max (nlength N) (nlength ((t - 1) * Z)) +
+    Suc Z * (43 + 9 * nlength (N + (t - 1) * Z + Z)) + 4 * nllength [N + (t - 1) * Z..<N + (t - 1) * Z + Z] +
+    2 * nlength (N + (t - 1) * Z)"
+  have "?ttt = ?s + 33 + 2 * nlength t + 26 * (nlength (t - 1) + nlength Z) ^ 2 + 3 * max (nlength N) (nlength ((t - 1) * Z)) +
+      Suc Z * (43 + 9 * nlength (N + (t - 1) * Z + Z)) + 4 * nllength [N + (t - 1) * Z..<N + (t - 1) * Z + Z]"
+    by simp
+  also have "... \<le> ?s + 33 + 2 * t + 26 * (nlength (t - 1) + nlength Z) ^ 2 +
+      3 * max (nlength N) (nlength ((t - 1) * Z)) + Suc Z * (43 + 9 * nlength (N + (t - 1) * Z + Z)) +
+      4 * nllength [N + (t - 1) * Z..<N + (t - 1) * Z + Z]"
+    using nlength_le_n by simp
+  also have "... \<le> ?s + 33 + 2 * t + 26 * ((t - 1) + nlength Z) ^ 2 +
+      3 * max (nlength N) (nlength ((t - 1) * Z)) + Suc Z * (43 + 9 * nlength (N + (t - 1) * Z + Z)) +
+      4 * nllength [N + (t - 1) * Z..<N + (t - 1) * Z + Z]"
+    using nlength_le_n by simp
+  also have "... \<le> ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * max (nlength N) (nlength ((t - 1) * Z)) + Suc Z * (43 + 9 * nlength (N + (t - 1) * Z + Z)) +
+      4 * nllength [N + (t - 1) * Z..<N + (t - 1) * Z + Z]"
+    using nlength_le_n by simp
+  also have "... \<le> ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * max (nlength N) (nlength ((t - 1) * Z)) + Suc Z * (43 + 9 * (N + (t - 1) * Z + Z)) +
+      4 * nllength [N + (t - 1) * Z..<N + (t - 1) * Z + Z]"
+    using nlength_le_n add_le_mono le_refl mult_le_mono by presburger
+  also have "... \<le> ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * max (nlength N) (nlength ((t - 1) * Z)) + Suc Z * (43 + 9 * (N + (t - 1) * Z + Z)) +
+      4 * Suc (nlength (N + (t - 1) * Z + Z)) * Z"
+  proof -
+    have "nllength [N + (t - 1) * Z..<N + (t - 1) * Z + Z] \<le> Suc (nlength (N + (t - 1) * Z + Z)) * Z"
+      using nllength_le_len_mult_max[of "[N + (t - 1) * Z..<N + (t - 1) * Z + Z]" "N + (t - 1) * Z + Z"]
+      by simp
+    then show ?thesis
+      by linarith
+  qed
+  also have "... = ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * nlength (max N ((t - 1) * Z)) + Suc Z * (43 + 9 * (N + (t - 1) * Z + Z)) +
+      4 * Suc (nlength (N + (t - 1) * Z + Z)) * Z"
+    using max_nlength by simp
+  also have "... \<le> ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * max N ((t - 1) * Z) + Suc Z * (43 + 9 * (N + (t - 1) * Z + Z)) +
+      4 * Suc (nlength (N + (t - 1) * Z + Z)) * Z"
+    using nlength_le_n by simp
+  also have "... = ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * max N ((t - 1) * Z) + Suc Z * (43 + 9 * (N + t * Z)) +
+      4 * Suc (nlength (N + (t - 1) * Z + Z)) * Z"
+    using t by (smt (verit) ab_semigroup_add_class.add_ac(1) add.commute diff_Suc_1 gr0_implies_Suc mult_Suc)
+  also have "... \<le> ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * max N ((t - 1) * Z) + Suc Z * (43 + 9 * (N + t * Z)) +
+      4 * Suc (N + (t - 1) * Z + Z) * Z"
+    using nlength_le_n Suc_le_mono add_le_mono le_refl mult_le_mono by presburger
+  also have "... = ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * max N ((t - 1) * Z) + Suc Z * (43 + 9 * (N + t * Z)) +
+      4 * Suc (N + t * Z) * Z"
+    by (smt (verit, del_insts) Suc_eq_plus1 Suc_leI add.commute add.left_commute add_leD2 le_add_diff_inverse mult.commute mult_Suc_right t(1))
+  also have "... \<le> ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * (N + ((t - 1) * Z)) + Suc Z * (43 + 9 * (N + t * Z)) + 4 * Suc (N + t * Z) * Z"
+    by simp
+  also have "... \<le> ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * (N + t * Z) + Suc Z * (43 + 9 * (N + t * Z)) + 4 * Suc (N + t * Z) * Z"
+    by simp
+  also have "... = ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * (N + t * Z) + Suc Z * (43 + 9 * (N + t * Z)) + (4 + 4 * (N + t * Z)) * Z"
+    by simp
+  also have "... \<le> ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 +
+      3 * (N + t * Z) + Suc Z * (43 + 9 * (N + t * Z)) + (4 + 4 * (N + t * Z)) * Suc Z"
+    by simp
+  also have "... = ?s + 33 + 2 * t + 26 * ((t - 1) + Z) ^ 2 + 3 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    by algebra
+  also have "... = 121 + 153 * nllength hp1 ^ 3 + 3 * nlength (min (previous hp1 t) t) + 2 * nlength (N + (t - 1) * Z) +
+      2 * t + 26 * ((t - 1) + Z) ^ 2 + 3 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    by simp
+  also have "... \<le> 121 + 153 * nllength hp1 ^ 3 + 3 * nlength t + 2 * nlength (N + (t - 1) * Z) +
+      2 * t + 26 * ((t - 1) + Z) ^ 2 + 3 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    using previous_hp1_le nlength_mono by simp
+  also have "... \<le> 121 + 153 * nllength hp1 ^ 3 + 2 * nlength (N + (t - 1) * Z) +
+      5 * t + 26 * ((t - 1) + Z) ^ 2 + 3 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    using nlength_le_n by simp
+  also have "... \<le> 121 + 153 * nllength hp1 ^ 3 + 2 * (N + (t - 1) * Z) +
+      5 * t + 26 * ((t - 1) + Z) ^ 2 + 3 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    using nlength_le_n add_le_mono1 mult_le_mono2 nat_add_left_cancel_le by presburger
+  also have "... \<le> 121 + 153 * nllength hp1 ^ 3 + 2 * (N + t * Z) +
+      5 * t + 26 * ((t - 1) + Z) ^ 2 + 3 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    by simp
+  also have "... = 121 + 153 * nllength hp1 ^ 3 +
+      5 * t + 26 * ((t - 1) + Z) ^ 2 + 5 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    by simp
+  also have "... \<le> 121 + 153 * (Suc T' * Suc T') ^ 3 +
+      5 * t + 26 * ((t - 1) + Z) ^ 2 + 5 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    using nllength_hp1 by simp
+  also have "... = 121 + 153 * (Suc T' ^ 2)^3 +
+      5 * t + 26 * ((t - 1) + Z) ^ 2 + 5 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    by algebra
+  also have "... = 121 + 153 * Suc T' ^ 6 +
+      5 * t + 26 * ((t - 1) + Z) ^ 2 + 5 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    by simp
+  also have "... \<le> 121 + 153 * Suc T' ^ 6 +
+      5 * t + 26 * (t + Z) ^ 2 + 5 * (N + t * Z) + Suc Z * (47 + 13 * (N + t * Z))"
+    by simp
+  also have "... = 121 + 153 * Suc T' ^ 6 +
+      5 * t + 26 * (t + Z) ^ 2 + 5 * (N + t * Z) + 47 + 13 * (N + t * Z) + Z * (47 + 13 * (N + t * Z))"
+    by simp
+  also have "... = 168 + 153 * Suc T' ^ 6 +
+      5 * t + 26 * (t + Z) ^ 2 + 18 * (N + t * Z) + Z * (47 + 13 * (N + t * Z))"
+    by simp
+  also have "... \<le> 168 + 153 * Suc T' ^ 6 +
+      5 * t + 26 * (t + Z) ^ 2 + 2 * Z * (N + t * Z) + Z * (47 + 13 * (N + t * Z))"
+    using Z_ge_9 by (metis add_le_mono add_le_mono1 mult_2 mult_le_mono1 nat_add_left_cancel_le numeral_Bit0)
+  also have "... = 168 + 153 * Suc T' ^ 6 +
+      5 * t + 26 * (t + Z) ^ 2 + 2 * Z * (N + t * Z) + 47 * Z + 13 * Z * (N + t * Z)"
+    by algebra
+  also have "... = 168 + 153 * Suc T' ^ 6 + 5 * t + 26 * (t + Z) ^ 2 + 47 * Z + 15 * Z * (N + t * Z)"
+    by simp
+  finally have "?ttt \<le> ttt8"
+    using ttt8_def by simp
+  then show ?thesis
+    using tm8 transforms_monotone by simp
+qed
+
+definition "tpsT1 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>previous hp1 t * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape [N + (t - 1) * Z..<N + (t - 1) * Z + Z]]"
+
+lemma tmT1 [transforms_intros]:
+  assumes "ttt = 4 + 26 * (nlength (previous hp1 t) + nlength Z) ^ 2"
+  shows "transforms tmT1 tps8 ttt tpsT1"
+  unfolding tmT1_def
+proof (tform tps: tps0 tps8_def tpsT1_def jk)
+  show "ttt = 4 + 26 * (nlength (previous hp1 t) + nlength Z) * (nlength (previous hp1 t) + nlength Z)"
+    using assms by algebra
+  show "tpsT1 = tps8[j3 + 7 := (\<lfloor>previous hp1 t * Z\<rfloor>\<^sub>N, 1)]"
+    unfolding tpsT1_def tps8_def by (simp add: list_update_swap[of "j3+7"])
+qed
+
+definition "tpsT2 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + previous hp1 t * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape [N + (t - 1) * Z..<N + (t - 1) * Z + Z]]"
+
+lemma tmT2 [transforms_intros]:
+  assumes "ttt = 14 + 26 * (nlength (previous hp1 t) + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (previous hp1 t * Z))"
+  shows "transforms tmT2 tps8 ttt tpsT2"
+  unfolding tmT2_def by (tform tps: tps0 tpsT1_def tpsT2_def jk assms)
+
+definition "tpsT3 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + previous hp1 t * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape [N + (t - 1) * Z..<N + (t - 1) * Z + Z],
+   j3 + 8 := (\<lfloor>[N + previous hp1 t * Z..<N + previous hp1 t * Z + Z]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tmT3 [transforms_intros]:
+  assumes "ttt = 14 + 26 * (nlength (previous hp1 t) + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (previous hp1 t * Z)) +
+    Suc Z * (43 + 9 * nlength (N + previous hp1 t * Z + Z))"
+  shows "transforms tmT3 tps8 ttt tpsT3"
+  unfolding tmT3_def
+  by (tform tps: nlcontents_Nil canrepr_0 tps0_sym tps0 tpsT2_def tpsT3_def jk time: assms)
+
+definition "tpsT4 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + previous hp1 t * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+         [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z]),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tmT4 [transforms_intros]:
+  assumes "ttt = 25 + 26 * (nlength (previous hp1 t) + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (previous hp1 t * Z)) +
+    Suc Z * (43 + 9 * nlength (N + previous hp1 t * Z + Z)) +
+    4 * nllength [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z]"
+  shows "transforms tmT4 tps8 ttt tpsT4"
+  unfolding tmT4_def by (tform tps: tps0 tpsT3_def tpsT4_def jk time: assms)
+
+definition "tpsT5 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+         [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z]),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tmT5 [transforms_intros]:
+  assumes "ttt = 35 + 26 * (nlength (previous hp1 t) + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (previous hp1 t * Z)) +
+    Suc Z * (43 + 9 * nlength (N + previous hp1 t * Z + Z)) +
+    4 * nllength [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] +
+    2 * nlength (N + previous hp1 t * Z)"
+  shows "transforms tmT5 tps8 ttt tpsT5"
+  unfolding tmT5_def by (tform tps: tps0 tpsT4_def tpsT5_def jk time: assms)
+
+definition "tps9 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else [])),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm89 [transforms_intros]:
+  assumes "ttt = 37 + 26 * (nlength (previous hp1 t) + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (previous hp1 t * Z)) +
+    Suc Z * (43 + 9 * nlength (N + previous hp1 t * Z + Z)) +
+    4 * nllength [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] +
+    2 * nlength (N + previous hp1 t * Z)"
+  shows "transforms tm89 tps8 ttt tps9"
+  unfolding tm89_def
+proof (tform time: assms)
+  have "tps8 ! (j3 + 13) = (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1)"
+    using tps8_def jk by simp
+  then have *: "(previous hp1 t \<noteq> t) = (read tps8 ! (j3 + 13) = \<box>)"
+    using jk tps8_def read_ncontents_eq_0 by force
+  show "read tps8 ! (j3 + 13) = \<box> \<Longrightarrow> tps9 = tpsT5"
+    using * tps9_def tpsT5_def by simp
+  have "(\<lfloor>[]\<rfloor>, 1) = tps0 ! (j3 + 8)"
+    using jk tps0 by simp
+  then have "tps0[j3 + 8 := (\<lfloor>[]\<rfloor>, 1)] = tps0"
+    using jk tps0 by (metis list_update_id)
+  then have "tps8 = tps0
+    [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+     j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+     j3 + 6 := (\<lfloor>t - 1\<rfloor>\<^sub>N, 1),
+     j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j3 + 12 := nltape [N + (t - 1) * Z..<N + (t - 1) * Z + Z],
+     j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+    using tps8_def jk tps0 by (simp add: list_update_swap[of _ "j3 + 8"])
+  then show "read tps8 ! (j3 + 13) \<noteq> \<box> \<Longrightarrow> tps9 = tps8"
+    using * tps9_def by simp
+qed
+
+definition "ttt10 \<equiv> ttt8 + 37 + 26 * (nlength (previous hp1 t) + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (previous hp1 t * Z)) +
+    Suc Z * (43 + 9 * nlength (N + previous hp1 t * Z + Z)) +
+    4 * nllength [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] +
+    2 * nlength (N + previous hp1 t * Z)"
+
+lemma tm10 [transforms_intros]: "transforms tm10 tps0 ttt10 tps9"
+  unfolding tm10_def by (tform tps: ttt10_def)
+
+definition "tps11 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else [])),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm11 [transforms_intros]:
+  assumes "ttt = ttt10 + 5 + 2 * nlength (t - 1)"
+  shows "transforms tm11 tps0 ttt tps11"
+  unfolding tm11_def by (tform tps: t(1) tps0 tps9_def tps11_def jk time: assms)
+
+definition "tps13 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>t * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else [])),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm13 [transforms_intros]:
+  assumes "ttt = ttt10 + 9 + 2 * nlength (t - 1) + 26 * (nlength t + nlength Z) ^ 2"
+  shows "transforms tm13 tps0 ttt tps13"
+  unfolding tm13_def
+proof (tform tps: tps0 tps11_def tps13_def jk)
+  show "ttt = ttt10 + 5 + 2 * nlength (t - 1) + (4 + 26 * (nlength t + nlength Z) * (nlength t + nlength Z))"
+    using assms by simp (metis Groups.mult_ac(1) distrib_left power2_eq_square)
+  show "tps13 = tps11[j3 + 7 := (\<lfloor>t * Z\<rfloor>\<^sub>N, 1)]"
+    unfolding tps13_def tps11_def by (simp add: list_update_swap[of "j3+7"])
+qed
+
+definition "tps14 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + t * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else [])),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm14 [transforms_intros]:
+  assumes "ttt = ttt10 + 19 + 2 * nlength (t - 1) + 26 * (nlength t + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (t * Z))"
+  shows "transforms tm14 tps0 ttt tps14"
+  unfolding tm14_def
+proof (tform tps: tps0 tps13_def tps14_def jk time: assms)
+  show "tps14 = tps13[j3 + 7 := (\<lfloor>N + t * Z\<rfloor>\<^sub>N, 1)]"
+    unfolding tps14_def tps13_def by (simp add: list_update_swap[of "j3+7"])
+qed
+
+definition "tps15 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + t * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else [])),
+   j3 + 8 := (\<lfloor>[N + t * Z..<N + t * Z + Z]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm15 [transforms_intros]:
+  assumes "ttt = ttt10 + 19 + 2 * nlength (t - 1) + 26 * (nlength t + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (t * Z)) + Suc Z * (43 + 9 * nlength (N + t * Z + Z))"
+  shows "transforms tm15 tps0 ttt tps15"
+  unfolding tm15_def
+proof (tform tps: tps0 tps14_def tps15_def jk time: assms)
+  show "tps14 ! (j3 + 8) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tps14_def jk nlcontents_Nil tps0 by simp
+  show "tps14 ! (j3 + 8 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps14_def jk canrepr_0 tps0_sym by simp
+  show "tps14 ! (j3 + 8 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps14_def jk canrepr_0 tps0_sym by simp
+qed
+
+definition "tps16 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>previous hp1 t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + t * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - Suc 0) * Z..<N + (t - Suc 0) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else []) @
+         [N + t * Z..<N + t * Z + Z]),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm16 [transforms_intros]:
+  assumes "ttt = ttt10 + 30 + 2 * nlength (t - 1) + 26 * (nlength t + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (t * Z)) + Suc Z * (43 + 9 * nlength (N + t * Z + Z)) +
+    4 * nllength [N + t * Z..<N + t * Z + Z]"
+  shows "transforms tm16 tps0 ttt tps16"
+  unfolding tm16_def by (tform tps: tps0 tps15_def tps16_def jk time: assms)
+
+definition "tps17 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + t * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - Suc 0) * Z..<N + (t - Suc 0) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else []) @
+         [N + t * Z..<N + t * Z + Z]),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm17 [transforms_intros]:
+  assumes "ttt = ttt10 + 40 + 2 * nlength (t - 1) + 26 * (nlength t + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (t * Z)) + Suc Z * (43 + 9 * nlength (N + t * Z + Z)) +
+    4 * nllength [N + t * Z..<N + t * Z + Z] + 2 * nlength (previous hp1 t)"
+  shows "transforms tm17 tps0 ttt tps17"
+  unfolding tm17_def by (tform tps: tps0 tps16_def tps17_def jk time: jk assms)
+
+definition "tps18 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>hp0 ! t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>N + t * Z\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - Suc 0) * Z..<N + (t - Suc 0) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else []) @
+         [N + t * Z..<N + t * Z + Z]),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm18 [transforms_intros]:
+  assumes "ttt = ttt10 + 66 + 2 * nlength (t - 1) + 26 * (nlength t + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (t * Z)) + Suc Z * (43 + 9 * nlength (N + t * Z + Z)) +
+    4 * nllength [N + t * Z..<N + t * Z + Z] + 2 * nlength (previous hp1 t) +
+    21 * (nllength hp0)\<^sup>2"
+  shows "transforms tm18 tps0 ttt tps18"
+  unfolding tm18_def
+proof (tform tps: tps0 tps18_def tps17_def jk time: assms)
+  show "t < length hp0"
+    using len_hp0 t by simp
+qed
+
+definition "tps19 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>hp0 ! t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - Suc 0) * Z..<N + (t - Suc 0) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else []) @
+         [N + t * Z..<N + t * Z + Z]),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm19 [transforms_intros]:
+  assumes "ttt = ttt10 + 76 + 2 * nlength (t - 1) + 26 * (nlength t + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (t * Z)) + Suc Z * (43 + 9 * nlength (N + t * Z + Z)) +
+    4 * nllength [N + t * Z..<N + t * Z + Z] + 2 * nlength (previous hp1 t) +
+    21 * (nllength hp0)\<^sup>2 + 2 * nlength (N + t * Z)"
+  shows "transforms tm19 tps0 ttt tps19"
+  unfolding tm19_def
+  by (tform tps: tps0 tps18_def tps19_def jk time: assms)
+
+definition "tps20 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>hp0 ! t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>hp0 ! t * G\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - Suc 0) * Z..<N + (t - Suc 0) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else []) @
+         [N + t * Z..<N + t * Z + Z]),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+definition "ttt20 \<equiv> ttt10 + 80 + 2 * nlength (t - 1) + 26 * (nlength t + nlength Z) ^ 2 +
+    3 * max (nlength N) (nlength (t * Z)) + Suc Z * (43 + 9 * nlength (N + t * Z + Z)) +
+    4 * nllength [N + t * Z..<N + t * Z + Z] + 2 * nlength (previous hp1 t) +
+    21 * (nllength hp0)\<^sup>2 + 2 * nlength (N + t * Z) + 26 * (nlength (hp0 ! t) + nlength G) ^ 2"
+
+lemma tm20 [transforms_intros]: "transforms tm20 tps0 ttt20 tps20"
+  unfolding tm20_def
+proof (tform tps: tps0 tps19_def tps20_def jk)
+  show "tps20 = tps19[j3 + 7 := (\<lfloor>hp0 ! t * G\<rfloor>\<^sub>N, 1)]"
+    unfolding tps20_def tps19_def by (simp add: list_update_swap[of "j3 + 7"])
+  show "ttt20 = ttt10 + 76 + 2 * nlength (t - 1) + 26 * (nlength t + nlength Z)\<^sup>2 +
+      3 * max (nlength N) (nlength (t * Z)) + Suc Z * (43 + 9 * nlength (N + t * Z + Z)) +
+      4 * nllength [N + t * Z..<N + t * Z + Z] + 2 * nlength (previous hp1 t) +
+      21 * (nllength hp0)\<^sup>2 + 2 * nlength (N + t * Z) +
+      (4 + 26 * (nlength (hp0 ! t) + nlength G) * (nlength (hp0 ! t) + nlength G))"
+    using ttt20_def by simp (metis Groups.mult_ac(1) distrib_left power2_eq_square)
+qed
+
+definition "tps21 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>hp0 ! t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>hp0 ! t * G\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape
+        ([N + (t - Suc 0) * Z..<N + (t - Suc 0) * Z + Z] @
+         (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else []) @
+         [N + t * Z..<N + t * Z + Z]),
+   j3 + 8 := (\<lfloor>[hp0 ! t * G..<hp0 ! t * G + G]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tm21 [transforms_intros]:
+  assumes "ttt = ttt20 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G))"
+  shows "transforms tm21 tps0 ttt tps21"
+  unfolding tm21_def
+proof (tform tps: tps0 tps20_def tps21_def jk time: assms)
+  show "tps20 ! (j3 + 8) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tps20_def jk nlcontents_Nil tps0 by simp
+  show "tps20 ! (j3 + 8 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps20_def jk canrepr_0 tps0_sym by simp
+  show "tps20 ! (j3 + 8 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps20_def jk canrepr_0 tps0_sym by simp
+qed
+
+abbreviation "\<sigma> \<equiv>
+  [N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+  (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else []) @
+  [N + t * Z..<N + t * Z + Z] @
+  [hp0 ! t * G..<hp0 ! t * G + G]"
+
+definition "tps22 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>hp0 ! t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>hp0 ! t * G\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape \<sigma>,
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm22 [transforms_intros]:
+  assumes "ttt = ttt20 + 11 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+    4 * nllength [hp0 ! t * G..<hp0 ! t * G + G]"
+  shows "transforms tm22 tps0 ttt tps22"
+  unfolding tm22_def by (tform tps: tps0 tps21_def tps22_def jk time: assms)
+
+definition "tps23 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>hp0 ! t\<rfloor>\<^sub>N, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape \<sigma>,
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm23 [transforms_intros]:
+  assumes "ttt = ttt20 + 21 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+    4 * nllength [hp0 ! t * G..<hp0 ! t * G + G] + 2 * nlength (hp0 ! t * G)"
+  shows "transforms tm23 tps0 ttt tps23"
+  unfolding tm23_def by (tform tps: tps0 tps22_def tps23_def jk time: assms)
+
+definition "tps24 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>[]\<rfloor>, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := nltape \<sigma>,
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm24 [transforms_intros]:
+  assumes "ttt = ttt20 + 28 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+    4 * nllength [hp0 ! t * G..<hp0 ! t * G + G] + 2 * nlength (hp0 ! t * G) +
+    2 * nlength (hp0 ! t)"
+  shows "transforms tm24 tps0 ttt tps24"
+  unfolding tm24_def
+proof (tform tps: tps0 tps23_def tps24_def jk assms)
+  show "proper_symbols (canrepr (hp0 ! t))"
+    using proper_symbols_canrepr by simp
+qed
+
+definition "tps25 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>[]\<rfloor>, 1),
+   j3 + 13 := (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := (\<lfloor>\<sigma>\<rfloor>\<^sub>N\<^sub>L, 1),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm25 [transforms_intros]:
+  assumes "ttt = ttt20 + 31 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+    4 * nllength [hp0 ! t * G..<hp0 ! t * G + G] + 2 * nlength (hp0 ! t * G) +
+    2 * nlength (hp0 ! t) + nllength \<sigma>"
+  shows "transforms tm25 tps0 ttt tps25"
+  unfolding tm25_def
+proof (tform tps: tps0 tps24_def tps25_def jk assms)
+  have *: "tps24 ! (j3 + 12) = nltape \<sigma>"
+    using tps24_def jk by simp
+  then show "clean_tape (tps24 ! (j3 + 12))"
+    using clean_tape_nlcontents by simp
+  have "tps25 = tps24[j3 + 12 := nltape \<sigma> |#=| 1]"
+    unfolding tps25_def tps24_def by (simp add: list_update_swap)
+  then show "tps25 = tps24[j3 + 12 := tps24 ! (j3 + 12) |#=| 1]"
+    using * by simp
+qed
+
+definition "tpsE1 \<equiv> tps0
+  [j3 + 11 := (\<lfloor>[]\<rfloor>, 1),
+   j3 + 13 := (\<lfloor>[]\<rfloor>, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := (\<lfloor>\<sigma>\<rfloor>\<^sub>N\<^sub>L, 1),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tmE1:
+  assumes "ttt = 7 + 2 * nlength (if previous hp1 t = t then 1 else 0)"
+  shows "transforms tmE1 tps25 ttt tpsE1"
+  unfolding tmE1_def
+proof (tform tps: tps0 tps25_def tpsE1_def jk assms)
+  show "proper_symbols (canrepr (if previous hp1 t = t then 1 else 0))"
+    using proper_symbols_canrepr by simp
+qed
+
+lemma tmE1' [transforms_intros]:
+  assumes "ttt = 9"
+  shows "transforms tmE1 tps25 ttt tpsE1"
+  using tmE1 assms transforms_monotone by (simp add: nlength_le_n)
+
+definition "tpsE2 \<equiv> tps0
+  [j3 + 11 := nlltape' (formula_n (relabel \<sigma> \<psi>')) 0,
+   j3 + 13 := (\<lfloor>[]\<rfloor>, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := (\<lfloor>\<sigma>\<rfloor>\<^sub>N\<^sub>L, 1),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tmE2 [transforms_intros]:
+  assumes "ttt = 16 + 108 * (nlllength (formula_n \<psi>'))\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)"
+    and "previous hp1 t = t"
+  shows "transforms tmE2 tps25 ttt tpsE2"
+  unfolding tmE2_def
+proof (tform tps: tps0 tpsE1_def tpsE2_def jk assms time: assms(1))
+  let ?sigma = "[N + (t - Suc 0) * Z..<N + (t - Suc 0) * Z + Z] @
+            [N + t * Z..<N + t * Z + Z] @ [hp0 ! t * G..<hp0 ! t * G + G]"
+  show "variables \<psi>' \<subseteq> {..<length ?sigma}"
+    using assms(2) psi'(1) by auto
+  show "tpsE1 ! (j3 + 11) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    using tpsE1_def jk nllcontents_Nil by simp
+  show "tpsE1 ! (j3 + 11 + 1) = (\<lfloor>?sigma\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using assms(2) tpsE1_def jk by (simp add: add.commute[of j3 12])
+  show "tpsE1 ! (j3 + 11 + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tpsE1_def jk nlcontents_Nil by (simp add: add.commute[of j3 13])
+  show "tpsE1 ! (j3 + 11 + 3) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tpsE1_def jk tps0_sym nlcontents_Nil by simp
+  show "tpsE1 ! (j3 + 11 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsE1_def jk tps0_sym canrepr_0 by simp
+  show "tpsE1 ! (j3 + 11 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsE1_def jk tps0_sym canrepr_0 by simp
+  show "tpsE2 = tpsE1[j3 + 11 := nlltape' (formula_n (relabel ?sigma \<psi>')) 0]"
+    unfolding tpsE2_def tpsE1_def using assms(2) by (simp add: list_update_swap[of "j3+11"])
+qed
+
+definition "tpsTT1 \<equiv> tps0
+  [j3 + 11 := nlltape' (formula_n (relabel \<sigma> \<psi>)) 0,
+   j3 + 13 := (\<lfloor>[]\<rfloor>, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := (\<lfloor>\<sigma>\<rfloor>\<^sub>N\<^sub>L, 1),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tmTT1 [transforms_intros]:
+  assumes "ttt = 7 + 108 * (nlllength (formula_n \<psi>))\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)"
+    and "previous hp1 t \<noteq> t"
+  shows "transforms tmTT1 tps25 ttt tpsTT1"
+  unfolding tmTT1_def
+proof (tform tps: tps0 tps25_def tpsTT1_def jk time: assms(1))
+  let ?sigma = "[N + (t - Suc 0) * Z..<N + (t - Suc 0) * Z + Z] @
+            (if previous hp1 t \<noteq> t
+             then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z]
+             else []) @
+            [N + t * Z..<N + t * Z + Z] @ [hp0 ! t * G..<hp0 ! t * G + G]"
+  show "variables \<psi> \<subseteq> {..<length ?sigma}"
+    using assms(2) psi(1) by auto
+  show "tps25 ! (j3 + 11) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    using tps25_def jk nllcontents_Nil by simp
+  show "tps25 ! (j3 + 11 + 1) = (\<lfloor>?sigma\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tps25_def jk by (simp add: add.commute[of j3 12])
+  show "tps25 ! (j3 + 11 + 2) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tps25_def jk canrepr_0 nlcontents_Nil assms(2) by (simp add: add.commute[of j3 13])
+  show "tps25 ! (j3 + 11 + 3) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tps25_def jk tps0_sym nlcontents_Nil by simp
+  show "tps25 ! (j3 + 11 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps25_def jk tps0_sym canrepr_0 by simp
+  show "tps25 ! (j3 + 11 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps25_def jk tps0_sym canrepr_0 by simp
+  show "tpsTT1 = tps25[j3 + 11 := nlltape' (formula_n (relabel ?sigma \<psi>)) 0]"
+    using tpsTT1_def tps25_def assms(2) canrepr_0 by (simp add: list_update_swap[of "j3+11"])
+qed
+
+definition "tps26 \<equiv> tps0
+  [j3 + 11 := nlltape' (formula_n (relabel \<sigma> (if previous hp1 t = t then \<psi>' else \<psi>))) 0,
+   j3 + 13 := (\<lfloor>[]\<rfloor>, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := (\<lfloor>\<sigma>\<rfloor>\<^sub>N\<^sub>L, 1),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma nlllength_psi: "nlllength (formula_n \<psi>) \<le> 24 * Z ^ 2 * 2 ^ (4*Z)"
+proof -
+  let ?V = "3 * Z + G"
+  have "\<And>v. v \<in> variables \<psi> \<Longrightarrow> v \<le> ?V"
+    using psi(1) by auto
+  then have "nlllength (formula_n \<psi>) \<le> fsize \<psi> * Suc (Suc (nlength ?V)) + length \<psi>"
+    using nlllength_formula_n by simp
+  also have "... \<le> fsize \<psi> * Suc (Suc (nlength ?V)) + 2 ^ ?V"
+    using psi by simp
+  also have "... \<le> ?V * 2 ^ ?V * Suc (Suc (nlength ?V)) + 2 ^ ?V"
+    using psi(2) by (metis add_le_mono1 mult.commute mult_le_mono2)
+  also have "... \<le> 4*Z * 2 ^ ?V * Suc (Suc (nlength ?V)) + 2 ^ ?V"
+    using Z by simp
+  also have "... \<le> 4*Z * 2 ^ (4*Z) * Suc (Suc (nlength ?V)) + 2 ^ ?V"
+  proof -
+    have "?V \<le> 4 * Z"
+      using Z by simp
+    then have "(2::nat) ^ ?V \<le> 2 ^ (4*Z)"
+      by simp
+    then show ?thesis
+      using add_le_mono le_refl mult_le_mono by presburger
+  qed
+  also have "... \<le> 4*Z * (2::nat) ^ (4*Z) * Suc (Suc (nlength (4*Z))) + 2 ^ ?V"
+    using Z nlength_mono by simp
+  also have "... \<le> 4*Z * (2::nat) ^ (4*Z) * Suc (Suc (4*Z)) + 2 ^ ?V"
+    using nlength_le_n by simp
+  also have "... \<le> 4*Z * 2 ^ (4*Z) * Suc (Suc (4*Z)) + 2 ^ (4*Z)"
+    using Z by simp
+  also have "... \<le> 4*Z * 2 ^ (4*Z) * (5*Z) + 2 ^ (4*Z)"
+    using Z G by simp
+  also have "... \<le> 4*Z * 2 ^ (4*Z) * (6*Z)"
+    using Z G by simp
+  also have "... = 24 * Z ^ 2 * 2 ^ (4*Z)"
+    by algebra
+  finally show ?thesis .
+qed
+
+lemma nlllength_psi': "nlllength (formula_n \<psi>') \<le> 24 * Z ^ 2 * 2 ^ (4*Z)"
+proof -
+  let ?V = "2 * Z + G"
+  have "\<And>v. v \<in> variables \<psi>' \<Longrightarrow> v \<le> ?V"
+    using psi'(1) by auto
+  then have "nlllength (formula_n \<psi>') \<le> fsize \<psi>' * Suc (Suc (nlength ?V)) + length \<psi>'"
+    using nlllength_formula_n by simp
+  also have "... \<le> fsize \<psi>' * Suc (Suc (nlength ?V)) + 2 ^ ?V"
+    using psi' by simp
+  also have "... \<le> ?V * 2 ^ ?V * Suc (Suc (nlength ?V)) + 2 ^ ?V"
+    using psi'(2) by (metis add_le_mono1 mult.commute mult_le_mono2)
+  also have "... \<le> 4*Z * 2 ^ ?V * Suc (Suc (nlength ?V)) + 2 ^ ?V"
+    using Z by simp
+  also have "... \<le> 4*Z * 2 ^ (4*Z) * Suc (Suc (nlength ?V)) + 2 ^ ?V"
+  proof -
+    have "?V \<le> 4 * Z"
+      using Z by simp
+    then have "(2::nat) ^ ?V \<le> 2 ^ (4*Z)"
+      by simp
+    then show ?thesis
+      using add_le_mono le_refl mult_le_mono by presburger
+  qed
+  also have "... \<le> 4*Z * (2::nat) ^ (4*Z) * Suc (Suc (nlength (4*Z))) + 2 ^ ?V"
+    using Z nlength_mono by simp
+  also have "... \<le> 4*Z * (2::nat) ^ (4*Z) * Suc (Suc (4*Z)) + 2 ^ ?V"
+    using nlength_le_n by simp
+  also have "... \<le> 4*Z * 2 ^ (4*Z) * Suc (Suc (4*Z)) + 2 ^ (4*Z)"
+    using Z by simp
+  also have "... \<le> 4*Z * 2 ^ (4*Z) * (5*Z) + 2 ^ (4*Z)"
+    using Z G by simp
+  also have "... \<le> 4*Z * 2 ^ (4*Z) * (6*Z)"
+    using Z G by simp
+  also have "... = 24 * Z ^ 2 * 2 ^ (4*Z)"
+    by algebra
+  finally show ?thesis .
+qed
+
+lemma tm2526:
+  assumes "ttt = 17 + 108 * (24 * Z ^ 2 * 2 ^ (4*Z))\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)"
+  shows "transforms tm2526 tps25 ttt tps26"
+  unfolding tm2526_def
+proof (tform)
+  have *: "tps25 ! (j3 + 13) = (\<lfloor>previous hp1 t = t\<rfloor>\<^sub>B, 1)"
+    using tps25_def jk by simp
+  then have **: "(previous hp1 t \<noteq> t) = (read tps25 ! (j3 + 13) = \<box>)"
+    using jk tps25_def read_ncontents_eq_0 by force
+  show "read tps25 ! (j3 + 13) = \<box> \<Longrightarrow> previous hp1 t \<noteq> t"
+    using ** by simp
+  show "read tps25 ! (j3 + 13) \<noteq> \<box> \<Longrightarrow> previous hp1 t = t"
+    using ** by simp
+  show "read tps25 ! (j3 + 13) = \<box> \<Longrightarrow> tps26 = tpsTT1"
+    using tps26_def tpsTT1_def ** by presburger
+  show "read tps25 ! (j3 + 13) \<noteq> \<box> \<Longrightarrow> tps26 = tpsE2"
+    using tps26_def tpsE2_def ** by presburger
+
+  let ?tT = "7 + 108 * (nlllength (formula_n \<psi>))\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)"
+  let ?tF = "16 + 108 * (nlllength (formula_n \<psi>'))\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)"
+  have "?tT + 2 \<le> 9 + 108 * (24 * Z ^ 2 * 2 ^ (4*Z))\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2)"
+    using nlllength_psi linear_le_pow by simp
+  also have "... \<le> ttt"
+    using assms by simp
+  finally show "?tT + 2 \<le> ttt" .
+  show "?tF + 1 \<le> ttt"
+    using nlllength_psi' assms linear_le_pow by simp
+qed
+
+lemma nllength_\<sigma>: "nllength \<sigma> \<le> 12 * T' * Z^2 + 4 * Z * N"
+proof -
+  have "n \<le> N + T' * Z + Z" if "n \<in> set \<sigma>" for n
+  proof -
+    consider
+        "n \<in> set [N + (t - 1) * Z..<N + (t - 1) * Z + Z]"
+      | "n \<in> set [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z]"
+      | "n \<in> set [N + t * Z..<N + t * Z + Z]"
+      | "n \<in> set [hp0 ! t * G..<hp0 ! t * G + G]"
+      using `n \<in> set \<sigma>` by auto
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "n \<le> N + (t - 1) * Z + Z"
+        by simp
+      also have "... \<le> N + T' * Z + Z"
+        using t(2) by auto
+      finally show ?thesis
+        by simp
+    next
+      case 2
+      then have "n \<le> N + (previous hp1 t) * Z + Z"
+        by simp
+      also have "... \<le> N + t * Z + Z"
+        by (simp add: previous_hp1_le)
+      also have "... \<le> N + T' * Z + Z"
+        using t(2) by simp
+      finally show ?thesis
+        by simp
+    next
+      case 3
+      then have "n \<le> N + t * Z + Z"
+        by simp
+      also have "... \<le> N + T' * Z + Z"
+        using t(2) by auto
+      finally show ?thesis
+        by simp
+    next
+      case 4
+      then have "n \<le> N + (hp0 ! t) * G + G"
+        by simp
+      also have "... \<le> N + T' * G + G"
+        using t len_hp0 hp0 by simp
+      also have "... \<le> N + T' * Z + Z"
+        using Z by simp
+      finally show ?thesis
+        by simp
+    qed
+  qed
+  then have "nllength \<sigma> \<le> Suc (N + T' * Z + Z) * (length \<sigma>)"
+    using nllength_le[of \<sigma> "N + T' * Z + Z"] by simp
+  also have "... \<le> Suc (N + T' * Z + Z) * (3 * Z + G)"
+  proof -
+    have "length \<sigma> \<le> 3 * Z + G"
+      by simp
+    then show ?thesis
+      using mult_le_mono2 by presburger
+  qed
+  also have "... \<le> Suc (N + T' * Z + Z) * (3 * Z + Z)"
+    using Z by simp
+  also have "... = 4 * Z * Suc (N + T' * Z + Z)"
+    by simp
+  also have "... = 4 * Z + 4 * Z * (N + T' * Z + Z)"
+    by simp
+  also have "... = 4 * Z + 4 * Z * N + 4 * T' * Z^2 + 4 * Z^2"
+    by algebra
+  also have "... \<le> 4 * Z^2 + 4 * Z * N + 4 * T' * Z^2 + 4 * Z^2"
+    using linear_le_pow by simp
+  also have "... = 8 * Z^2 + 4 * Z * N + 4 * T' * Z^2"
+    by simp
+  also have "... \<le> 8 * T' * Z^2 + 4 * Z * N + 4 * T' * Z^2"
+    using t by simp
+  also have "... = 12 * T' * Z^2 + 4 * Z * N"
+    by simp
+  finally show ?thesis .
+qed
+
+lemma tm2526' [transforms_intros]:
+  assumes "ttt = 17 + 108 * (24 * Z ^ 2 * 2 ^ (4*Z))\<^sup>2 * (3 + (12 * T' * Z^2 + 4 * Z * N)\<^sup>2)"
+  shows "transforms tm2526 tps25 ttt tps26"
+proof -
+  have "17 + 108 * (24 * Z ^ 2 * 2 ^ (4*Z))\<^sup>2 * (3 + (nllength \<sigma>)\<^sup>2) \<le> ttt"
+    using assms nllength_\<sigma> by simp
+  then show ?thesis
+    using tm2526 transforms_monotone by simp
+qed
+
+lemma tm26 [transforms_intros]:
+  assumes "ttt = ttt20 + 31 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+    4 * nllength [hp0 ! t * G..<hp0 ! t * G + G] + 2 * nlength (hp0 ! t * G) +
+    2 * nlength (hp0 ! t) + nllength \<sigma> +
+    17 + 108 * (24 * Z ^ 2 * 2 ^ (4*Z))\<^sup>2 * (3 + (12 * T' * Z^2 + 4 * Z * N)\<^sup>2)"
+  shows "transforms tm26 tps0 ttt tps26"
+  unfolding tm26_def by (tform tps: assms)
+
+definition "tps27 \<equiv> tps0
+  [j3 + 11 := nlltape' (formula_n (relabel \<sigma> (if previous hp1 t = t then \<psi>' else \<psi>))) 0,
+   j3 + 13 := (\<lfloor>[]\<rfloor>, 1),
+   j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, 1),
+   j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+   j3 + 12 := (\<lfloor>[]\<rfloor>, 1),
+   j3 + 8 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm27:
+  assumes "ttt = ttt20 + 38 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+    4 * nllength [hp0 ! t * G..<hp0 ! t * G + G] + 2 * nlength (hp0 ! t * G) +
+    2 * nlength (hp0 ! t) + 3 * nllength \<sigma> +
+    17 + 108 * (24 * Z ^ 2 * 2 ^ (4*Z))\<^sup>2 * (3 + (12 * T' * Z^2 + 4 * Z * N)\<^sup>2)"
+  shows "transforms tm27 tps0 ttt tps27"
+  unfolding tm27_def
+proof (tform tps: tps0 tps26_def tps27_def jk)
+  let ?zs = "numlist \<sigma>"
+  show "tps26 ::: (j3 + 12) = \<lfloor>?zs\<rfloor>"
+    using tps26_def jk nlcontents_def by simp
+  show "proper_symbols ?zs"
+    using proper_symbols_numlist by simp
+  show "ttt = ttt20 + 31 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+      4 * nllength [hp0 ! t * G..<hp0 ! t * G + G] + 2 * nlength (hp0 ! t * G) +
+      2 * nlength (hp0 ! t) + nllength \<sigma> +
+      17 + 108 * (24 * Z\<^sup>2 * 2 ^ (4 * Z))\<^sup>2 * (3 + (12 * T' * Z\<^sup>2 + 4 * Z * N)\<^sup>2) +
+      (tps26 :#: (j3 + 12) + 2 * length (numlist \<sigma>) + 6)"
+    using tps26_def jk nllength_def assms by simp
+qed
+
+definition "tps27' \<equiv> tps0
+  [j3 + 11 := nlltape' (formula_n (relabel \<sigma> (if previous hp1 t = t then \<psi>' else \<psi>))) 0]"
+
+lemma tps27': "tps27 = tps27'"
+proof -
+  have 1: "tps0[j3 + 13 := (\<lfloor>[]\<rfloor>, Suc 0)] = tps0"
+    using list_update_id[of tps0 "j3+13"] jk tps0 by simp
+  have 2: "tps0[j3 + 12 := (\<lfloor>[]\<rfloor>, Suc 0)] = tps0"
+    using list_update_id[of tps0 "j3+12"] jk tps0 by simp
+  have 3: "tps0[j3 + 8 := (\<lfloor>[]\<rfloor>, Suc 0)] = tps0"
+    using list_update_id[of tps0 "j3+8"] jk tps0 by simp
+  have 4: "tps0[j3 + 7 := (\<lfloor>0\<rfloor>\<^sub>N, Suc 0)] = tps0"
+    using list_update_id[of tps0 "j3+7"] canrepr_0 jk tps0 by simp
+  have 5: "tps0[j3 + 6 := (\<lfloor>t\<rfloor>\<^sub>N, Suc 0)] = tps0"
+    using list_update_id[of tps0 "j3+6"] jk tps0 by simp
+  show ?thesis
+    unfolding tps27_def tps27'_def
+    using tps0
+    by (simp split del: if_split add:
+      list_update_swap[of _ "j3 + 13"] 1
+      list_update_swap[of _ "j3 + 12"] 2
+      list_update_swap[of _ "j3 + 8"] 3
+      list_update_swap[of _ "j3 + 7"] 4
+      list_update_swap[of _ "j3 + 6"] 5)
+qed
+
+definition "ttt27 = ttt20 + 38 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+    4 * nllength [hp0 ! t * G..<hp0 ! t * G + G] + 2 * nlength (hp0 ! t * G) +
+    2 * nlength (hp0 ! t) + 3 * nllength \<sigma> +
+    17 + 108 * (24 * Z ^ 2 * 2 ^ (4*Z))\<^sup>2 * (3 + (12 * T' * Z^2 + 4 * Z * N)\<^sup>2)"
+
+lemma tm27' [transforms_intros]: "transforms tm27 tps0 ttt27 tps27'"
+  using ttt27_def tm27 nllength_\<sigma> tps27' transforms_monotone by simp
+
+definition "tps28 \<equiv> tps0
+  [1 := nlltape (nss @ formula_n (relabel \<sigma> (if previous hp1 t = t then \<psi>' else \<psi>))),
+   j3 + 11 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm28:
+  assumes "ttt = ttt27 + (11 + 4 * nlllength (formula_n (relabel \<sigma> (if previous hp1 t = t then \<psi>' else \<psi>))))"
+  shows "transforms tm28 tps0 ttt tps28"
+  unfolding tm28_def by (tform tps: tps0(1) tps0 tps27'_def tps28_def jk time: ttt27_def assms)
+
+lemma nlllength_relabel_chi_t:
+  "nlllength (formula_n (relabel \<sigma> (if previous hp1 t = t then \<psi>' else \<psi>))) \<le>
+     Suc (nllength \<sigma>) * 24 * Z ^ 2 * 2 ^ (4*Z)"
+  (is "nlllength (formula_n (relabel \<sigma> ?phi)) \<le> _")
+proof -
+  have "variables ?phi \<subseteq> {..<length \<sigma>}"
+  proof (cases "previous hp1 t = t")
+    case True
+    then show ?thesis
+      using psi'(1) by auto
+  next
+    case False
+    then show ?thesis
+      using psi(1) by auto
+  qed
+  then have "nlllength (formula_n (relabel \<sigma> ?phi)) \<le> Suc (nllength \<sigma>) * nlllength (formula_n ?phi)"
+    using nlllength_relabel_variables by simp
+  moreover have "nlllength (formula_n ?phi) \<le> 24 * Z ^ 2 * 2 ^ (4*Z)"
+    using nlllength_psi nlllength_psi' by (cases "previous hp1 t = t") simp_all
+  ultimately have "nlllength (formula_n (relabel \<sigma> ?phi)) \<le> Suc (nllength \<sigma>) * (24 * Z ^ 2 * 2 ^ (4*Z))"
+    by (meson le_trans mult_le_mono2)
+  then show ?thesis
+    by linarith
+qed
+
+definition "tps28' \<equiv> tps0
+    [1 := nlltape (nss @ formula_n (relabel \<sigma> (if previous hp1 t = t then \<psi>' else \<psi>)))]"
+
+lemma tps28': "tps28' = tps28"
+  unfolding tps28'_def tps28_def using tps0 list_update_id[of tps0 "j3+11"]
+  by (simp add: list_update_swap[of _ "j3 + 11"])
+
+lemma tm28' [transforms_intros]:
+  assumes "ttt = ttt27 + (11 + 4 * (Suc (nllength \<sigma>) * 24 * Z ^ 2 * 2 ^ (4*Z)))"
+  shows "transforms tm28 tps0 ttt tps28'"
+  using assms tm28 tps28' nlllength_relabel_chi_t transforms_monotone by simp
+
+definition "tps29 \<equiv> tps0
+    [1 := nlltape (nss @ formula_n (relabel \<sigma> (if previous hp1 t = t then \<psi>' else \<psi>))),
+     j3 + 6 := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1)]"
+
+lemma tm29 [transforms_intros]:
+  assumes "ttt = ttt27 + 16 + 4 * (Suc (nllength \<sigma>) * 24 * Z ^ 2 * 2 ^ (4*Z)) + 2 * nlength t"
+  shows "transforms tm29 tps0 ttt tps29"
+  unfolding tm29_def by (tform tps: assms tps0 tps28'_def tps29_def jk)
+
+definition "tps30 \<equiv> tps0
+    [1 := nlltape (nss @ formula_n (relabel \<sigma> (if previous hp1 t = t then \<psi>' else \<psi>))),
+     j3 + 6 := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1),
+     j3 + 3 := (\<lfloor>T - 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm30:
+  assumes "ttt = ttt27 + 24 + 4 * (Suc (nllength \<sigma>) * 24 * Z ^ 2 * 2 ^ (4*Z)) + 2 * nlength t + 2 * nlength T"
+  shows "transforms tm30 tps0 ttt tps30"
+  unfolding tm30_def by (tform tps: assms tps0 tps29_def tps30_def jk)
+
+text \<open>
+Some helpers for bounding the running time:
+\<close>
+
+lemma pow4_le_2pow4: "z ^ 4 \<le> 2 ^ (4*z)" for z :: nat
+proof -
+  have "z ^ 4 = (z ^ 2) ^ 2"
+    by simp
+  also have "... \<le> (2^(2*z)) ^ 2"
+    using pow2_le_2pow2 power_mono by blast
+  also have "... = 2^(4*z)"
+    by (metis mult.commute mult_2_right numeral_Bit0 power_mult)
+  finally show ?thesis .
+qed
+
+lemma pow8_le_2pow8: "z ^ 8 \<le> 2 ^ (8*z)" for z :: nat
+proof -
+  have "z ^ 8 = (z ^ 2) ^ 4"
+    by simp
+  also have "... \<le> (2^(2*z)) ^ 4"
+    using pow2_le_2pow2 power_mono by blast
+  also have "... = 2^(8*z)"
+    by (metis mult.commute mult_2_right numeral_Bit0 power_mult)
+  finally show ?thesis .
+qed
+
+lemma Z_sq_le: "Z^2 \<le> 2^(16*Z)"
+proof -
+  have "Z^2 \<le> 2^(2*Z)"
+    using pow2_le_2pow2[of Z] by simp
+  also have "... \<le> 2^(16*Z)"
+    by simp
+  finally show "Z^2 \<le> 2^(16*Z)" .
+qed
+
+lemma time_bound:
+  "ttt27 + 24 + 4 * (Suc (nllength \<sigma>) * 24 * Z ^ 2 * 2 ^ (4*Z)) + 2 * nlength t + 2 * nlength T \<le> 16114765 * 2^(16*Z) * N^6"
+proof -
+  have sum_sq: "(a + b) ^ 2 \<le> Suc (2 * b) * a ^ 2 + b ^ 2" for a b :: nat
+  proof -
+    have "(a + b) ^ 2 = a ^ 2 + 2 * a * b + b ^ 2"
+      by algebra
+    also have "... \<le> a ^ 2 + 2 * a ^ 2 * b + b ^ 2"
+      using linear_le_pow by simp
+    also have "... = Suc (2 * b) * a ^ 2 + b ^ 2"
+      by simp
+    finally show ?thesis .
+  qed
+  have 1: "t < N"
+    using t T' by simp
+  then have 15: "t \<le> N"
+    by simp
+  have 2: "nlength t < N"
+    using 1 nlength_le_n dual_order.strict_trans2 by blast
+  have 25: "nlength T \<le> N"
+    using T T' nlength_le_n by (meson le_trans order_less_imp_le)
+  have 27: "nlength (t - 1) < N"
+    using t(1) nlength_mono 2
+    by (metis diff_less dual_order.strict_trans2 less_numeral_extra(1) linorder_not_less order.asym)
+  have 3: "t * Z < N * Z"
+    using 1 Z_ge_1 by simp
+  then have 4: "N + t * Z < Suc Z * N"
+    using 1 by simp
+  have 41: "N + t * Z + Z \<le> Suc Z * N"
+  proof -
+    have "N + t * Z + Z \<le> N + (N - 1) * Z + Z"
+      using 1 N by auto
+    then show ?thesis
+      using N
+      by (metis One_nat_def Suc_n_not_le_n ab_semigroup_add_class.add_ac(1) add.commute mult.commute mult_eq_if times_nat.simps(2))
+  qed
+  have 42: "(t + Z)^2 \<le> (N + Z) ^ 2"
+    using 1 by simp
+  have 45: "(N + Z) ^ 2 \<le> 3*Z*N^2 + Z^2"
+  proof -
+    have "(N + Z) ^ 2 \<le> Suc (2 * Z) * N^2 + Z^2"
+      using sum_sq by simp
+    also have "... \<le> 3*Z * N^2 +Z^2"
+      using Z_ge_1 by simp
+    finally show ?thesis .
+  qed
+  have 5: "nlength (previous hp1 t) < N"
+    using previous_hp1_le 1 by (meson dual_order.strict_trans2 nlength_le_n)
+  then have 51: "nlength (previous hp1 t) \<le> N"
+    by simp
+  have 6: "nlength (N + t * Z) < Suc Z * N"
+    using 4 nlength_le_n by (meson le_trans linorder_not_le)
+  have "nllength \<sigma> \<le> 12 * N * Z^2 + 4 * Z * N"
+  proof -
+    have "nllength \<sigma> \<le> 12 * T' * Z^2 + 4 * Z * N"
+      using nllength_\<sigma> by simp
+    also have "... \<le> 12 * N * Z^2 + 4 * Z * N"
+      using T' by simp
+    finally show ?thesis .
+  qed
+  have 7: "previous hp1 t \<le> N"
+    using previous_hp1_le 15 by simp
+  have 65: "(nlength (previous hp1 t) + nlength Z)\<^sup>2 < (N + Z) ^ 2"
+  proof -
+    have "nlength (previous hp1 t) + nlength Z < N + Z"
+      using 7 2 5 by (simp add: add_less_le_mono nlength_le_n)
+    then show ?thesis
+      by (simp add: power_strict_mono)
+  qed
+  have 66: "N + previous hp1 t * Z + Z \<le> Suc Z * N"
+    using 41 previous_hp1_le by (meson add_le_mono le_trans less_or_eq_imp_le mult_le_mono)
+  have 67: "(nlength t + nlength Z)\<^sup>2 \<le> 3 * Z * N^2 + Z^2"
+  proof -
+    have "nlength t + nlength Z < N + Z"
+      using nlength_le_n 2 by (simp add: add_less_le_mono)
+    then have "(nlength t + nlength Z)^2 < (N + Z) ^ 2"
+      by (simp add: power_strict_mono)
+    then show ?thesis
+      using 45 by simp
+  qed
+  have "nlength (previous hp1 t * Z) \<le> N * Z"
+    using nlength_le_n previous_hp1_le 1 by (meson le_trans less_or_eq_imp_le mult_le_mono)
+  have 75: "max (nlength N) (nlength (t * Z)) \<le> Suc Z * N"
+  proof -
+    have "max (nlength N) (nlength (t * Z)) \<le> nlength (max N (t * Z))"
+      using max_nlength by simp
+    also have "... \<le> nlength (N + t * Z)"
+      by (simp add: nlength_mono)
+    finally show ?thesis
+      using 6 by simp
+  qed
+  then have 78: "max (nlength N) (nlength (previous hp1 t * Z)) \<le> Suc Z * N"
+    using previous_hp1_le nlength_mono by (smt (verit, best) Groups.mult_ac(2) le_trans max_def mult_le_mono2)
+  have 79: "nlength (N + t * Z + Z) \<le> Suc Z * N + Z"
+  proof -
+    have "N + t * Z + Z \<le> Suc Z * N + Z"
+      using previous_le 15 by simp
+    then show ?thesis
+      using nlength_le_n le_trans by blast
+  qed
+  have 8: "nllength [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] \<le> 2 * Z^2 * N + 2 * Z^2"
+  proof -
+    have "nllength [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] \<le>
+        Suc (nlength (N + previous hp1 t * Z + Z)) * Z"
+      using nllength_upt_le_len_mult_max by (metis diff_add_inverse)
+    moreover have "nlength (N + previous hp1 t * Z + Z) \<le> Suc Z * N + Z"
+    proof -
+      have "N + previous hp1 t * Z + Z \<le> Suc Z * N + Z"
+        using previous_le 15 7 by simp
+      then show ?thesis
+        using nlength_le_n le_trans by blast
+    qed
+    ultimately have "nllength [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] \<le> Suc (Suc Z * N + Z) * Z"
+      by (meson Suc_le_mono le_trans less_or_eq_imp_le mult_le_mono)
+    also have "... = (Z^2 + Z) * Suc N"
+      by (metis add.commute mult.commute mult.left_commute mult_Suc nat_arith.suc1 power2_eq_square)
+    also have "... \<le> (Z^2 + Z^2) * Suc N"
+      by (meson add_le_cancel_left linear_le_pow mult_le_mono1 rel_simps(51))
+    also have "... = 2 * Z^2 * Suc N"
+      by simp
+    also have "... = 2 * Z^2 * N + 2 * Z^2"
+      by simp
+    finally show ?thesis .
+  qed
+  have 84: "Z * Suc Z \<le> 2 * Z^2"
+    by (simp add: power2_eq_square)
+  have 85: "nlength (N + previous hp1 t * Z) \<le> Suc Z * N"
+  proof -
+    have "nlength (N + previous hp1 t * Z) \<le> nlength (N + t * Z)"
+      using previous_hp1_le nlength_mono by simp
+    then show ?thesis
+      using 6 by simp
+  qed
+  have 9: "Suc Z \<le> 2*Z"
+    using Z_ge_1 by simp
+  then have 91: "Suc Z ^ 2 \<le> 4 * Z^2"
+    by (metis mult_2_right numeral_Bit0 power2_eq_square power2_nat_le_eq_le power_mult_distrib)
+  have 99: "Z^2 \<ge> 81"
+  proof -
+    have "Z * Z \<ge> 9 * 9"
+      using Z_ge_9 mult_le_mono by presburger
+    moreover have "9 * 9 = (81::nat)"
+      by simp
+    ultimately show ?thesis
+      by (simp add: power2_eq_square)
+  qed
+
+  have part1: "ttt8 \<le> 241 * Z^2 + 266 * Z^2 * N ^ 6"
+  proof -
+    have "ttt8 \<le> 168 + 153 * N ^ 6 + 5 * t + 26 * (t + Z)\<^sup>2 + 47 * Z + 15 * Z * (N + t * Z)"
+      using ttt8_def T' by simp
+    also have "... \<le> 168 + 153 * N ^ 6 + 5 * N + 26 * (t + Z)\<^sup>2 + 47 * Z + 15 * Z * (N + t * Z)"
+      using 15 by simp
+    also have "... \<le> 168 + 153 * N ^ 6 + 5 * N + 26 * (N + Z)\<^sup>2 + 47 * Z + 15 * Z * (N + t * Z)"
+      using 42 by simp
+    also have "... \<le> 168 + 153 * N ^ 6 + 5 * N + 26 * (3*Z*N^2 + Z^2) + 47 * Z + 15 * Z * (N + t * Z)"
+      using 45 by simp
+    also have "... \<le> 168 + 153 * N ^ 6 + 5 * N + 26 * (3*Z*N^2 + Z^2) + 47 * Z + 15 * Z * Suc Z * N"
+      using 4 by (metis (mono_tags, lifting) add_left_mono less_or_eq_imp_le mult.assoc mult_le_mono2)
+    also have "... \<le> 168 + 153 * N ^ 6 + 5 * N + 26 * (3*Z*N^2 + Z^2) + 47 * Z + 30 * Z^2 * N"
+      using `Z * Suc Z \<le> 2 * Z^2` by simp
+    also have "... = 168 + 153 * N ^ 6 + 5 * N + 78 * Z * N^2 + 26*Z^2 + 47 * Z + 30 * Z^2 * N"
+      by simp
+    also have "... \<le> 168 + 158 * N ^ 6 + 78 * Z * N^2 + 73 * Z^2 + 30 * Z^2 * N"
+      using linear_le_pow[of 6 N] linear_le_pow[of 2 Z] by simp
+    also have "... \<le> 168 + 158 * N ^ 6 + 78 * Z^2 * N^2 + 73 * Z^2 + 30 * Z^2 * N^2"
+      using linear_le_pow
+      by (metis add_le_mono add_le_mono1 le_square mult_le_mono1 mult_le_mono2 nat_add_left_cancel_le power2_eq_square)
+    also have "... = 168 + 158 * N ^ 6 + 108 * Z^2 * N^2 + 73 * Z^2"
+      by simp
+    also have "... \<le> 168*Z^2 + 158 * N ^ 6 + 108 * Z^2 * N^2 + 73 * Z^2"
+      using Z_ge_1 by simp
+    also have "... \<le> 241 * Z^2 + 158 * N ^ 6 + 108 * Z^2 * N^6"
+      using pow_mono'[of 2 6 N] by simp
+    also have "... \<le> 241 * Z^2 + 158 * Z^2 * N ^ 6 + 108 * Z^2 * N^6"
+      using Z_ge_1 by simp
+    also have "... = 241 * Z^2 + 266 * Z^2 * N ^ 6"
+      by simp
+    finally show ?thesis .
+  qed
+
+  have part2: "ttt10 - ttt8 \<le> 63 * Z^2 + 226 * Z^2 * N^6"
+  proof -
+    have "ttt10 - ttt8 = 37 + 26 * (nlength (previous hp1 t) + nlength Z)\<^sup>2 +
+        3 * max (nlength N) (nlength (previous hp1 t * Z)) +
+        Suc Z * (43 + 9 * nlength (N + previous hp1 t * Z + Z)) +
+        4 * nllength [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] +
+        2 * nlength (N + previous hp1 t * Z)"
+      using ttt10_def ttt8_def by simp
+    also have "... \<le> 37 + 26 * (nlength (previous hp1 t) + nlength Z)\<^sup>2 +
+        3 * max (nlength N) (nlength (previous hp1 t * Z)) +
+        Suc Z * (43 + 9 * nlength (N + previous hp1 t * Z + Z)) +
+        4 * (2 * Z^2 * N + 2 * Z^2) + 2 * nlength (N + previous hp1 t * Z)"
+      using 8 by simp
+    also have "... \<le> 37 + 26 * (N + Z)\<^sup>2 +
+        3 * max (nlength N) (nlength (previous hp1 t * Z)) +
+        Suc Z * (43 + 9 * nlength (N + previous hp1 t * Z + Z)) +
+        4 * (2 * Z^2 * N + 2 * Z^2) + 2 * nlength (N + previous hp1 t * Z)"
+      using 65 by linarith
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 3 * (Suc Z * N) +
+        Suc Z * (43 + 9 * nlength (N + previous hp1 t * Z + Z)) +
+        8 * Z^2 * N + 8 * Z^2 + 2 * nlength (N + previous hp1 t * Z)"
+      using 78 45 by auto
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 3 * (Suc Z * N) +
+        Suc Z * (43 + 9 * nlength (N + previous hp1 t * Z + Z)) +
+        8 * Z^2 * N + 8 * Z^2 + 2 * Suc Z * N"
+      using 85 by linarith
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 3 * (Suc Z * N) +
+        Suc Z * (43 + 9 * nlength (Suc Z * N)) +
+        8 * Z^2 * N + 8 * Z^2 + 2 * Suc Z * N"
+      using 66 nlength_mono add_le_mono le_refl mult_le_mono by presburger
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 3 * (Suc Z * N) +
+        Suc Z * (43 + 9 * (Suc Z * N)) +
+        8 * Z^2 * N + 8 * Z^2 + 2 * Suc Z * N"
+      using nlength_le_n add_le_mono le_refl mult_le_mono by presburger
+    also have "... = 37 + 26 * (3*Z*N^2 + Z^2) + 3 * (Suc Z * N) +
+        43 * Suc Z + Suc Z * 9 * Suc Z * N +
+        8 * Z^2 * N + 8 * Z^2 + 2 * Suc Z * N"
+      by algebra
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 3 * (Suc Z * N) +
+        43 * 2 * Z + 2 * Z * 9 * Suc Z * N +
+        8 * Z^2 * N + 8 * Z^2 + 2 * Suc Z * N"
+      using 9 by (simp add: add_le_mono)
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 3 * (Suc Z * N) +
+        86 * Z + 36 * Z * Z * N + 8 * Z^2 * N + 8 * Z^2 + 2 * Suc Z * N"
+      by simp
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 3 * (Suc Z * N) +
+        86 * Z + 44 * Z^2 * N + 8 * Z^2 + 2 * Suc Z * N"
+      by (simp add: power2_eq_square)
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 3 * (Suc Z * N) +
+        86 * Z + 44 * Z^2 * N + 8 * Z^2 + 4 * Z * N"
+      using 9 by simp
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 3 * (Suc Z * N) +
+        86 * Z + 48 * Z^2 * N + 8 * Z^2"
+      using linear_le_pow by simp
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 3 * 2 * Z * N +
+        86 * Z + 48 * Z^2 * N + 8 * Z^2"
+      using 9 by simp
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 6 * Z * N +
+        86 * Z^2 * N + 48 * Z^2 * N + 8 * Z^2"
+      using linear_le_pow[of 2 Z] N by simp (metis N le_trans mult_le_mono1 nat_mult_1)
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 140 * Z^2 * N + 8 * Z^2"
+      using linear_le_pow[of 2 Z] by simp
+    also have "... \<le> 37 + 26 * (3*Z*N^2 + Z^2) + 148 * Z^2 * N"
+      using N by simp
+    also have "... = 37 + 78 * Z * N^2 + 26 * Z^2 + 148 * Z^2 * N"
+      by simp
+    also have "... \<le> 63 * Z^2 + 78 * Z * N^2 + 148 * Z^2 * N"
+      using Z_ge_1 by simp
+    also have "... \<le> 63 * Z^2 + 78 * Z^2 * N^2 + 148 * Z^2 * N"
+      using linear_le_pow by simp
+    also have "... \<le> 63 * Z^2 + 226 * Z^2 * N^2"
+      using linear_le_pow by simp
+    also have "... \<le> 63 * Z^2 + 226 * Z^2 * N^6"
+      using pow_mono'[of 2 6 N] by simp
+    finally show ?thesis .
+  qed
+
+  have 10: "nllength hp0 \<le> N ^ 2"
+  proof -
+    have "\<forall>n\<in>set hp0. n \<le> T'"
+      using hp0 by (metis in_set_conv_nth)
+    then have "nllength hp0 \<le> Suc T' * Suc T'"
+      using nllength_le[of hp0 T'] len_hp0 by simp
+    also have "... \<le> N * N"
+      using T' Suc_leI mult_le_mono by presburger
+    also have "... = N ^ 2"
+      by algebra
+    finally show ?thesis .
+  qed
+  have 11: "nllength [N + t * Z..<N + t * Z + Z] \<le> 2 * Z^2 * N + Z"
+  proof -
+    have "nllength [N + t * Z..<N + t * Z + Z] \<le> Suc (N + t * Z + Z) * Z"
+      using nllength_upt_le[of "N + t * Z" "N + t * Z + Z"] by simp
+    also have "... \<le> Suc (Suc Z * N) * Z"
+      using 41 by simp
+    also have "... = (Z*Z + Z)*N + Z"
+      by (metis add.commute mult.commute mult.left_commute mult_Suc)
+    also have "... \<le> 2 * Z^2 * N + Z"
+      using linear_le_pow[of 2 Z] by (simp add: power2_eq_square)
+    finally show ?thesis .
+  qed
+  have 12: "nlength (hp0 ! t) + nlength G \<le> N + Z"
+  proof -
+    have "nlength (hp0 ! t) + nlength G \<le> hp0 ! t + G"
+      using nlength_le_n by (simp add: add_mono)
+    also have "... \<le> T' + Z"
+      using Z by (simp add: add_le_mono hp0 le_imp_less_Suc len_hp0 t(2))
+    also have "... \<le> N + Z"
+      using T' by simp
+    finally show ?thesis .
+  qed
+
+  have part3: "ttt20 - ttt10 \<le> 120 * Z^2 + 206 * Z^2 * N ^ 4"
+  proof -
+    have "ttt20 - ttt10 = 80 + 2 * nlength (t - 1) + 26 * (nlength t + nlength Z)\<^sup>2 +
+        3 * max (nlength N) (nlength (t * Z)) + Suc Z * (43 + 9 * nlength (N + t * Z + Z)) +
+        4 * nllength [N + t * Z..<N + t * Z + Z] + 2 * nlength (previous hp1 t) +
+        21 * (nllength hp0)\<^sup>2 + 2 * nlength (N + t * Z) + 26 * (nlength (hp0 ! t) + nlength G)\<^sup>2"
+      using ttt20_def ttt10_def by simp
+    also have "... \<le> 80 + 2 * N + 26 * (3 * Z * N^2 + Z^2) +
+        3 * (Suc Z * N) + Suc Z * (43 + 9 * nlength (N + t * Z + Z)) +
+        4 * nllength [N + t * Z..<N + t * Z + Z] + 2 * nlength (previous hp1 t) +
+        21 * (nllength hp0)\<^sup>2 + 2 * nlength (N + t * Z) + 26 * (nlength (hp0 ! t) + nlength G)\<^sup>2"
+      using 27 67 75 by auto
+    also have "... \<le> 80 + 2 * N + 26 * (3 * Z * N^2 + Z^2) +
+        3 * (Suc Z * N) + Suc Z * (43 + 9 * (Suc Z * N + Z)) +
+        4 * nllength [N + t * Z..<N + t * Z + Z] + 2 * nlength (previous hp1 t) +
+        21 * (nllength hp0)\<^sup>2 + 2 * nlength (N + t * Z) + 26 * (nlength (hp0 ! t) + nlength G)\<^sup>2"
+      using 79 add_le_mono le_refl mult_le_mono by presburger
+    also have "... \<le> 80 + 2 * N + 26 * (3 * Z * N^2 + Z^2) +
+        3 * (Suc Z * N) + Suc Z * (43 + 9 * (Suc Z * N + Z)) +
+        4 * nllength [N + t * Z..<N + t * Z + Z] + 2 * N +
+        21 * (nllength hp0)\<^sup>2 + 2 * nlength (N + t * Z) + 26 * (N + Z)\<^sup>2"
+      using 51 12
+      by (metis add_le_cancel_right add_le_mono nat_add_left_cancel_le nat_mult_le_cancel_disj power2_nat_le_eq_le)
+    also have "... \<le> 80 + 4 * N + 52 * (3 * Z * N^2 + Z^2) + 3 * (Suc Z * N) + Suc Z * (43 + 9 * (Suc Z * N + Z)) +
+        4 * nllength [N + t * Z..<N + t * Z + Z] + 21 * (nllength hp0)\<^sup>2 + 2 * nlength (N + t * Z)"
+      using 45 by simp
+    also have "... \<le> 80 + 4 * N + 52 * (3 * Z * N^2 + Z^2) + 3 * (Suc Z * N) + Suc Z * (43 + 9 * (Suc Z * N + Z)) +
+        4 * nllength [N + t * Z..<N + t * Z + Z] + 21 * (nllength hp0)\<^sup>2 + 2 * Suc Z * N"
+      using 6 by linarith
+    also have "... \<le> 80 + 4 * N + 52 * (3 * Z * N^2 + Z^2) + 3 * (Suc Z * N) + Suc Z * (43 + 9 * (Suc Z * N + Z)) +
+        4 * (2 * Z^2 * N + Z) + 21 * (N^2)\<^sup>2 + 2 * Suc Z * N"
+      using 11 10 add_le_mono le_refl mult_le_mono2 power2_nat_le_eq_le by presburger
+    also have "... = 80 + 4 * N + 156 * Z * N^2 + 52 * Z^2 + 3 * (Suc Z * N) + Suc Z * (43 + 9 * (Suc Z * N + Z)) +
+        8 * Z^2 * N + 4 * Z + 21 * N ^ 4 + 2 * Suc Z * N"
+      by simp
+    also have "... = 80 + 156 * Z * N^2 + 52 * Z^2 + Suc Z * 43 + Suc Z * 9 * Suc Z * N + Suc Z * 9 * Z +
+        (4 + 5 * Suc Z + 8 * Z^2) * N + 4 * Z + 21 * N ^ 4"
+      by algebra
+    also have "... = 123 + 156 * Z * N^2 + 52 * Z^2 + 47 * Z + 9 * Suc Z * Suc Z * N + Suc Z * 9 * Z +
+        (9 + 5 * Z + 8 * Z^2) * N + 21 * N ^ 4"
+      by simp
+    also have "... = 123 + 156 * Z * N^2 + 52 * Z^2 + 47 * Z + 9 * Z * Suc Z +
+        (9 * Suc Z^2 + 9 + 5 * Z + 8 * Z^2) * N + 21 * N ^ 4"
+      by algebra
+    also have "... \<le> 123 + 156 * Z * N^2 + 52 * Z^2 + 47 * Z + 9 * Z * Suc Z +
+        (44 * Z^2 + 9 + 5 * Z) * N + 21 * N ^ 4"
+      using 91 by simp
+    also have "... \<le> 123 + 156 * Z * N^2 + 70 * Z^2 + 47 * Z + (44 * Z^2 + 9 + 5 * Z) * N + 21 * N ^ 4"
+      using 84 by simp
+    also have "... \<le> 123 + 156 * Z * N^2 + 70 * Z^2 + 47 * Z^2 + (44 * Z^2 + 9 + 5 * Z^2) * N + 21 * N ^ 4"
+      using linear_le_pow[of 2 Z] add_le_mono le_refl mult_le_mono power2_nat_le_imp_le
+      by presburger
+    also have "... \<le> 123 + 156 * Z * N^2 + 117 * Z^2 + (49 * Z^2 + 9) * N ^ 4 + 21 * N ^ 4"
+      using linear_le_pow[of 4 N] by simp
+    also have "... \<le> 123 + 156 * Z * N^4 + 117 * Z^2 + (49 * Z^2 + 9) * N ^ 4 + 21 * N ^ 4"
+      using pow_mono'[of 2 4 N] by simp
+    also have "... = 123 + 117 * Z^2 + (156 * Z + 49 * Z^2 + 30) * N ^ 4"
+      by algebra
+    also have "... \<le> 123 + 117 * Z^2 + (205 * Z^2 + 30) * N ^ 4"
+      using linear_le_pow[of 2 Z] by simp
+    also have "... \<le> 120 * Z^2 + (205 * Z^2 + 30) * N ^ 4"
+      using 99 by simp
+    also have "... \<le> 120 * Z^2 + 206 * Z^2 * N ^ 4"
+      using 99 by simp
+    finally show ?thesis .
+  qed
+
+  have 12: "hp0 ! t * G + G \<le> Z * N"
+  proof -
+    have "hp0 ! t * G + G \<le> T' * G + G"
+      using hp0 t(2) len_hp0 by simp
+    also have "... \<le> (N - 1) * G + G"
+      using T' by auto
+    also have "... = N * G"
+      using T' by (metis Suc_diff_1 add.commute less_nat_zero_code mult_Suc not_gr_zero)
+    also have "... \<le> Z * N"
+      using Z by simp
+    finally show ?thesis .
+  qed
+  have 13: "Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) \<le> 43 * Z + 9 * Z^2 * N"
+  proof -
+    have "Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) \<le> Suc G * (43 + 9 * (hp0 ! t * G + G))"
+      using nlength_le_n add_le_mono le_refl mult_le_mono by presburger
+    also have "... \<le> Suc G * (43 + 9 * (Z * N))"
+      using 12 add_le_mono less_or_eq_imp_le mult_le_mono by presburger
+    also have "... \<le> Z * (43 + 9 * (Z * N))"
+      using G Z by simp
+    also have "... = 43 * Z + 9 * N * Z * Z"
+      by algebra
+    also have "... = 43 * Z + 9 * Z^2 * N"
+      by algebra
+    finally show ?thesis .
+  qed
+  have 14: "nllength [hp0 ! t * G..<hp0 ! t * G + G] \<le> Z^2 * N"
+  proof -
+    have "nllength [hp0 ! t * G..<hp0 ! t * G + G] \<le> (hp0 ! t * G + G) * Suc G"
+      using nllength_upt_le[of "hp0 ! t * G" "hp0 ! t * G + G"] by simp
+    also have "... \<le> (hp0 ! t * G + G) * Z"
+      using Z G by simp
+    also have "... \<le> N * Z * Z"
+      using 12 by (simp add: mult.commute)
+    also have "... = Z^2 * N"
+      by algebra
+    finally show ?thesis .
+  qed
+  have 15: "nlength (hp0 ! t) \<le> N"
+    using T' hp0 t(2) len_hp0 nlength_le_n by (metis le_imp_less_Suc le_trans less_or_eq_imp_le)
+  have 16: "nlength (hp0 ! t * G) \<le> Z * N"
+  proof -
+    have "nlength (hp0 ! t * G) \<le> hp0 ! t * G"
+      using nlength_le_n by simp
+    also have "... \<le> T' * G"
+      using Z T' hp0 t(2) len_hp0 by simp
+    also have "... \<le> Z * N"
+      using Z T' by simp
+    finally show ?thesis .
+  qed
+  have 17: "(12 * T' * Z\<^sup>2 + 4 * Z * N) ^ 2 \<le> 256 * Z^4 * N^2"
+  proof -
+    have "(12 * T' * Z\<^sup>2 + 4 * Z * N) ^ 2 \<le> (12 * N * Z^2 + 4 * Z * N)^2"
+      using T' by simp
+    also have "... \<le> (12 * N * Z^2 + 4 * Z^2 * N)^2"
+      using linear_le_pow[of 2 Z] add_le_mono le_refl mult_le_mono power2_nat_le_eq_le power2_nat_le_imp_le
+      by presburger
+    also have "... = 256 * Z^4 * N^2"
+      by algebra
+    finally show ?thesis .
+  qed
+  have 18: "108 * (24 * Z\<^sup>2 * 2 ^ (4 * Z))\<^sup>2 * (3 + (12 * T' * Z\<^sup>2 + 4 * Z * N)\<^sup>2) \<le> 16111872 * 2^(16*Z) * N^2"
+  proof -
+    have "108 * (24 * Z\<^sup>2 * 2 ^ (4 * Z))\<^sup>2 = 62208 * (Z^2 * 2 ^ (4*Z))^2"
+      by algebra
+    also have "... = 62208 * Z^(2*2) * 2 ^ (2*(4*Z))"
+      by (metis (no_types, lifting) mult.assoc power_even_eq power_mult_distrib)
+    also have "... = 62208 * Z^4 * 2 ^ (8*Z)"
+      by simp
+    finally have *: "108 * (24 * Z\<^sup>2 * 2 ^ (4 * Z))\<^sup>2 = 62208 * Z^4 * 2 ^ (8*Z)" .
+    have "3 + (12 * T' * Z\<^sup>2 + 4 * Z * N)\<^sup>2 \<le> 3 + 256 * Z^4 * N^2"
+      using 17 by simp
+    moreover have "Z^4 * N^2 \<ge> 1"
+      using Z_ge_1 N by simp
+    ultimately have "3 + (12 * T' * Z\<^sup>2 + 4 * Z * N)\<^sup>2 \<le> 259 * Z^4 * N^2"
+      by linarith
+    then have "108 * (24 * Z\<^sup>2 * 2 ^ (4 * Z))\<^sup>2 * (3 + (12 * T' * Z\<^sup>2 + 4 * Z * N)\<^sup>2) \<le>
+        16111872 * Z^4 * 2 ^ (8*Z) * Z^4 * N^2"
+      using * by simp
+    also have "... = 16111872 * Z^8 * 2 ^ (8*Z) * N^2"
+      by simp
+    also have "... \<le> 16111872 * 2^(8*Z) * 2 ^ (8*Z) * N^2"
+      using pow8_le_2pow8 by simp
+    also have "... = 16111872 * 2^(8*Z+8*Z) * N^2"
+      by (metis (no_types, lifting) mult.assoc power_add)
+    also have "... = 16111872 * 2^(16*Z) * N^2"
+      by simp
+    finally show ?thesis .
+  qed
+  have 19: "nllength \<sigma> \<le> 16 * Z^2 * N"
+  proof -
+    have "nllength \<sigma> \<le> 12 * T' * Z^2 + 4 * Z * N"
+      using nllength_\<sigma> by simp
+    also have "... \<le> 12 * N * Z^2 + 4 * Z * N"
+      using T' by simp
+    also have "... \<le> 12 * Z^2 * N + 4 * Z^2 * N"
+      using linear_le_pow[of 2 Z] by simp
+    also have "... \<le> 16 * Z^2 * N"
+      by simp
+    finally show ?thesis .
+  qed
+
+  have part4: "ttt27 - ttt20 \<le> 50 * Z + 16111936 * 2^(16*Z) * N^2"
+  proof -
+    have "ttt27 - ttt20 = 55 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+        4 * nllength [hp0 ! t * G..<hp0 ! t * G + G] +
+        2 * nlength (hp0 ! t * G) + 2 * nlength (hp0 ! t) + 3 * nllength \<sigma> +
+        108 * (24 * Z\<^sup>2 * 2 ^ (4 * Z))\<^sup>2 * (3 + (12 * T' * Z\<^sup>2 + 4 * Z * N)\<^sup>2)"
+      using ttt27_def ttt20_def by linarith
+    also have "... \<le> 55 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+        4 * nllength [hp0 ! t * G..<hp0 ! t * G + G] +
+        2 * nlength (hp0 ! t * G) + 2 * nlength (hp0 ! t) + 3 * (16 * Z^2 * N) +
+        108 * (24 * Z\<^sup>2 * 2 ^ (4 * Z))\<^sup>2 * (3 + (12 * T' * Z\<^sup>2 + 4 * Z * N)\<^sup>2)"
+      using 19 by (simp add: mult.commute)
+    also have "... \<le> 55 + Suc G * (43 + 9 * nlength (hp0 ! t * G + G)) +
+        2 * Z * N + 2 * N + 52 * Z^2 * N + 16111872 * 2^(16*Z) * N^2"
+      using 14 15 16 18 by linarith
+    also have "... \<le> 55 + 43 * Z + 9 * Z^2 * N + 2 * Z * N + 2 * N + 52 * Z^2 * N + 16111872 * 2^(16*Z) * N^2"
+      using 13 by linarith
+    also have "... = 55 + 43 * Z + 2 * Z * N + 2 * N + 61 * Z^2 * N + 16111872 * 2^(16*Z) * N^2"
+      by simp
+    also have "... \<le> 50 * Z + 2 * Z * N + 2 * N + 61 * Z^2 * N + 16111872 * 2^(16*Z) * N^2"
+      using Z_ge_9 by simp
+    also have "... \<le> 50 * Z + 3 * Z * N + 61 * Z^2 * N + 16111872 * 2^(16*Z) * N^2"
+      using Z_ge_9 by simp
+    also have "... \<le> 50 * Z + 64 * Z^2 * N + 16111872 * 2^(16*Z) * N^2"
+      using linear_le_pow[of 2 Z] by simp
+    also have "... \<le> 50 * Z + 64 * Z^2 * N^2 + 16111872 * 2^(16*Z) * N^2"
+      using linear_le_pow[of 2 N] by simp
+    also have "... \<le> 50 * Z + 64 * 2^(2*Z) * N^2 + 16111872 * 2^(16*Z) * N^2"
+      using pow2_le_2pow2 by simp
+    also have "... \<le> 50 * Z + 64 * 2^(16*Z) * N^2 + 16111872 * 2^(16*Z) * N^2"
+      by simp
+    also have "... = 50 * Z + 16111936 * 2^(16*Z) * N^2"
+      by simp
+    finally show ?thesis .
+  qed
+
+  have part5: "24 + 4 * (Suc (nllength \<sigma>) * 24 * Z ^ 2 * 2 ^ (4*Z)) + 2 * nlength t + 2 * nlength T \<le>
+    24 + 1633 * 2^(8*Z) * N"
+  proof -
+    have "24 + 4 * (Suc (nllength \<sigma>) * 24 * Z ^ 2 * 2 ^ (4*Z)) + 2 * nlength t + 2 * nlength T \<le>
+        24 + 4 * (Suc (nllength \<sigma>) * 24 * Z ^ 2 * 2 ^ (4*Z)) + 4 * N"
+      using 25 2 by simp
+    also have "... \<le> 24 + 4 * (Suc (16 * Z^2 * N) * 24 * Z ^ 2 * 2 ^ (4*Z)) + 4 * N"
+      using 19 by (simp add: mult.commute)
+    also have "... \<le> 24 + 1632 * Z^2 * N * Z ^ 2 * 2 ^ (4*Z) + 4 * N"
+      using Z N by simp
+    also have "... = 24 + 1632 * Z^4 * 2 ^ (4*Z) * N + 4 * N"
+      by simp
+    also have "... \<le> 24 + 1632 * 2^(4*Z) * 2 ^ (4*Z) * N + 4 * N"
+      using pow4_le_2pow4 by simp
+    also have "... = 24 + 1632 * 2^(8*Z) * N + 4 * N"
+      by (metis (no_types, lifting) ab_semigroup_mult_class.mult_ac(1) add_mult_distrib numeral_Bit0 power_add)
+    also have "... \<le> 24 + 1632 * 2^(8*Z) * N + 2^(8*Z) * N"
+    proof -
+      have "(4::nat) \<le> 2 ^ 8"
+        by simp
+      also have "... \<le> 2 ^ (8*Z)"
+        using Z_ge_1 by (metis nat_mult_1_right nat_mult_le_cancel_disj one_le_numeral power_increasing)
+      finally have "(4::nat) \<le> 2 ^ (8*Z)" .
+      then show ?thesis
+        by simp
+    qed
+    also have "... \<le> 24 + 1633 * 2^(8*Z) * N"
+      by simp
+    finally show ?thesis .
+  qed
+
+  show "ttt27 + 24 + 4 * (Suc (nllength \<sigma>) * 24 * Z ^ 2 * 2 ^ (4*Z)) + 2 * nlength t + 2 * nlength T \<le>
+    16114765 * 2^(16*Z) * N^6"
+  proof -
+    have "ttt27 \<le> ttt20 + 50 * Z + 16111936 * 2^(16*Z) * N^2"
+      using part4 ttt27_def by simp
+    also have "... \<le> ttt10 + 120 * Z^2 + 206 * Z^2 * N ^ 4 + 50 * Z + 16111936 * 2^(16*Z) * N^2"
+      using part3 ttt20_def by simp
+    also have "... \<le> ttt8 + 63 * Z^2 + 226 * Z^2 * N^6 + 120 * Z^2 + 206 * Z^2 * N ^ 4 + 50 * Z +
+        16111936 * 2^(16*Z) * N^2"
+      using part2 ttt10_def by simp
+    also have "... \<le> 241 * Z^2 + 266 * Z^2 * N ^ 6 + 63 * Z^2 + 226 * Z^2 * N^6 + 120 * Z^2 +
+        206 * Z^2 * N ^ 4 + 50 * Z + 16111936 * 2^(16*Z) * N^2"
+      using part1 by simp
+    also have "... = 424 * Z^2 + 492 * Z^2 * N ^ 6 + 206 * Z^2 * N ^ 4 + 50 * Z + 16111936 * 2^(16*Z) * N^2"
+      by simp
+    also have "... \<le> 474 * Z^2 + 492 * Z^2 * N ^ 6 + 206 * Z^2 * N ^ 4 + 16111936 * 2^(16*Z) * N^2"
+      using linear_le_pow[of 2 Z] by simp
+    also have "... \<le> 474 * Z^2 + 698 * Z^2 * N ^ 6 + 16111936 * 2^(16*Z) * N^2"
+      using pow_mono'[of 4 6 N] by simp
+    also have "... \<le> 474 * Z^2 + 698 * Z^2 * N ^ 6 + 16111936 * 2^(16*Z) * N^6"
+      using pow_mono'[of 2 6 N] by simp
+    also have "... \<le> 474 * Z^2 + 698 * 2^(16*Z) * N ^ 6 + 16111936 * 2^(16*Z) * N^6"
+      using Z_sq_le by simp
+    also have "... = 474 * Z^2 + 16112634 * 2^(16*Z) * N^6"
+      by simp
+    also have "... \<le> 474 * 2^(16*Z) + 16112634 * 2^(16*Z) * N^6"
+      using Z_sq_le by simp
+    also have "... \<le> 16113108 * 2^(16*Z) * N^6"
+      using N by simp
+    finally have "ttt27 \<le> 16113108 * 2^(16*Z) * N^6" .
+    then have "ttt27 + 24 + 4 * (Suc (nllength \<sigma>) * 24 * Z ^ 2 * 2 ^ (4*Z)) + 2 * nlength t + 2 * nlength T \<le>
+        16113108 * 2^(16*Z) * N^6 + 24 + 1633 * 2^(8*Z) * N"
+      using part5 by simp
+    also have "... \<le> 16113108 * 2^(16*Z) * N^6 + 24 + 1633 * 2^(16*Z) * N"
+      by simp
+    also have "... \<le> 16113108 * 2^(16*Z) * N^6 + 24 + 1633 * 2^(16*Z) * N^6"
+      using linear_le_pow[of 6 N] by simp
+    also have "... = 24 + 16114741 * 2^(16*Z) * N^6"
+      by simp
+    also have "... \<le> 24 * 2^(16*Z) + 16114741 * 2^(16*Z) * N^6"
+      using Z_sq_le by simp
+    also have "... \<le> 16114765 * 2^(16*Z) * N^6"
+      using N by simp
+    finally show ?thesis .
+  qed
+qed
+
+lemma tm30':
+  assumes "ttt = 16114765 * 2^(16*Z) * N^6"
+  shows "transforms tm30 tps0 ttt tps30"
+  using tm30 time_bound transforms_monotone assms by simp
+
+end  (* context tps0 *)
+
+end  (* locale turing_machine_chi *)
+
+lemma transforms_tm_chi:
+  fixes j1 j2 j3 :: tapeidx
+  fixes tps tps' :: "tape list" and k G N Z T' T t :: nat and hp0 hp1 :: "nat list" and \<psi> \<psi>' :: formula
+  fixes nss :: "nat list list"
+  assumes "length tps = k"
+    and "1 < j1" "j1 < j2" "j2 < j3" "j3 + 17 < k"
+    and "G \<ge> 3"
+    and "Z = 3 * G"
+    and "N \<ge> 1"
+    and "length hp0 = Suc T'"
+    and "\<forall>i<length hp0. hp0 ! i \<le> T'"
+    and "length hp1 = Suc T'"
+    and "\<forall>i<length hp1. hp1 ! i \<le> T'"
+    and "0 < t" "t \<le> T'"
+    and "0 < T" "T \<le> T'"
+    and "T' < N"
+    and "variables \<psi> \<subseteq> {..<3*Z+G}" "fsize \<psi> \<le> (3*Z+G) * 2 ^ (3*Z+G)" "length \<psi> \<le> 2 ^ (3*Z+G)"
+    and "variables \<psi>' \<subseteq> {..<2*Z+G}" "fsize \<psi>' \<le> (2*Z+G) * 2 ^ (2*Z+G)" "length \<psi>' \<le> 2 ^ (2*Z+G)"
+  assumes
+    "tps ! 1 = nlltape nss"
+    "tps ! j1 = (\<lfloor>hp0\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! j2 = (\<lfloor>hp1\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! j3 = (\<lfloor>N\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 1) = (\<lfloor>G\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 2) = (\<lfloor>Z\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 3) = (\<lfloor>T\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 4) = (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps ! (j3 + 5) = (\<lfloor>formula_n \<psi>'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps ! (j3 + 6) = (\<lfloor>t\<rfloor>\<^sub>N, 1)"
+    "\<And>i. 6 < i \<Longrightarrow> i < 17 \<Longrightarrow> tps ! (j3 + i) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "tps' = tps
+        [1 := nlltape (nss @ formula_n (relabel
+          ([N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+            (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else []) @
+            [N + t * Z..<N + t * Z + Z] @
+            [hp0 ! t * G..<hp0 ! t * G + G])
+           (if previous hp1 t = t then \<psi>' else \<psi>))),
+         j3 + 6 := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1),
+         j3 + 3 := (\<lfloor>T - 1\<rfloor>\<^sub>N, 1)]"
+  assumes "ttt = 16114765 * 2 ^ (16*Z) * N^6"
+  shows "transforms (tm_chi j1 j2 j3) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_chi j1 j2 j3 .
+  show ?thesis
+    using loc.tm30'[OF assms(1-34)] loc.tps30_def[OF assms(1-34)] assms(35,36) loc.tm30_eq_tm_chi
+    by simp
+qed
+
+
+subsubsection \<open>A Turing machine for $\Phi_9$ proper\<close>
+
+text \<open>
+The formula $\Phi_9$ is a conjunction of formulas $\chi_t$. The TM @{const
+tm_chi} decreases the number on tape $j_3 + 3$. If this tape is initialized with
+$T'$, then a while loop with @{const tm_chi} as its body will generate $\Phi_9$.
+The next TM is such a machine:
+\<close>
+
+definition tm_PHI9 :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_PHI9 j1 j2 j3 \<equiv> WHILE [] ; \<lambda>rs. rs ! (j3 + 3) \<noteq> \<box> DO tm_chi j1 j2 j3 DONE"
+
+lemma tm_PHI9_tm:
+  assumes "0 < j1" and "j1 < j2" and "j2 < j3" and "j3 + 17 < k" and "G \<ge> 6"
+  shows "turing_machine k G (tm_PHI9 j1 j2 j3)"
+  unfolding tm_PHI9_def
+  using tm_chi_tm turing_machine_loop_turing_machine Nil_tm assms by simp
+
+lemma map_nth:
+  fixes zs ys f n i
+  assumes "zs = map f [0..<n]" and "i < length zs"
+  shows "zs ! i = f i"
+  using assms by simp
+
+lemma concat_formula_n:
+  "concat (map (\<lambda>t. formula_n (\<phi> t)) [0..<n]) = formula_n (concat (map (\<lambda>t. \<phi> t) [0..<n]))"
+  using formula_n_def by (induction n) simp_all
+
+lemma upt_append_upt:
+  assumes "a \<le> b" and "b \<le> c"
+  shows "[a..<b] @ [b..<c] = [a..<c]"
+proof (rule nth_equalityI)
+  show "length ([a..<b] @ [b..<c]) = length [a..<c]"
+    using assms by simp
+  show "([a..<b] @ [b..<c]) ! i = [a..<c] ! i" if "i < length ([a..<b] @ [b..<c])" for i
+    using assms that nth_append[of "[a..<b]" "[b..<c]" i] by (cases "i < b - a") simp_all
+qed
+
+text \<open>
+The semantics of the TM @{const tm_PHI9} can be proved inside the locale
+@{locale reduction_sat_x} because it is a fairly simple TM.
+\<close>
+
+context reduction_sat_x
+begin
+
+text \<open>
+The TM @{const tm_chi} is the first TM whose semantics we transfer into the
+locale @{locale reduction_sat_x}.
+\<close>
+
+lemma tm_chi:
+  fixes tps0 :: "tape list" and k t' t :: nat and j1 j2 j3 :: tapeidx
+  fixes nss :: "nat list list"
+  assumes jk: "length tps0 = k" "1 < j1" "j1 < j2" "j2 < j3" "j3 + 17 < k"
+    and t: "0 < t" "t \<le> T'"
+    and T: "0 < t'" "t' \<le> T'"
+  assumes "hp0 = map (\<lambda>t. exc (zeros m) t <#> 0) [0..<Suc T']"
+  assumes "hp1 = map (\<lambda>t. exc (zeros m) t <#> 1) [0..<Suc T']"
+  assumes tps0:
+     "tps0 ! 1 = nlltape nss"
+     "tps0 ! j1 = (\<lfloor>hp0\<rfloor>\<^sub>N\<^sub>L, 1)"
+     "tps0 ! j2 = (\<lfloor>hp1\<rfloor>\<^sub>N\<^sub>L, 1)"
+     "tps0 ! j3 = (\<lfloor>N\<rfloor>\<^sub>N, 1)"
+     "tps0 ! (j3 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+     "tps0 ! (j3 + 2) = (\<lfloor>Z\<rfloor>\<^sub>N, 1)"
+     "tps0 ! (j3 + 3) = (\<lfloor>t'\<rfloor>\<^sub>N, 1)"
+     "tps0 ! (j3 + 4) = (\<lfloor>formula_n \<psi>\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+     "tps0 ! (j3 + 5) = (\<lfloor>formula_n \<psi>'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+     "tps0 ! (j3 + 6) = (\<lfloor>t\<rfloor>\<^sub>N, 1)"
+     "\<And>i. 6 < i \<Longrightarrow> i < 17 \<Longrightarrow> tps0 ! (j3 + i) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "tps' = tps0
+      [1 := nlltape (nss @ formula_n (\<chi> t)),
+       j3 + 6 := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1),
+       j3 + 3 := (\<lfloor>t' - 1\<rfloor>\<^sub>N, 1)]"
+  assumes "ttt = 16114765 * 2^(16*Z) * N ^ 6"
+  shows "transforms (tm_chi j1 j2 j3) tps0 ttt tps'"
+proof -
+  interpret loc: turing_machine_chi j1 j2 j3 .
+
+  have G: "H \<ge> 3"
+    using H_gr_2 by simp
+  then have N: "N \<ge> 1"
+    using N_eq by simp
+  have Z: "Z = 3 * H"
+    using Z_def by simp
+  have len_hp0: "length hp0 = Suc T'"
+    using assms by simp
+  have len_hp1: "length hp1 = Suc T'"
+    using assms by simp
+  have hp0: "\<forall>i<length hp0. hp0 ! i \<le> T'"
+  proof standard+
+    fix i :: nat
+    assume "i < length hp0"
+    then have "hp0 ! i = exc (zeros m) i <#> 0"
+      using map_nth assms(10) by blast
+    then show "hp0 ! i \<le> T'"
+      using inputpos_less inputpos_def by simp
+  qed
+  have hp1: "\<forall>i<length hp1. hp1 ! i \<le> T'"
+  proof standard+
+    fix i :: nat
+    assume "i < length hp1"
+    then have "hp1 ! i = exc (zeros m) i <#> 1"
+      using map_nth assms(11) by blast
+    then show "hp1 ! i \<le> T'"
+      using headpos_1_less by simp
+  qed
+  have psi: "variables \<psi> \<subseteq> {..<3*Z+H}" "fsize \<psi> \<le> (3*Z+H) * 2 ^ (3*Z+H)" "length \<psi> \<le> 2 ^ (3*Z+H)"
+    using psi by simp_all
+  have psi': "variables \<psi>' \<subseteq> {..<2*Z+H}" "fsize \<psi>' \<le> (2*Z+H) * 2 ^ (2*Z+H)" "length \<psi>' \<le> 2 ^ (2*Z+H)"
+    using psi' by simp_all
+
+  let ?sigma = "[N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+    (if previous hp1 t \<noteq> t then [N + previous hp1 t * Z..<N + previous hp1 t * Z + Z] else []) @
+    [N + t * Z..<N + t * Z + Z] @
+    [hp0 ! t * H..<hp0 ! t * H + H]"
+
+  have hp0_nth: "hp0 ! i = exc (zeros m) i <#> 0" if "i \<le> T' " for i
+    using that assms map_nth len_hp0 by (metis (no_types, lifting) le_imp_less_Suc)
+  then have hp0_eq_inputpos: "hp0 ! i = inputpos m i" if "i \<le> T' " for i
+    using inputpos_def that by simp
+
+  have hp1_nth: "hp1 ! i = exc (zeros m) i <#> 1" if "i \<le> T' " for i
+    using that assms map_nth len_hp1 by (metis (no_types, lifting) le_imp_less_Suc)
+
+  have previous_eq_prev: "previous hp1 idx = prev m idx" if "idx \<le> T' " for idx
+  proof (cases "\<exists>i<idx. hp1 ! i = hp1 ! idx")
+    case True
+    then have 1: "\<exists>i<idx. exc (zeros m) i <#> 1 = exc (zeros m) idx <#> 1"
+      using that hp1_nth by auto
+    then have "prev m idx = (GREATEST i. i < idx \<and> exc (zeros m) i <#> 1 = exc (zeros m) idx <#> 1)"
+      using prev_def by simp
+    have "previous hp1 idx = (GREATEST i. i < idx \<and> hp1 ! i = hp1 ! idx)"
+      using True previous_def by simp
+    also have "... = (GREATEST i. i < idx \<and> exc (zeros m) i <#> 1 = exc (zeros m) idx <#> 1)"
+      (is "Greatest ?P = Greatest ?Q")
+    proof (rule Greatest_equality)
+      have "\<exists>i. ?Q i"
+        using 1 by simp
+      moreover have 2: "\<forall>y. ?Q y \<longrightarrow> y \<le> idx"
+        by simp
+      ultimately have 3: "?Q (Greatest ?Q)"
+        using GreatestI_ex_nat[of ?Q] by blast
+      then have 4: "Greatest ?Q < idx"
+        by simp
+      then have "Greatest ?Q \<le> T' "
+        using that by simp
+      then have "hp1 ! (Greatest ?Q) = exc (zeros m) (Greatest ?Q) <#> 1"
+        using hp1_nth by simp
+      moreover have "hp1 ! idx = exc (zeros m) idx <#> 1"
+        using that hp1_nth by simp
+      ultimately have "hp1 ! (Greatest ?Q) = hp1 ! idx"
+        using 3 by simp
+      then show "?P (Greatest ?Q)"
+        using 4 by simp
+      show "i \<le> Greatest ?Q" if "?P i" for i
+      proof -
+        have "i < idx"
+          using that by simp
+        then have "hp1 ! i = exc (zeros m) i <#> 1"
+          using `idx \<le> T' ` hp1_nth by simp
+        moreover have "hp1 ! idx = exc (zeros m) idx <#> 1"
+          using `idx \<le> T' ` hp1_nth by simp
+        ultimately have "exc (zeros m) i <#> 1 = exc (zeros m) idx <#> 1"
+          using that by simp
+        then have "?Q i"
+          using `i < idx` by simp
+        then show ?thesis
+          using Greatest_le_nat[of ?Q i] 2 by blast
+      qed
+    qed
+    also have "... = prev m idx"
+      using prev_def 1 by simp
+    finally show ?thesis .
+  next
+    case False
+    have "\<not> (\<exists>i<idx. exc (zeros m) i <#> 1 = exc (zeros m) idx <#> 1)"
+    proof (rule ccontr)
+      assume "\<not> (\<not> (\<exists>i<idx. exc (zeros m) i <#> 1 = exc (zeros m) idx <#> 1))"
+      then obtain i where "i < idx" "exc (zeros m) i <#> 1 = exc (zeros m) idx <#> 1"
+        by auto
+      then have "hp1 ! i = hp1 ! idx"
+        using hp1_nth that by simp
+      then show False
+        using False `i < idx` by simp
+    qed
+    then have "prev m idx = idx"
+      using prev_def by auto
+    moreover have "previous hp1 idx = idx"
+      using False assms previous_def by auto
+    ultimately show ?thesis
+      by simp
+  qed
+
+  have "\<zeta>\<^sub>0 i @ \<zeta>\<^sub>1 i @ \<zeta>\<^sub>2 i = [N + i * Z..<N + (Suc i) * Z]" for i
+    using zeta0_def zeta1_def zeta2_def upt_append_upt Z by simp
+  then have zeta012: "\<zeta>\<^sub>0 i @ \<zeta>\<^sub>1 i @ \<zeta>\<^sub>2 i = [N + i * Z..<N + i * Z + Z]" for i
+    by (simp add: ab_semigroup_add_class.add_ac(1) add.commute[of Z "i*Z"])
+  have gamma: "\<gamma> (inputpos m i) = [inputpos m i * H..<inputpos m i * H + H]" for i
+    using gamma_def by (simp add: add.commute)
+
+  have rho: "\<rho> t = ?sigma" if "prev m t < t"
+  proof -
+    have "previous hp1 t \<noteq> t"
+      using t that previous_eq_prev by simp
+    then have "?sigma = [N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+        [N + prev m t * Z..<N + prev m t * Z + Z] @
+        [N + t * Z..<N + t * Z + Z] @
+        [inputpos m t * H..<inputpos m t * H + H]"
+      using previous_eq_prev hp0_eq_inputpos t by simp
+    also have "... = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1)) @
+        (\<zeta>\<^sub>0 (prev m t) @ \<zeta>\<^sub>1 (prev m t) @ \<zeta>\<^sub>2 (prev m t)) @
+        (\<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t) @
+        \<gamma> (inputpos m t)"
+      using zeta012 gamma by simp
+    also have "... = \<rho> t"
+      using rho_def by simp
+    finally have "?sigma = \<rho> t" .
+    then show ?thesis
+      by simp
+  qed
+
+  have rho': "\<rho>' t = ?sigma" if "prev m t = t"
+  proof -
+    have "previous hp1 t = t"
+      using t that previous_eq_prev by simp
+    then have "?sigma = [N + (t - 1) * Z..<N + (t - 1) * Z + Z] @
+        [N + t * Z..<N + t * Z + Z] @
+        [inputpos m t * H..<inputpos m t * H + H]"
+      using previous_eq_prev hp0_eq_inputpos t by simp
+    also have "... = (\<zeta>\<^sub>0 (t - 1) @ \<zeta>\<^sub>1 (t - 1) @ \<zeta>\<^sub>2 (t - 1)) @
+        (\<zeta>\<^sub>0 t @ \<zeta>\<^sub>1 t @ \<zeta>\<^sub>2 t) @
+        \<gamma> (inputpos m t)"
+      using zeta012 gamma by simp
+    also have "... = \<rho>' t"
+      using rho'_def by simp
+    finally have "?sigma = \<rho>' t" .
+    then show ?thesis
+      by simp
+  qed
+
+  have "\<chi> t = relabel ?sigma (if previous hp1 t = t then \<psi>' else \<psi>)"
+  proof (cases "prev m t < t")
+    case True
+    then have "\<chi> t = relabel (\<rho> t) \<psi>"
+      using chi_def by simp
+    moreover have "previous hp1 t < t"
+      using t True previous_eq_prev by simp
+    ultimately show ?thesis
+      using rho True by simp
+  next
+    case False
+    then have *: "prev m t = t"
+      by (simp add: nat_less_le prev_le)
+    then have "\<chi> t = relabel (\<rho>' t) \<psi>'"
+      using chi_def by simp
+    moreover have "previous hp1 t = t"
+      using t * previous_eq_prev by simp
+    ultimately show ?thesis
+      using rho' * by simp
+  qed
+
+  then show "transforms (tm_chi j1 j2 j3) tps0 ttt tps'"
+    using transforms_tm_chi[OF jk G Z N len_hp0 hp0 len_hp1 hp1 t T T'_less psi psi' tps0 _ assms(24)] assms(23)
+    by simp
+qed
+
+lemma Z_sq_le: "Z^2 \<le> 2^(16*Z)"
+proof -
+  have "Z^2 \<le> 2^(2*Z)"
+    using pow2_le_2pow2[of Z] by simp
+  also have "... \<le> 2^(16*Z)"
+    by simp
+  finally show "Z^2 \<le> 2^(16*Z)" .
+qed
+
+lemma tm_PHI9 [transforms_intros]:
+  fixes tps0 tps' :: "tape list" and k :: nat and j1 j2 j3 :: tapeidx
+  fixes nss :: "nat list list"
+  assumes jk: "length tps0 = k" "1 < j1" "j1 < j2" "j2 < j3" "j3 + 17 < k"
+  assumes "hp0 = map (\<lambda>t. exc (zeros m) t <#> 0) [0..<Suc T']"
+  assumes "hp1 = map (\<lambda>t. exc (zeros m) t <#> 1) [0..<Suc T']"
+  assumes tps0:
+    "tps0 ! 1 = nlltape nss"
+    "tps0 ! j1 = (\<lfloor>hp0\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! j2 = (\<lfloor>hp1\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! j3 = (\<lfloor>N\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 1) = (\<lfloor>H\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 2) = (\<lfloor>Z\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 3) = (\<lfloor>T'\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 4) = (\<lfloor>formula_n psi\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps0 ! (j3 + 5) = (\<lfloor>formula_n psi'\<rfloor>\<^sub>N\<^sub>L\<^sub>L, 1)"
+    "tps0 ! (j3 + 6) = (\<lfloor>1\<rfloor>\<^sub>N, 1)"
+    "\<And>i. 6 < i \<Longrightarrow> i < 17 \<Longrightarrow> tps0 ! (j3 + i) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes tps': "tps' = tps0
+        [1 := nlltape (nss @ formula_n \<Phi>\<^sub>9),
+         j3 + 6 := (\<lfloor>Suc T'\<rfloor>\<^sub>N, 1),
+         j3 + 3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+  assumes "ttt = 16114767 * 2 ^ (16 * Z) * N ^ 7"
+  shows "transforms (tm_PHI9 j1 j2 j3) tps0 ttt tps'"
+proof -
+  define tps where "tps = (\<lambda>t. tps0
+        [1 := nlltape (nss @ concat (map (\<lambda>t. formula_n (\<chi> (Suc t))) [0..<t])),
+         j3 + 6 := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1),
+         j3 + 3 := (\<lfloor>T' - t\<rfloor>\<^sub>N, 1)])"
+  have "transforms (tm_PHI9 j1 j2 j3) (tps 0) ttt (tps T')"
+    unfolding tm_PHI9_def
+  proof (tform)
+    let ?ttt = "16114765 * 2^(16*Z) * N ^ 6"
+    show "transforms (tm_chi j1 j2 j3) (tps i) ?ttt (tps (Suc i))" if "i < T' " for i
+    proof (rule tm_chi ; (use assms tps_def that in simp ; fail)?)
+      show "tps (Suc i) = (tps i)
+          [1 := nlltape
+                ((nss @ concat (map (\<lambda>t. formula_n (\<chi> (Suc t))) [0..<i])) @
+                  formula_n (\<chi> (Suc i))),
+          j3 + 6 := (\<lfloor>Suc (Suc i)\<rfloor>\<^sub>N, 1),
+          j3 + 3 := (\<lfloor>T' - i - 1\<rfloor>\<^sub>N, 1)]"
+        using that tps_def by (simp add: list_update_swap)
+    qed
+    show "\<And>i. i < T' \<Longrightarrow> read (tps i) ! (j3 + 3) \<noteq> \<box>"
+      using jk tps_def read_ncontents_eq_0 by simp
+    show "\<not> read (tps T') ! (j3 + 3) \<noteq> \<box>"
+      using jk tps_def read_ncontents_eq_0 by simp
+    show "T' * (16114765 * 2 ^ (16 * Z) * N ^ 6 + 2) + 1 \<le> ttt"
+    proof -
+      have "T' * (16114765 * 2 ^ (16 * Z) * N ^ 6 + 2) + 1 \<le> T' * (16114767 * 2 ^ (16 * Z) * N ^ 6) + 1"
+        using Z_sq_le H_gr_2 N_eq by auto
+      also have "... \<le> T' * (16114767 * 2 ^ (16 * Z) * N ^ 6) + (16114767 * 2 ^ (16 * Z) * N ^ 6)"
+        using H_gr_2 N_eq by auto
+      also have "... = Suc T' * (16114767 * 2 ^ (16 * Z) * N ^ 6)"
+        by simp
+      also have "... \<le> N * (16114767 * 2 ^ (16 * Z) * N ^ 6)"
+        using T'_less Suc_leI mult_le_mono1 by presburger
+      also have "... = 16114767 * 2 ^ (16 * Z) * N ^ 7"
+        by algebra
+      also have "... = ttt"
+        using assms(20) by simp
+      finally show ?thesis .
+    qed
+  qed
+  moreover have "tps 0 = tps0"
+    using tps_def tps0 list_update_id[of tps0 "Suc 0"] list_update_id[of tps0 "j3 + 6"]
+      list_update_id[of tps0 "j3 + 3"]
+    by simp
+  moreover have "tps T' = tps'"
+  proof -
+    have "concat (map (\<lambda>t. formula_n (\<chi> (Suc t))) [0..<T']) =
+        formula_n (concat (map (\<lambda>t. \<chi> (Suc t)) [0..<T']))"
+      using concat_formula_n by simp
+    then show ?thesis
+      using PHI9_def tps_def tps' list_update_id[of tps0 "Suc 0"] list_update_id[of tps0 "j3 + 6"]
+        list_update_id[of tps0 "j3 + 3"]
+      by simp
+  qed
+  ultimately show "transforms (tm_PHI9 j1 j2 j3) tps0 ttt tps'"
+    by simp
+qed
+
+end  (* context reduction_sat_x *)
+
+end
diff --git a/thys/Cook_Levin/Satisfiability.thy b/thys/Cook_Levin/Satisfiability.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Satisfiability.thy
@@ -0,0 +1,3187 @@
+chapter \<open>Satisfiability\label{s:Sat}\<close>
+
+theory Satisfiability
+  imports Wellformed NP
+begin
+
+text \<open>
+This chapter introduces the language \SAT{} and shows that it is in $\NP$, which
+constitutes the easier part of the Cook-Levin theorem. The other part, the
+$\NP$-hardness of \SAT{}, is what all the following chapters are concerned with.
+
+We first introduce Boolean formulas in conjunctive normal form and the concept
+of satisfiability. Then we define a way to represent such formulas as bit
+strings, leading to the definition of the language \SAT{} as a set of strings
+(Section~\ref{s:sat-sat}).
+
+For the proof that \SAT{} is in $\NP$, we construct a Turing machine that, given
+a CNF formula and a string representing a variable assignment, outputs
+\textbf{1} iff. the assignment satisfies the formula. The TM will run in
+polynomial time, and there are always assignments polynomial (in fact, linear)
+in the length of the formula (Section~\ref{s:Sat-np}).
+\<close>
+
+
+section \<open>The language \SAT{}\label{s:sat-sat}\<close>
+
+text \<open>
+\SAT{} is the language of all strings representing satisfiable Boolean
+formulas in conjunctive normal form (CNF).  This section introduces a minimal
+version of Boolean formulas in conjunctive normal form, including the
+concepts of assignments and satisfiability.
+\<close>
+
+
+subsection \<open>CNF formulas and satisfiability\label{s:CNF}\<close>
+
+text \<open>
+Arora and Barak~\cite[p.~44]{ccama} define Boolean formulas in general as
+expressions over $\land$, $\lor$, $\lnot$, parentheses, and variables $v_1, v_2,
+\dots$ in the usual way. Boolean formulas in conjunctive normal form are defined as
+$\bigwedge_i\left(\bigvee_j v_{i_j}\right)$, where the $v_{i_j}$ are literals.
+This definition does not seem to allow for empty clauses. Also whether the
+``empty CNF formula'' exists is somewhat doubtful.  Nevertheless, our
+formalization allows for both empty clauses and the empty CNF formula, because
+this enables us to represent CNF formulas as lists of clauses and clauses as
+lists of literals without having to somehow forbid the empty list. This seems to
+be a popular approach for formalizing CNF formulas in the context of \SAT{} and
+$\NP$~\cite{Gher2021MechanisingCT,Multiset_Ordering_NPC-AFP}.
+
+We identify a variable $v_i$ with its index $i$, which can be any natural
+number. A \emph{literal} can either be positive or negative, representing a
+variable or negated variable, respectively.
+
+\null
+\<close>
+
+datatype literal = Neg nat | Pos nat
+
+type_synonym clause = "literal list"
+
+type_synonym formula = "clause list"
+
+text \<open>
+An \emph{assignment} maps all variables, given by their index, to a Boolean:
+\<close>
+
+type_synonym assignment = "nat \<Rightarrow> bool"
+
+abbreviation satisfies_literal :: "assignment \<Rightarrow> literal \<Rightarrow> bool" where
+  "satisfies_literal \<alpha> x \<equiv> case x of Neg n \<Rightarrow> \<not> \<alpha> n | Pos n \<Rightarrow> \<alpha> n"
+
+definition satisfies_clause :: "assignment \<Rightarrow> clause \<Rightarrow> bool" where
+  "satisfies_clause \<alpha> c \<equiv> \<exists>x\<in>set c. satisfies_literal \<alpha> x"
+
+definition satisfies :: "assignment \<Rightarrow> formula \<Rightarrow> bool" (infix "\<Turnstile>" 60) where
+  "\<alpha> \<Turnstile> \<phi> \<equiv> \<forall>c\<in>set \<phi>. satisfies_clause \<alpha> c"
+
+text \<open>
+As is customary, the empty clause is satisfied by no assignment, and the empty
+CNF formula is satisfied by every assignment.
+\<close>
+
+proposition "\<not> satisfies_clause \<alpha> []"
+  by (simp add: satisfies_clause_def)
+
+proposition "\<alpha> \<Turnstile> []"
+  by (simp add: satisfies_def)
+
+lemma satisfies_clause_take:
+  assumes "i < length clause"
+  shows "satisfies_clause \<alpha> (take (Suc i) clause) \<longleftrightarrow>
+    satisfies_clause \<alpha> (take i clause) \<or> satisfies_literal \<alpha> (clause ! i)"
+  using assms satisfies_clause_def by (auto simp add: take_Suc_conv_app_nth)
+
+lemma satisfies_take:
+  assumes "i < length \<phi>"
+  shows "\<alpha> \<Turnstile> take (Suc i) \<phi> \<longleftrightarrow> \<alpha> \<Turnstile> take i \<phi> \<and> satisfies_clause \<alpha> (\<phi> ! i)"
+  using assms satisfies_def by (auto simp add: take_Suc_conv_app_nth)
+
+lemma satisfies_append:
+  assumes "\<alpha> \<Turnstile> \<phi>\<^sub>1 @ \<phi>\<^sub>2"
+  shows "\<alpha> \<Turnstile> \<phi>\<^sub>1" and "\<alpha> \<Turnstile> \<phi>\<^sub>2"
+  using assms satisfies_def by simp_all
+
+lemma satisfies_append':
+  assumes "\<alpha> \<Turnstile> \<phi>\<^sub>1" and "\<alpha> \<Turnstile> \<phi>\<^sub>2"
+  shows "\<alpha> \<Turnstile> \<phi>\<^sub>1 @ \<phi>\<^sub>2"
+  using assms satisfies_def by auto
+
+lemma satisfies_concat_map:
+  assumes "\<alpha> \<Turnstile> concat (map f [0..<k])" and "i < k"
+  shows "\<alpha> \<Turnstile> f i"
+  using assms satisfies_def by simp
+
+lemma satisfies_concat_map':
+  assumes "\<And>i. i < k \<Longrightarrow> \<alpha> \<Turnstile> f i"
+  shows "\<alpha> \<Turnstile> concat (map f [0..<k])"
+  using assms satisfies_def by simp
+
+text \<open>
+The main ingredient for defining \SAT{} is the concept of \emph{satisfiable} CNF
+formula:
+\<close>
+
+definition satisfiable :: "formula \<Rightarrow> bool" where
+  "satisfiable \<phi> \<equiv> \<exists>\<alpha>. \<alpha> \<Turnstile> \<phi>"
+
+text \<open>
+The set of all variables used in a CNF formula is finite.
+\<close>
+
+definition variables :: "formula \<Rightarrow> nat set" where
+  "variables \<phi> \<equiv> {n. \<exists>c\<in>set \<phi>. Neg n \<in> set c \<or> Pos n \<in> set c}"
+
+lemma finite_variables: "finite (variables \<phi>)"
+proof -
+  define voc :: "clause \<Rightarrow> nat set" where
+    "voc c = {n. Neg n \<in> set c \<or> Pos n \<in> set c}" for c
+  let ?vocs = "set (map voc \<phi>)"
+
+  have "finite (voc c)" for c
+  proof (induction c)
+    case Nil
+    then show ?case
+      using voc_def by simp
+  next
+    case (Cons a c)
+    have "voc (a # c) = {n. Neg n \<in> set (a # c) \<or> Pos n \<in> set (a # c)}"
+      using voc_def by simp
+    also have "... = {n. Neg n \<in> set c \<or> Neg n = a \<or> Pos n \<in> set c \<or> Pos n = a}"
+      by auto
+    also have "... = {n. (Neg n \<in> set c \<or> Pos n \<in> set c) \<or> (Pos n = a \<or> Neg n = a)}"
+      by auto
+    also have "... = {n. Neg n \<in> set c \<or> Pos n \<in> set c} \<union> {n. Pos n = a \<or> Neg n = a}"
+      by auto
+    also have "... = voc c \<union> {n. Pos n = a \<or> Neg n = a}"
+      using voc_def by simp
+    finally have "voc (a # c) = voc c \<union> {n. Pos n = a \<or> Neg n = a}" .
+    moreover have "finite {n. Pos n = a \<or> Neg n = a}"
+      using finite_nat_set_iff_bounded by auto
+    ultimately show ?case
+      using Cons by simp
+  qed
+  moreover have "variables \<phi> = \<Union>?vocs"
+    using variables_def voc_def by auto
+  moreover have "finite ?vocs"
+    by simp
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma variables_append: "variables (\<phi>\<^sub>1 @ \<phi>\<^sub>2) = variables \<phi>\<^sub>1 \<union> variables \<phi>\<^sub>2"
+  using variables_def by auto
+
+text \<open>
+Arora and Barak~\cite[Claim~2.13]{ccama} define the \emph{size} of a CNF formula
+as the numbr of $\wedge / \vee$ symbols. We use a slightly different definition,
+namely the number of literals:
+\<close>
+
+definition fsize :: "formula \<Rightarrow> nat" where
+  "fsize \<phi> \<equiv> sum_list (map length \<phi>)"
+
+
+subsection \<open>Predicates on assignments\<close>
+
+text \<open>
+Every CNF formula is satisfied by a set of assignments. Conversely, for certain
+sets of assignments we can construct CNF formulas satisfied by exactly these
+assignments.  This will be helpful later when we construct formulas for reducing
+arbitrary languages to \SAT{} (see Section~\ref{s:Reducing}).
+\<close>
+
+
+subsubsection \<open>Universality of CNF formulas\<close>
+
+text \<open>
+A set (represented by a predicate) $F$ of assignments depends on the first
+$\ell$ variables iff.\ any two assignments that agree on the first $\ell$
+variables are either both in the set or both outside of the set.
+\<close>
+
+definition depon :: "nat \<Rightarrow> (assignment \<Rightarrow> bool) \<Rightarrow> bool" where
+  "depon l F \<equiv> \<forall>\<alpha>\<^sub>1 \<alpha>\<^sub>2. (\<forall>i<l. \<alpha>\<^sub>1 i = \<alpha>\<^sub>2 i) \<longrightarrow> F \<alpha>\<^sub>1 = F \<alpha>\<^sub>2"
+
+text \<open>
+Lists of all strings of the same length:
+\<close>
+
+fun str_of_len :: "nat \<Rightarrow> string list" where
+  "str_of_len 0 = [[]]" |
+  "str_of_len (Suc l) = map ((#) \<bbbO>) (str_of_len l) @ map ((#) \<bbbI>) (str_of_len l)"
+
+lemma length_str_of_len: "length (str_of_len l) = 2 ^ l"
+  by (induction l) simp_all
+
+lemma in_str_of_len_length: "xs \<in> set (str_of_len l) \<Longrightarrow> length xs = l"
+  by (induction l arbitrary: xs) auto
+
+lemma length_in_str_of_len: "length xs = l \<Longrightarrow> xs \<in> set (str_of_len l)"
+proof (induction l arbitrary: xs)
+  case 0
+  then show ?case
+    by simp
+next
+  case (Suc l)
+  then obtain y ys where "xs = y # ys"
+    by (meson length_Suc_conv)
+  then have "length ys = l"
+    using Suc by simp
+  show ?case
+  proof (cases y)
+    case True
+    then have "xs \<in> set (map ((#) \<bbbI>) (str_of_len l))"
+      using `length ys = l` Suc `xs = y # ys` by simp
+    then show ?thesis
+      by simp
+  next
+    case False
+    then have "xs \<in> set (map ((#) \<bbbO>) (str_of_len l))"
+      using `length ys = l` Suc `xs = y # ys` by simp
+    then show ?thesis
+      by simp
+  qed
+qed
+
+text \<open>
+A predicate $F$ depending on the first $\ell$ variables $v_0, \dots, v_{\ell-1}$
+can be regarded as a truth table over $\ell$ variables. The next lemma shows
+that for every such truth table there exists a CNF formula with at most $2^\ell$
+clauses and $\ell\cdot2^\ell$ literals over the first $\ell$ variables. This is
+the well-known fact that every Boolean function (over $\ell$ variables) can be
+represented by a CNF formula~\cite[Claim~2.13]{ccama}.
+\<close>
+
+lemma depon_ex_formula:
+  assumes "depon l F"
+  shows "\<exists>\<phi>.
+    fsize \<phi> \<le> l * 2 ^ l \<and>
+    length \<phi> \<le> 2 ^ l \<and>
+    variables \<phi> \<subseteq> {..<l} \<and>
+    (\<forall>\<alpha>. F \<alpha> = \<alpha> \<Turnstile> \<phi>)"
+proof -
+  define cl where "cl = (\<lambda>v. map (\<lambda>i. if v ! i then Neg i else Pos i) [0..<l])"
+  have cl1: "satisfies_clause a (cl v)" if "length v = l" and "v \<noteq> map a [0..<l]" for v a
+  proof -
+    obtain i where i: "i < l" "a i \<noteq> v ! i"
+      using \<open>length v = l\<close> \<open>v \<noteq> map a [0..<l]\<close>
+      by (smt (verit, best) atLeastLessThan_iff map_eq_conv map_nth set_upt)
+    then have *: "cl v ! i = (if v ! i then Neg i else Pos i)"
+      using cl_def by simp
+    then have "case (cl v ! i) of Neg n \<Rightarrow> \<not> a n | Pos n \<Rightarrow> a n"
+      using i(2) by simp
+    then show ?thesis
+      using cl_def * that(1) satisfies_clause_def i(1) by fastforce
+  qed
+  have cl2: "v \<noteq> map a [0..<l]" if "length v = l" and "satisfies_clause a (cl v)" for v a
+  proof
+    assume assm: "v = map a [0..<l]"
+    from that(2) have "\<exists>x\<in>set (cl v). case x of Neg n \<Rightarrow> \<not> a n | Pos n \<Rightarrow> a n"
+      using satisfies_clause_def by simp
+    then obtain i where i: "i < l" and "case (cl v ! i) of Neg n \<Rightarrow> \<not> a n | Pos n \<Rightarrow> a n"
+      using cl_def by auto
+    then have "v ! i \<noteq> a i"
+      using cl_def by fastforce
+    then show False
+      using i assm by simp
+  qed
+
+  have filter_length_nth: "f (vs ! j)" if "vs = filter f sol" and "j < length vs"
+    for vs sol :: "'a list" and f j
+    using that nth_mem by (metis length_removeAll_less less_irrefl removeAll_filter_not)
+
+  have sum_list_map: "sum_list (map g xs) \<le> k * length xs" if "\<And>x. x \<in> set xs \<Longrightarrow> g x = k"
+    for xs :: "'a list" and g k
+    using that
+  proof (induction "length xs" arbitrary: xs)
+    case 0
+    then show ?case
+      by simp
+  next
+    case (Suc x)
+    then obtain y ys where "xs = y # ys"
+      by (metis length_Suc_conv)
+    then have "length ys = x"
+      using Suc by simp
+    have "y \<in> set xs"
+      using `xs = y # ys` by simp
+    have "sum_list (map g xs) = sum_list (map g (y # ys))"
+      using `xs = y # ys` by simp
+    also have "... = g y + sum_list (map g ys)"
+      by simp
+    also have "... = k + sum_list (map g ys)"
+      using Suc `y \<in> set xs` by simp
+    also have "... \<le> k + k * length ys"
+      using Suc `length ys = x` \<open>xs = y # ys\<close> by auto
+    also have "... = k * length xs"
+      by (metis Suc.hyps(2) \<open>length ys = x\<close> mult_Suc_right)
+    finally show ?case
+      by simp
+  qed
+
+  define vs where
+    "vs = filter (\<lambda>v. F (\<lambda>i. if i < l then v ! i else False) = False) (str_of_len l)"
+  define \<phi> where "\<phi> = map cl vs"
+
+  have "a \<Turnstile> \<phi>" if "F a" for a
+  proof -
+    define v where "v = map a [0..<l]"
+    then have "(\<lambda>i. if i < l then v ! i else False) j = a j" if "j < l" for j
+      by (simp add: that)
+    then have *: "F (\<lambda>i. if i < l then v ! i else False)"
+      using assms(1) depon_def that by (smt (verit, ccfv_SIG))
+    have "satisfies_clause a c" if "c \<in> set \<phi>" for c
+    proof -
+      obtain j where j: "c = \<phi> ! j" "j < length \<phi>"
+        using \<phi>_def `c \<in> set \<phi>` by (metis in_set_conv_nth)
+      then have "c = cl (vs ! j)"
+        using \<phi>_def by simp
+      have "j < length vs"
+        using \<phi>_def j by simp
+      then have "F (\<lambda>i. if i < l then (vs ! j) ! i else False) = False"
+        using vs_def filter_length_nth by blast
+      then have "vs ! j \<noteq> v"
+        using * by auto
+      moreover have "length (vs ! j) = l"
+        using vs_def length_str_of_len \<open>j < length vs\<close>
+        by (smt (z3) filter_eq_nths in_str_of_len_length notin_set_nthsI nth_mem)
+      ultimately have "satisfies_clause a (cl (vs ! j))"
+        using v_def cl1 by simp
+      then show ?thesis
+        using `c = cl (vs ! j)` by simp
+    qed
+    then show ?thesis
+      using satisfies_def by simp
+  qed
+  moreover have "F \<alpha>" if "\<alpha> \<Turnstile> \<phi>" for \<alpha>
+  proof (rule ccontr)
+    assume assm: "\<not> F \<alpha>"
+    define v where "v = map \<alpha> [0..<l]"
+    have *: "F (\<lambda>i. if i < l then v ! i else False) = False"
+    proof -
+      have "(\<lambda>i. if i < l then v ! i else False) j = \<alpha> j" if "j < l" for j
+        using v_def by (simp add: that)
+      then show ?thesis
+        using assm assms(1) depon_def by (smt (verit, best))
+    qed
+    have "length v = l"
+      using v_def by simp
+    then obtain j where "j < length (str_of_len l)" and "v = str_of_len l ! j"
+      by (metis in_set_conv_nth length_in_str_of_len)
+    then have "v \<in> set vs"
+      using vs_def * by fastforce
+    then have "cl v \<in> set \<phi>"
+      using \<phi>_def by simp
+    then have "satisfies_clause \<alpha> (cl v)"
+      using that satisfies_def by simp
+    then have "v \<noteq> map \<alpha> [0..<l]"
+      using `length v = l` cl2 by simp
+    then show False
+      using v_def by simp
+  qed
+  ultimately have "\<forall>\<alpha>. F \<alpha> = \<alpha> \<Turnstile> \<phi>"
+    by auto
+  moreover have "fsize \<phi> \<le> l * 2 ^ l"
+  proof -
+    have "length c = l" if "c \<in> set \<phi>" for c
+      using that cl_def \<phi>_def by auto
+    then have "fsize \<phi> \<le> l * length \<phi>"
+      unfolding fsize_def using sum_list_map by auto
+    also have "... \<le> l * length (str_of_len l)"
+      using \<phi>_def vs_def by simp
+    also have "... = l * 2 ^ l"
+      using length_str_of_len by simp
+    finally show ?thesis .
+  qed
+  moreover have "length \<phi> \<le> 2 ^ l"
+  proof -
+    have "length \<phi> \<le> length (str_of_len l)"
+      using \<phi>_def vs_def by simp
+    also have "... = 2 ^ l"
+      using length_str_of_len by simp
+    finally show ?thesis .
+  qed
+  moreover have "variables \<phi> \<subseteq> {..<l}"
+  proof
+    fix x assume "x \<in> variables \<phi>"
+    then obtain c where c: "c \<in> set \<phi>" "Neg x \<in> set c \<or> Pos x \<in> set c"
+      using variables_def by auto
+    then obtain v where v: "v \<in> set (str_of_len l)" "c = cl v"
+      using \<phi>_def vs_def by auto
+    then show "x \<in> {..<l}"
+      using cl_def c by auto
+  qed
+  ultimately show ?thesis
+    by auto
+qed
+
+
+subsubsection \<open>Substitutions of variables\<close>
+
+text \<open>
+We will sometimes consider CNF formulas over the first $\ell$ variables and
+derive other CNF formulas from them by substituting these variables.  Such a
+substitution will be represented by a list $\sigma$ of length at least $\ell$,
+meaning that the variable $v_i$ is replaced by $v_{\sigma(i)}$. We will call
+this operation on formulas \emph{relabel}, and the corresponding one on literals
+\emph{rename}:
+\<close>
+
+fun rename :: "nat list \<Rightarrow> literal \<Rightarrow> literal" where
+  "rename \<sigma> (Neg i) = Neg (\<sigma> ! i)" |
+  "rename \<sigma> (Pos i) = Pos (\<sigma> ! i)"
+
+definition relabel :: "nat list \<Rightarrow> formula \<Rightarrow> formula" where
+  "relabel \<sigma> \<phi> \<equiv> map (map (rename \<sigma>)) \<phi>"
+
+lemma fsize_relabel: "fsize (relabel \<sigma> \<phi>) = fsize \<phi>"
+  using relabel_def fsize_def by (metis length_concat length_map map_concat)
+
+text \<open>
+A substitution $\sigma$ can also be applied to an assignment and to a list of
+variable indices:
+\<close>
+
+definition remap :: "nat list \<Rightarrow> assignment \<Rightarrow> assignment" where
+  "remap \<sigma> \<alpha> i \<equiv> if i < length \<sigma> then \<alpha> (\<sigma> ! i) else \<alpha> i"
+
+definition reseq :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
+  "reseq \<sigma> vs \<equiv> map ((!) \<sigma>) vs"
+
+lemma length_reseq [simp]: "length (reseq \<sigma> vs) = length vs"
+  using reseq_def by simp
+
+text \<open>
+Relabeling a formula and remapping an assignment are equivalent in a sense.
+\<close>
+
+lemma satisfies_sigma:
+  assumes "variables \<phi> \<subseteq> {..<length \<sigma>}"
+  shows "\<alpha> \<Turnstile> relabel \<sigma> \<phi> \<longleftrightarrow> remap \<sigma> \<alpha> \<Turnstile> \<phi>"
+proof
+  assume sat: "\<alpha> \<Turnstile> relabel \<sigma> \<phi>"
+  have "satisfies_clause (remap \<sigma> \<alpha>) c" if "c \<in> set \<phi>" for c
+  proof -
+    obtain i where "i < length \<phi>" "\<phi> ! i = c"
+      by (meson \<open>c \<in> set \<phi>\<close> in_set_conv_nth)
+    then have "satisfies_clause \<alpha> (map (rename \<sigma>) c)"
+        (is "satisfies_clause \<alpha> ?c")
+      using sat satisfies_def relabel_def by auto
+    then obtain x where "x\<in>set ?c" "case x of Neg n \<Rightarrow> \<not> \<alpha> n | Pos n \<Rightarrow> \<alpha> n"
+      using satisfies_clause_def by auto
+    then obtain j where j: "j < length ?c" "case (?c ! j) of Neg n \<Rightarrow> \<not> \<alpha> n | Pos n \<Rightarrow> \<alpha> n"
+      by (metis in_set_conv_nth)
+    have "case c ! j of Neg n \<Rightarrow> \<not> (remap \<sigma> \<alpha>) n | Pos n \<Rightarrow> (remap \<sigma> \<alpha>) n"
+    proof (cases "c ! j")
+      case (Neg n)
+      then have 1: "?c ! j = Neg (\<sigma> ! n)"
+        using j(1) by simp
+      have "n \<in> variables \<phi>"
+        using Neg j(1) nth_mem that variables_def by force
+      then have "n < length \<sigma>"
+        using assms by auto
+      then show ?thesis
+        using Neg 1 j(2) remap_def by auto
+    next
+      case (Pos n)
+      then have 1: "?c ! j = Pos (\<sigma> ! n)"
+        using j(1) by simp
+      have "n \<in> variables \<phi>"
+        using Pos j(1) nth_mem that variables_def by force
+      then have "n < length \<sigma>"
+        using assms by auto
+      then show ?thesis
+        using Pos 1 j(2) remap_def by auto
+    qed
+    then show ?thesis
+      using satisfies_clause_def j by auto
+  qed
+  then show "remap \<sigma> \<alpha> \<Turnstile> \<phi>"
+    using satisfies_def by simp
+next
+  assume sat: "remap \<sigma> \<alpha> \<Turnstile> \<phi>"
+  have "satisfies_clause \<alpha> c" if "c \<in> set (relabel \<sigma> \<phi>)" for c
+  proof -
+    let ?phi = "relabel \<sigma> \<phi>"
+    let ?beta = "remap \<sigma> \<alpha>"
+    obtain i where i: "i < length ?phi" "?phi ! i = c"
+      by (meson \<open>c \<in> set ?phi\<close> in_set_conv_nth)
+    then have "satisfies_clause ?beta (\<phi> ! i)"
+        (is "satisfies_clause _ ?c")
+      using sat satisfies_def relabel_def by simp
+    then obtain x where "x\<in>set ?c" "case x of Neg n \<Rightarrow> \<not> ?beta n | Pos n \<Rightarrow> ?beta n"
+      using satisfies_clause_def by auto
+    then obtain j where j: "j < length ?c" "case (?c ! j) of Neg n \<Rightarrow> \<not> ?beta n | Pos n \<Rightarrow> ?beta n"
+      by (metis in_set_conv_nth)
+    then have ren: "c ! j = rename \<sigma> (?c ! j)"
+      using i relabel_def by auto
+    have "case c ! j of Neg n \<Rightarrow> \<not> \<alpha> n | Pos n \<Rightarrow> \<alpha> n"
+    proof (cases "?c ! j")
+      case (Neg n)
+      then have *: "c ! j = Neg (\<sigma> ! n)"
+        by (simp add: ren)
+      have "n \<in> variables \<phi>"
+        using Neg i j variables_def that length_map mem_Collect_eq nth_mem relabel_def by force
+      then have "n < length \<sigma>"
+        using assms by auto
+      moreover have "\<not> (remap \<sigma> \<alpha>) n"
+        using j(2) Neg by simp
+      ultimately have "\<not> \<alpha> (\<sigma> ! n)"
+        using remap_def by simp
+      then show ?thesis
+        by (simp add: *)
+    next
+      case (Pos n)
+      then have *: "c ! j = Pos (\<sigma> ! n)"
+        by (simp add: ren)
+      have "n \<in> variables \<phi>"
+        using Pos i j variables_def that length_map mem_Collect_eq nth_mem relabel_def by force
+      then have "n < length \<sigma>"
+        using assms by auto
+      moreover have "(remap \<sigma> \<alpha>) n"
+        using j(2) Pos by simp
+      ultimately have "\<alpha> (\<sigma> ! n)"
+        using remap_def by simp
+      then show ?thesis
+        by (simp add: *)
+    qed
+    moreover have "length c = length (\<phi> ! i)"
+      using relabel_def i by auto
+    ultimately show ?thesis
+      using satisfies_clause_def j by auto
+  qed
+  then show "\<alpha> \<Turnstile> relabel \<sigma> \<phi>"
+    by (simp add: satisfies_def)
+qed
+
+
+subsection \<open>Representing CNF formulas as strings\label{s:sat-sat-repr}\<close>
+
+text \<open>
+By identifying negated literals with even numbers and positive literals with odd
+numbers, we can identify literals with natural numbers. This yields a
+straightforward representation of a clause as a list of numbers and of a CNF
+formula as a list of lists of numbers. Such a list can, in turn, be represented
+as a symbol sequence over a quaternary alphabet as described in
+Section~\ref{s:tm-numlistlist}, which ultimately can be encoded over a binary
+alphabet (see Section~\ref{s:tm-quaternary}). This is essentially how we
+represent CNF formulas as strings.
+
+We have to introduce a bunch of functions for mapping between these
+representations.
+
+\null
+\<close>
+
+fun literal_n :: "literal \<Rightarrow> nat" where
+  "literal_n (Neg i) = 2 * i" |
+  "literal_n (Pos i) = Suc (2 * i)"
+
+definition n_literal :: "nat \<Rightarrow> literal" where
+  "n_literal n \<equiv> if even n then Neg (n div 2) else Pos (n div 2)"
+
+lemma n_literal_n: "n_literal (literal_n x) = x"
+  using n_literal_def by (cases x) simp_all
+
+lemma literal_n_literal: "literal_n (n_literal n) = n"
+  using n_literal_def by simp
+
+definition clause_n :: "clause \<Rightarrow> nat list" where
+  "clause_n cl \<equiv> map literal_n cl"
+
+definition n_clause :: "nat list \<Rightarrow> clause" where
+  "n_clause ns \<equiv> map n_literal ns"
+
+lemma n_clause_n: "n_clause (clause_n cl) = cl"
+  using n_clause_def clause_n_def n_literal_n by (simp add: map_idI)
+
+lemma clause_n_clause: "clause_n (n_clause n) = n"
+  using n_clause_def clause_n_def literal_n_literal by (simp add: map_idI)
+
+definition formula_n :: "formula \<Rightarrow> nat list list" where
+  "formula_n \<phi> \<equiv> map clause_n \<phi>"
+
+definition n_formula :: "nat list list \<Rightarrow> formula" where
+  "n_formula nss \<equiv> map n_clause nss"
+
+lemma n_formula_n: "n_formula (formula_n \<phi>) = \<phi>"
+  using n_formula_def formula_n_def n_clause_n by (simp add: map_idI)
+
+lemma formula_n_formula: "formula_n (n_formula nss) = nss"
+  using n_formula_def formula_n_def clause_n_clause by (simp add: map_idI)
+
+definition formula_zs :: "formula \<Rightarrow> symbol list" where
+  "formula_zs \<phi> \<equiv> numlistlist (formula_n \<phi>)"
+
+text \<open>
+The mapping between formulas and well-formed symbol sequences for
+lists of lists of numbers is bijective.
+\<close>
+
+lemma formula_n_inj: "formula_n \<phi>\<^sub>1 = formula_n \<phi>\<^sub>2 \<Longrightarrow> \<phi>\<^sub>1 = \<phi>\<^sub>2"
+  using n_formula_n by metis
+
+definition zs_formula :: "symbol list \<Rightarrow> formula" where
+  "zs_formula zs \<equiv> THE \<phi>. formula_zs \<phi> = zs"
+
+lemma zs_formula:
+  assumes "numlistlist_wf zs"
+  shows "\<exists>!\<phi>. formula_zs \<phi> = zs"
+proof -
+  obtain nss where nss: "numlistlist nss = zs"
+    using assms numlistlist_wf_def by auto
+  let ?phi = "n_formula nss"
+  have *: "formula_n ?phi = nss"
+    using nss formula_n_formula by simp
+  then have "formula_zs ?phi = zs"
+    using nss formula_zs_def by simp
+  then have "\<exists>\<phi>. formula_zs \<phi> = zs"
+    by auto
+  moreover have "\<phi> = ?phi" if "formula_zs \<phi> = zs" for \<phi>
+  proof -
+    have "numlistlist (formula_n \<phi>) = zs"
+      using that formula_zs_def by simp
+    then have "nss = formula_n \<phi>"
+      using nss numlistlist_inj by simp
+    then show ?thesis
+      using formula_n_inj * by simp
+  qed
+  ultimately show ?thesis
+    by auto
+qed
+
+lemma zs_formula_zs: "zs_formula (formula_zs \<phi>) = \<phi>"
+  by (simp add: formula_n_inj formula_zs_def numlistlist_inj the_equality zs_formula_def)
+
+lemma formula_zs_formula:
+  assumes "numlistlist_wf zs"
+  shows "formula_zs (zs_formula zs) = zs"
+  using assms zs_formula zs_formula_zs by metis
+
+text \<open>
+There will of course be Turing machines that perform computations on formulas.
+In order to bound their running time, we need bounds for the length of the
+symbol representation of formulas.
+\<close>
+
+lemma nlength_literal_n_Pos: "nlength (literal_n (Pos n)) \<le> Suc (nlength n)"
+  using nlength_times2plus1 by simp
+
+lemma nlength_literal_n_Neg: "nlength (literal_n (Neg n)) \<le> Suc (nlength n)"
+  using nlength_times2 by simp
+
+lemma nlllength_formula_n:
+  fixes V :: nat and \<phi> :: formula
+  assumes "\<And>v. v \<in> variables \<phi> \<Longrightarrow> v \<le> V"
+  shows "nlllength (formula_n \<phi>) \<le> fsize \<phi> * Suc (Suc (nlength V)) + length \<phi>"
+  using assms
+proof (induction \<phi>)
+  case Nil
+  then show ?case
+    using formula_n_def by simp
+next
+  case (Cons cl \<phi>)
+  then have 0: "\<And>v. v \<in> variables \<phi> \<Longrightarrow> v \<le> V"
+    using variables_def by simp
+  have 1: "n \<le> V" if "Pos n \<in> set cl" for n
+    using that variables_def by (simp add: Cons.prems)
+  have 2: "n \<le> V" if "Neg n \<in> set cl" for n
+    using that variables_def by (simp add: Cons.prems)
+  have 3: "nlength (literal_n v) \<le> Suc (nlength V)" if "v \<in> set cl" for v
+  proof (cases v)
+    case (Neg n)
+    then have "nlength (literal_n v) \<le> Suc (nlength n)"
+      using nlength_literal_n_Neg by blast
+    moreover have "n \<le> V"
+      using Neg that 2 by simp
+    ultimately show ?thesis
+      using nlength_mono by fastforce
+  next
+    case (Pos n)
+    then have "nlength (literal_n v) \<le> Suc (nlength n)"
+      using nlength_literal_n_Pos by blast
+    moreover have "n \<le> V"
+      using Pos that 1 by simp
+    ultimately show ?thesis
+      using nlength_mono by fastforce
+  qed
+
+  have "nllength (clause_n cl) = length (numlist (map literal_n cl))"
+    using clause_n_def nllength_def by simp
+  have "nllength (clause_n cl) = (\<Sum>n\<leftarrow>(map literal_n cl). Suc (nlength n))"
+    using clause_n_def nllength by simp
+  also have "... = (\<Sum>v\<leftarrow>cl. Suc (nlength (literal_n v)))"
+  proof -
+    have "map (\<lambda>n. Suc (nlength n)) (map literal_n cl) = map (\<lambda>v. Suc (nlength (literal_n v))) cl"
+      by simp
+    then show ?thesis
+      by metis
+  qed
+  also have "... \<le> (\<Sum>v\<leftarrow>cl. Suc (Suc (nlength V)))"
+    using sum_list_mono[of cl "\<lambda>v. Suc (nlength (literal_n v))" "\<lambda>v. Suc (Suc (nlength V))"] 3
+    by simp
+  also have "... = Suc (Suc (nlength V)) * length cl"
+    using sum_list_const by blast
+  finally have 4: "nllength (clause_n cl) \<le> Suc (Suc (nlength V)) * length cl" .
+
+  have "concat (map (\<lambda>ns. numlist ns @ [5]) (map clause_n (cl # \<phi>))) =
+      (numlist (clause_n cl) @ [5]) @ concat (map (\<lambda>ns. numlist ns @ [5]) (map clause_n \<phi>))"
+    by simp
+  then have "length (concat (map (\<lambda>ns. numlist ns @ [5]) (map clause_n (cl # \<phi>)))) =
+      length ((numlist (clause_n cl) @ [5]) @ concat (map (\<lambda>ns. numlist ns @ [5]) (map clause_n \<phi>)))"
+    by simp
+  then have "nlllength (formula_n (cl # \<phi>)) =
+      length ((numlist (clause_n cl) @ [5]) @ concat (map (\<lambda>ns. numlist ns @ [5]) (map clause_n \<phi>)))"
+    using formula_n_def numlistlist_def nlllength_def by simp
+  also have "... = length (numlist (clause_n cl) @ [5]) + length (concat (map (\<lambda>ns. numlist ns @ [5]) (map clause_n \<phi>)))"
+      by simp
+  also have "... = length (numlist (clause_n cl) @ [5]) + nlllength (formula_n \<phi>)"
+    using formula_n_def numlistlist_def nlllength_def by simp
+  also have "... = Suc (nllength (clause_n cl)) + nlllength (formula_n \<phi>)"
+    using nllength_def by simp
+  also have "... \<le> Suc (Suc (Suc (nlength V)) * length cl) + nlllength (formula_n \<phi>)"
+    using 4 by simp
+  also have "... \<le> Suc (Suc (Suc (nlength V)) * length cl) + fsize \<phi> * Suc (Suc (nlength V)) + length \<phi>"
+    using Cons 0 by simp
+  also have "... = fsize (cl # \<phi>) * Suc (Suc (nlength V)) + length (cl # \<phi>)"
+    by (simp add: add_mult_distrib2 mult.commute fsize_def)
+  finally show ?case
+    by simp
+qed
+
+text \<open>
+Since \SAT{} is supposed to be a set of strings rather than symbol
+sequences, we need to map symbol sequences representing formulas to strings:
+\<close>
+
+abbreviation formula_to_string :: "formula \<Rightarrow> string" where
+  "formula_to_string \<phi> \<equiv> symbols_to_string (binencode (numlistlist (formula_n \<phi>)))"
+
+lemma formula_to_string_inj:
+  assumes "formula_to_string \<phi>\<^sub>1 = formula_to_string \<phi>\<^sub>2"
+  shows "\<phi>\<^sub>1 = \<phi>\<^sub>2"
+proof -
+  let ?xs1 = "binencode (numlistlist (formula_n \<phi>\<^sub>1))"
+  let ?xs2 = "binencode (numlistlist (formula_n \<phi>\<^sub>2))"
+  have bin1: "binencodable (numlistlist (formula_n \<phi>\<^sub>1))"
+    by (simp add: Suc_le_eq numeral_2_eq_2 proper_symbols_numlistlist symbols_lt_numlistlist)
+  then have "bit_symbols ?xs1"
+    using bit_symbols_binencode by simp
+  then have 1: "string_to_symbols (symbols_to_string ?xs1) = ?xs1"
+    using bit_symbols_to_symbols by simp
+
+  have bin2: "binencodable (numlistlist (formula_n \<phi>\<^sub>2))"
+    by (simp add: Suc_le_eq numeral_2_eq_2 proper_symbols_numlistlist symbols_lt_numlistlist)
+  then have "bit_symbols ?xs2"
+    using bit_symbols_binencode by simp
+  then have "string_to_symbols (symbols_to_string ?xs2) = ?xs2"
+    using bit_symbols_to_symbols by simp
+  then have "?xs1 = ?xs2"
+    using 1 assms by simp
+  then have "numlistlist (formula_n \<phi>\<^sub>1) = numlistlist (formula_n \<phi>\<^sub>2)"
+    using binencode_inj bin1 bin2 by simp
+  then have "formula_n \<phi>\<^sub>1 = formula_n \<phi>\<^sub>2"
+    using numlistlist_inj by simp
+  then show ?thesis
+    using formula_n_inj by simp
+qed
+
+text \<open>
+While @{const formula_to_string} maps every CNF formula to a string, not every
+string represents a CNF formula. We could just ignore such invalid strings and
+define \SAT{} to only contain well-formed strings.  But this would implicitly
+place these invalid strings in the complement of \SAT{}. While this does not
+cause us any issues here, it would if we were to introduce co-$\NP$ and wanted
+to show that $\overline{\mathtt{SAT}}$ is in co-$\NP$, as we would then have to
+deal with the invalid strings. So it feels a little like cheating to ignore the
+invalid strings like this.
+
+Arora and Barak~\cite[p.~45 footnote~3]{ccama} recommend mapping invalid strings
+to ``some fixed formula''.  A natural candidate for this fixed formula is the
+empty CNF, since an invalid string in a sense represents nothing, and the empty
+CNF formula is represented by the empty string. Since the empty CNF formula is
+satisfiable this implies that all invalid strings become elements of \SAT{}.
+
+We end up with the following definition of the protagonist of this article:
+\<close>
+
+definition SAT :: language where
+  "SAT \<equiv> {formula_to_string \<phi> | \<phi>. satisfiable \<phi>} \<union> {x. \<not> (\<exists>\<phi>. x = formula_to_string \<phi>)}"
+
+
+section \<open>\SAT{} is in $\NP$\label{s:Sat-np}\<close>
+
+text \<open>
+In order to show that \SAT{} is in $\NP$, we will construct a polynomial-time
+Turing machine $M$ and specify a polynomial function $p$ such that for every
+$x$, $x\in \SAT$ iff. there is a $u\in\bbOI^{p(|x|)}$ such that $M$ outputs
+\textbf{1} on $\langle x; u\rangle$.
+
+The idea is straightforward: Let $\phi$ be the formula represented by the
+string $x$.  Interpret the string $u$ as a list of variables and interpret this
+as the assignment that assigns True to only the variables in the list. Then
+check if the assignment satisfies the formula. This check is ``obviously''
+possible in polynomial time because $M$ simply has to iterate over all clauses
+and check if at least one literal per clause is true under the assignment.
+Checking if a literal is true is simply a matter of checking whether the
+literal's variable is in the list $u$. If the assignment satisfies $\phi$,
+output \textbf{1}, otherwise the empty symbol sequence.
+
+If $\phi$ is unsatisfiable then no assignment, hence no $u$ no matter the length
+will make $M$ output \textbf{1}. On the other hand, if $\phi$ is satisfiable
+then there will be a satisfying assignment where a subset of the variables in
+$\phi$ are assigned True. Hence there will be a list of variables of at most
+roughly the length of $\phi$. So setting the polynomial $p$ to something like
+$p(n) = n$ should suffice.
+
+In fact, as we shall see, $p(n) = n$ suffices. This is so because in our
+representation, the string $x$, being a list of lists, has slightly more
+overhead per number than the plain list $u$ has. Therefore listing all variables
+in $\phi$ is guaranteed to need fewer symbols than $x$ has.
+
+There are several technical details to work out. First of all, the input to $M$
+need not be a well-formed pair. And if it is, the pair $\langle x, u\rangle$ has
+to be decoded into separate components $x$ and $u$. These have to be decoded
+again from the binary to the quaternary alphabet, which is only possible if both
+$x$ and $u$ comprise only bit symbols (\textbf{01}). Then $M$ needs to check if
+the decoded $x$ and $u$ are valid symbol sequences for lists (of lists) of
+numbers. In the case of $u$ this is particularly finicky because the definition
+of $\NP$ requires us to provide a string $u$ of exactly the length $p(|x|)$ and
+so we have to pad $u$ with extra symbols, which have to be stripped again before
+the validation can take place.
+
+In the first subsection we describe what the verifier TM has to do in terms of
+symbol sequences. In the subsections after that we devise a Turing machine that
+implements this behavior.
+\<close>
+
+
+subsection \<open>Verifying \SAT{} instances\<close>
+
+text \<open>
+Our verifier Turing machine for \SAT{} will implement the following function;
+that is, on input @{term zs} it will output @{term "verify_sat zs"}.  It
+performs a number of decodings and well-formedness checks and outputs either
+\textbf{1} or the empty symbol sequence.
+\<close>
+
+definition verify_sat :: "symbol list \<Rightarrow> symbol list" where
+  "verify_sat zs \<equiv>
+    let
+      ys = bindecode zs;
+      xs = bindecode (first ys);
+      vs = rstrip \<sharp> (bindecode (second ys))
+    in
+      if even (length (first ys)) \<and> bit_symbols (first ys) \<and> numlistlist_wf xs
+      then if bit_symbols (second ys) \<and> numlist_wf vs
+           then if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then [\<one>] else []
+           else []
+      else [\<one>]"
+
+text \<open>
+Next we show that @{const verify_sat} behaves as is required of a verifier TM
+for \SAT. Its polynomial running time is the subject of the next subsection.
+\<close>
+
+text \<open>
+First we consider the case that @{term zs} encodes a pair $\langle x, u\rangle$
+of strings where $x$ does not represent a CNF formula. Such an $x$ is in \SAT{},
+hence the verifier TM is supposed to output \textbf{1}.
+\<close>
+
+lemma ex_phi_x:
+  assumes "xs = string_to_symbols x"
+  assumes "even (length xs)" and "numlistlist_wf (bindecode xs)"
+  shows "\<exists>\<phi>. x = formula_to_string \<phi>"
+proof -
+  obtain nss where "numlistlist nss = bindecode xs"
+    using assms(3) numlistlist_wf_def by auto
+  moreover have "binencode (bindecode xs) = xs"
+    using assms(1,2) binencode_decode by simp
+  ultimately have "binencode (numlistlist nss) = xs"
+    by simp
+  then have "binencode (numlistlist (formula_n (n_formula nss))) = xs"
+    using formula_n_formula by simp
+  then have "formula_to_string (n_formula nss) = symbols_to_string xs"
+    by simp
+  then show ?thesis
+    using assms(1) symbols_to_string_to_symbols by auto
+qed
+
+lemma verify_sat_not_wf_phi:
+  assumes "zs = \<langle>x; u\<rangle>" and "\<not> (\<exists>\<phi>. x = formula_to_string \<phi>)"
+  shows "verify_sat zs = [\<one>]"
+proof -
+  define ys where "ys = bindecode zs"
+  then have first_ys: "first ys = string_to_symbols x"
+    using first_pair assms(1) by simp
+  then have 2: "bit_symbols (first ys)"
+    using assms(1) bit_symbols_first ys_def by presburger
+
+  define xs where "xs = bindecode (first ys)"
+  then have "\<not> (even (length (first ys)) \<and> bit_symbols (first ys) \<and> numlistlist_wf xs)"
+    using first_ys ex_phi_x assms(2) by auto
+  then show "verify_sat zs = [\<one>]"
+    unfolding verify_sat_def Let_def using ys_def xs_def by simp
+qed
+
+text \<open>
+The next case is that @{term zs} represents a pair $\langle x, u\rangle$ where
+$x$ represents an unsatisfiable CNF formula. This $x$ is thus not in \SAT{} and
+the verifier TM must output something different from \textbf{1}, such as the
+empty string, regardless of $u$.
+\<close>
+
+lemma verify_sat_not_sat:
+  fixes \<phi> :: formula
+  assumes "zs = \<langle>formula_to_string \<phi>; u\<rangle>" and "\<not> satisfiable \<phi>"
+  shows "verify_sat zs = []"
+proof -
+  have bs_phi: "bit_symbols (binencode (formula_zs \<phi>))"
+    using bit_symbols_binencode formula_zs_def proper_symbols_numlistlist symbols_lt_numlistlist
+    by (metis Suc_le_eq dual_order.refl numeral_2_eq_2)
+
+  define ys where "ys = bindecode zs"
+  then have "first ys = string_to_symbols (formula_to_string \<phi>)"
+    using first_pair assms(1) by simp
+  then have first_ys: "first ys = binencode (formula_zs \<phi>)"
+    using bit_symbols_to_symbols bs_phi formula_zs_def by simp
+  then have 2: "bit_symbols (first ys)"
+    using assms(1) bit_symbols_first ys_def by presburger
+  have 22: "even (length (first ys))"
+    using first_ys by simp
+
+  define xs where "xs = bindecode (first ys)"
+  define vs where "vs = rstrip 5 (bindecode (second ys))"
+
+  have wf_xs: "numlistlist_wf xs"
+    using xs_def first_ys bindecode_encode formula_zs_def numlistlist_wf_def numlistlist_wf_has2'
+    by (metis le_simps(3) numerals(2))
+
+  have \<phi>: "zs_formula xs = \<phi>"
+    using xs_def first_ys "2" binencode_decode formula_to_string_inj formula_zs_def formula_zs_formula wf_xs
+    by auto
+
+  have "verify_sat zs =
+     (if bit_symbols (second ys) \<and> numlist_wf vs
+      then if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> \<phi> then [3] else []
+      else [])"
+    unfolding verify_sat_def Let_def using ys_def xs_def vs_def 2 22 wf_xs \<phi> by simp
+  then show "verify_sat zs = []"
+    using assms(2) satisfiable_def by simp
+qed
+
+text \<open>
+Next we consider the case in which @{term zs} represents a pair $\langle x,
+u\rangle$ where $x$ represents a satisfiable CNF formula and $u$ a list of
+numbers padded at the right with @{text \<sharp>} symbols. This $u$ thus represents a
+variable assignment, namely the one assigning True to exactly the variables in
+the list. The verifier TM is to output \textbf{1} iff.\ this assignment
+satisfies the CNF formula represented by $x$.
+
+First we show that stripping away @{text \<sharp>} symbols does not damage a symbol
+sequence representing a list of numbers.
+\<close>
+
+lemma rstrip_numlist_append: "rstrip \<sharp> (numlist vars @ replicate pad \<sharp>) = numlist vars"
+  (is "rstrip \<sharp> ?zs = ?ys")
+proof -
+  have "(LEAST i. i \<le> length ?zs \<and> set (drop i ?zs) \<subseteq> {\<sharp>}) = length ?ys"
+  proof (rule Least_equality)
+    show "length ?ys \<le> length ?zs \<and> set (drop (length ?ys) ?zs) \<subseteq> {\<sharp>}"
+      by auto
+    show "length ?ys \<le> m" if "m \<le> length ?zs \<and> set (drop m ?zs) \<subseteq> {\<sharp>}" for m
+    proof (rule ccontr)
+      assume "\<not> length ?ys \<le> m"
+      then have "m < length ?ys"
+        by simp
+      then have "?ys ! m \<in> set (drop m ?ys)"
+        by (metis Cons_nth_drop_Suc list.set_intros(1))
+      moreover have "set (drop m ?ys) \<subseteq> {\<sharp>}"
+        using that by simp
+      ultimately have "?ys ! m = \<sharp>"
+        by auto
+      moreover have "?ys ! m < \<sharp>"
+        using symbols_lt_numlist `m < length ?ys` by simp
+      ultimately show False
+        by simp
+    qed
+  qed
+  then show ?thesis
+    using rstrip_def by simp
+qed
+
+lemma verify_sat_wf:
+  fixes \<phi> :: formula and pad :: nat
+  assumes "zs = \<langle>formula_to_string \<phi>; symbols_to_string (binencode (numlist vars @ replicate pad \<sharp>))\<rangle>"
+  shows "verify_sat zs = (if (\<lambda>v. v \<in> set vars) \<Turnstile> \<phi> then [\<one>] else [])"
+proof -
+  have bs_phi: "bit_symbols (binencode (formula_zs \<phi>))"
+    using bit_symbols_binencode formula_zs_def proper_symbols_numlistlist symbols_lt_numlistlist
+    by (metis Suc_le_eq dual_order.refl numeral_2_eq_2)
+
+  have "binencodable (numlist vars @ replicate pad \<sharp>)"
+    using proper_symbols_numlist symbols_lt_numlist binencodable_append[of "numlist vars" "replicate pad \<sharp>"]
+    by fastforce
+  then have bs_vars: "bit_symbols (binencode (numlist vars @ replicate pad \<sharp>))"
+    using bit_symbols_binencode by simp
+
+  define ys where "ys = bindecode zs"
+  then have "first ys = string_to_symbols (formula_to_string \<phi>)"
+    using first_pair assms(1) by simp
+  then have first_ys: "first ys = binencode (formula_zs \<phi>)"
+    using bit_symbols_to_symbols bs_phi formula_zs_def by simp
+  then have bs_first: "bit_symbols (first ys)"
+    using assms(1) bit_symbols_first ys_def by presburger
+
+  have even: "even (length (first ys))"
+    using first_ys by simp
+
+  have second_ys: "second ys = binencode (numlist vars @ replicate pad \<sharp>)"
+    using bs_vars ys_def assms(1) bit_symbols_to_symbols second_pair by simp
+  then have bs_second: "bit_symbols (second ys)"
+    using bs_vars by simp
+
+  define xs where "xs = bindecode (first ys)"
+  define vs where "vs = rstrip \<sharp> (bindecode (second ys))"
+
+  then have "vs = rstrip \<sharp> (numlist vars @ replicate pad \<sharp>)"
+    using second_ys \<open>binencodable (numlist vars @ replicate pad \<sharp>)\<close> bindecode_encode by simp
+  then have vs: "vs = numlist vars"
+    using rstrip_numlist_append by simp
+
+  have wf_xs: "numlistlist_wf xs"
+    using xs_def first_ys bindecode_encode formula_zs_def numlistlist_wf_def numlistlist_wf_has2'
+    by (metis le_simps(3) numerals(2))
+
+  have "verify_sat zs =
+     (if even (length (first ys)) \<and> bit_symbols (first ys) \<and> numlistlist_wf xs
+      then if bit_symbols (second ys) \<and> numlist_wf vs
+           then if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then [\<one>] else []
+           else []
+      else [3])"
+    unfolding verify_sat_def Let_def using bs_second ys_def xs_def vs_def by simp
+  then have *: "verify_sat zs =
+        (if bit_symbols (second ys) \<and> numlist_wf vs
+         then if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then [\<one>] else []
+         else [])"
+    unfolding verify_sat_def Let_def using even bs_first wf_xs by simp
+
+  have "xs = formula_zs \<phi>"
+    using xs_def bindecode_encode formula_zs_def first_ys proper_symbols_numlistlist symbols_lt_numlistlist
+    by (simp add: Suc_leI numerals(2))
+  then have \<phi>: "\<phi> = zs_formula xs"
+    by (simp add: zs_formula_zs)
+
+  have vars: "vars = zs_numlist vs"
+    using vs numlist_wf_def numlist_zs_numlist zs_numlist_ex1 by blast
+  then have wf_vs: "numlist_wf vs"
+    using numlist_wf_def vs by auto
+
+  have "verify_sat zs = (if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then [\<one>] else [])"
+    using * bs_second wf_xs wf_vs by simp
+  then show ?thesis
+    using \<phi> vars by simp
+qed
+
+text \<open>
+Finally we show that for every string $x$ representing a satisfiable CNF formula
+there is a list of numbers representing a satisfying assignment and represented
+by a string of length at most $|x|$. That means there is always a string of
+exactly the length of $x$ consisting of a satisfying assignment plus some
+padding symbols.
+\<close>
+
+lemma nllength_remove1:
+  assumes "n \<in> set ns"
+  shows "nllength (n # remove1 n ns) = nllength ns"
+  using assms nllength sum_list_map_remove1[of n ns "\<lambda>n. Suc (nlength n)"] by simp
+
+lemma nllength_distinct_le:
+  assumes "distinct ns"
+    and "set ns \<subseteq> set ms"
+  shows "nllength ns \<le> nllength ms"
+  using assms
+proof (induction ms arbitrary: ns)
+  case Nil
+  then show ?case
+    by simp
+next
+  case (Cons m ms)
+  show ?case
+  proof (cases "m \<in> set ns")
+    case True
+    let ?ns = "remove1 m ns"
+    have "set ?ns \<subseteq> set ms"
+      using Cons by auto
+    moreover have "distinct ?ns"
+      using Cons by simp
+    ultimately have *: "nllength ?ns \<le> nllength ms"
+      using Cons by simp
+
+    have "nllength ns = nllength (m # ?ns)"
+      using True nllength_remove1 by simp
+    also have "... = Suc (nlength m) + nllength ?ns"
+      using nllength by simp
+    also have "... \<le> Suc (nlength m) + nllength ms"
+      using * by simp
+    also have "... = nllength (m # ms)"
+      using nllength by simp
+    finally show ?thesis .
+  next
+    case False
+    then have "set ns \<subseteq> set ms"
+      using Cons by auto
+    moreover have "distinct ns"
+      using Cons by simp
+    ultimately have "nllength ns \<le> nllength ms"
+      using Cons by simp
+    then show ?thesis
+      using nllength by simp
+  qed
+qed
+
+lemma nlllength_nllength_concat: "nlllength nss = nllength (concat nss) + length nss"
+  using nlllength nllength by (induction nss) simp_all
+
+fun variable :: "literal \<Rightarrow> nat" where
+  "variable (Neg i) = i" |
+  "variable (Pos i) = i"
+
+lemma sum_list_eq: "ns = ms \<Longrightarrow> sum_list ns = sum_list ms"
+  by simp
+
+lemma nllength_clause_le: "nllength (clause_n cl) \<ge> nllength (map variable cl)"
+proof -
+  have "variable x \<le> literal_n x" for x
+    by (cases x) simp_all
+  then have *: "Suc (nlength (variable x)) \<le> Suc (nlength (literal_n x))" for x
+    using nlength_mono by simp
+
+  let ?ns = "map literal_n cl"
+  have "nllength (clause_n cl) = nllength ?ns"
+    using clause_n_def by presburger
+  also have "... = (\<Sum>n\<leftarrow>?ns. Suc (nlength n))"
+    using nllength by simp
+  also have "... = (\<Sum>x\<leftarrow>cl. Suc (nlength (literal_n x)))"
+    by (smt (verit, del_insts) length_map nth_equalityI nth_map)
+  also have "... \<ge> (\<Sum>x\<leftarrow>cl. Suc (nlength (variable x)))"
+    using * by (simp add: sum_list_mono)
+  finally have "(\<Sum>x\<leftarrow>cl. Suc (nlength (variable x))) \<le> nllength (clause_n cl)"
+    by simp
+  moreover have "(\<Sum>x\<leftarrow>cl. Suc (nlength (variable x))) = nllength (map variable cl)"
+  proof -
+    have 1: "map (\<lambda>x. Suc (nlength (variable x))) cl = map (\<lambda>n. Suc (nlength n)) (map variable cl)"
+      by simp
+    then have "(\<Sum>x\<leftarrow>cl. Suc (nlength (variable x))) = (\<Sum>n\<leftarrow>(map variable cl). Suc (nlength n))"
+      using sum_list_eq[OF 1] by simp
+    then show ?thesis
+      using nllength by simp
+  qed
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma nlllength_formula_ge: "nlllength (formula_n \<phi>) \<ge> nlllength (map (map variable) \<phi>)"
+proof (induction \<phi>)
+  case Nil
+  then show ?case
+    by simp
+next
+  case (Cons cl \<phi>)
+  have "nlllength (map (map variable) (cl # \<phi>)) =
+      nlllength (map (map variable) [cl]) + nlllength (map (map variable) \<phi>)"
+    using nlllength by simp
+  also have "... = Suc (nllength (map variable cl)) + nlllength (map (map variable) \<phi>)"
+    using nlllength by simp
+  also have "... \<le> Suc (nllength (map variable cl)) + nlllength (formula_n \<phi>)"
+    using Cons by simp
+  also have "... \<le> Suc (nllength (clause_n cl)) + nlllength (formula_n \<phi>)"
+    using nllength_clause_le by simp
+  also have "... = nlllength (formula_n (cl # \<phi>))"
+    using nlllength by (simp add: formula_n_def)
+  finally show ?case .
+qed
+
+lemma variables_shorter_formula:
+  fixes \<phi> :: formula and vars :: "nat list"
+  assumes "set vars \<subseteq> variables \<phi>" and "distinct vars"
+  shows "nllength vars \<le> nlllength (formula_n \<phi>)"
+proof -
+  let ?nss = "map (map variable) \<phi>"
+  have "nllength (concat ?nss) \<le> nlllength ?nss"
+    using nlllength_nllength_concat by simp
+  then have *: "nllength (concat ?nss) \<le> nlllength (formula_n \<phi>)"
+    using nlllength_formula_ge by (meson le_trans)
+
+  have "set vars \<subseteq> set (concat ?nss)"
+  proof
+    fix n :: nat
+    assume "n \<in> set vars"
+    then have "n \<in> variables \<phi>"
+      using assms(1) by auto
+    then obtain c where c: "c \<in> set \<phi>" "Neg n \<in> set c \<or> Pos n \<in> set c"
+      using variables_def by auto
+    then obtain x where x: "x \<in> set c" "variable x = n"
+      by auto
+    then show "n \<in> set (concat (map (map variable) \<phi>))"
+      using c by auto
+  qed
+  then have "nllength vars \<le> nllength (concat ?nss)"
+    using nllength_distinct_le assms(2) by simp
+  then show ?thesis
+    using * by simp
+qed
+
+lemma ex_assignment_linear_length:
+  assumes "satisfiable \<phi>"
+  shows "\<exists>vars. (\<lambda>v. v \<in> set vars) \<Turnstile> \<phi> \<and> nllength vars \<le> nlllength (formula_n \<phi>)"
+proof -
+  obtain \<alpha> where \<alpha>: "\<alpha> \<Turnstile> \<phi>"
+    using assms satisfiable_def by auto
+  define poss where "poss = {v. v \<in> variables \<phi> \<and> \<alpha> v}"
+  then have "finite poss"
+    using finite_variables by simp
+
+  let ?beta = "\<lambda>v. v \<in> poss"
+  have sat: "?beta \<Turnstile> \<phi>"
+    unfolding satisfies_def
+  proof
+    fix c :: clause
+    assume "c \<in> set \<phi>"
+    then have "satisfies_clause \<alpha> c"
+      using satisfies_def \<alpha> by simp
+    then obtain x where x: "x \<in> set c" "satisfies_literal \<alpha> x"
+      using satisfies_clause_def by auto
+    show "satisfies_clause ?beta c"
+    proof (cases x)
+      case (Neg n)
+      then have "\<not> \<alpha> n"
+        using x(2) by simp
+      then have "n \<notin> poss"
+        using poss_def by simp
+      then have "\<not> ?beta n"
+        by simp
+      then have "satisfies_literal ?beta x"
+        using Neg by simp
+      then show ?thesis
+        using satisfies_clause_def x(1) by auto
+    next
+      case (Pos n)
+      then have "\<alpha> n"
+        using x(2) by simp
+      then have "n \<in> poss"
+        using poss_def Pos \<open>c \<in> set \<phi>\<close> variables_def x(1) by auto
+      then have "?beta n"
+        by simp
+      then have "satisfies_literal ?beta x"
+        using Pos by simp
+      then show ?thesis
+        using satisfies_clause_def x(1) by auto
+    qed
+  qed
+
+  obtain vars where vars: "set vars = poss" "distinct vars"
+    using `finite poss` by (meson finite_distinct_list)
+  moreover from this have "set vars \<subseteq> variables \<phi>"
+    using poss_def by simp
+  ultimately have "nllength vars \<le> nlllength (formula_n \<phi>)"
+    using variables_shorter_formula by simp
+  moreover have "(\<lambda>v. v \<in> set vars) \<Turnstile> \<phi>"
+    using vars(1) sat by simp
+  ultimately show ?thesis
+    by auto
+qed
+
+lemma ex_witness_linear_length:
+  fixes \<phi> :: formula
+  assumes "satisfiable \<phi>"
+  shows "\<exists>us.
+    bit_symbols us \<and>
+    length us = length (formula_to_string \<phi>) \<and>
+    verify_sat \<langle>formula_to_string \<phi>; symbols_to_string us\<rangle> = [\<one>]"
+proof -
+  obtain vars where vars:
+    "(\<lambda>v. v \<in> set vars) \<Turnstile> \<phi>"
+    "nllength vars \<le> nlllength (formula_n \<phi>)"
+    using assms ex_assignment_linear_length by auto
+
+  define pad where "pad = nlllength (formula_n \<phi>) - nllength vars"
+  then have "nllength vars + pad = nlllength (formula_n \<phi>)"
+    using vars(2) by simp
+  moreover define us where "us = numlist vars @ replicate pad \<sharp>"
+  ultimately have "length us = nlllength (formula_n \<phi>)"
+    by (simp add: nllength_def)
+  then have "length (binencode us) = length (formula_to_string \<phi>)" (is "length ?us = _")
+    by (simp add: nlllength_def)
+  moreover have "verify_sat \<langle>formula_to_string \<phi>; symbols_to_string ?us\<rangle> = [\<one>]"
+    using us_def vars(1) assms verify_sat_wf by simp
+  moreover have "bit_symbols ?us"
+  proof -
+    have "binencodable (numlist vars)"
+      using proper_symbols_numlist symbols_lt_numlist
+      by (metis Suc_leI lessI less_Suc_numeral numeral_2_eq_2 numeral_le_iff numeral_less_iff
+        order_less_le_trans pred_numeral_simps(3) semiring_norm(74))
+    moreover have "binencodable (replicate pad \<sharp>)"
+      by simp
+    ultimately have "binencodable us"
+      using us_def binencodable_append by simp
+    then show ?thesis
+      using bit_symbols_binencode by simp
+  qed
+  ultimately show ?thesis
+    by blast
+qed
+
+lemma bit_symbols_verify_sat: "bit_symbols (verify_sat zs)"
+  unfolding verify_sat_def Let_def by simp
+
+
+subsection \<open>A Turing machine for verifying formulas\<close>
+
+text \<open>
+The core of the function @{const verify_sat} is the expression @{term " (\<lambda>v. v \<in>
+set (zs_numlist vs)) \<Turnstile> zs_formula xs"}, which checks if an assignment
+represented by a list of variable indices satisfies a CNF formula represented by
+a list of lists of literals. In this section we devise a Turing machine
+performing this check.
+
+Recall that the numbers 0 and 1 are represented by the empty symbol sequence
+and the symbol sequence \textbf{1}, respectively. The Turing machines in this
+section are described in terms of numbers.
+
+We start with a Turing machine that checks a clause. The TM accepts on tape
+$j_1$ a list of numbers representing an assignment $\alpha$ and on tape $j_2$ a
+list of numbers representing a clause. It outputs on tape $j_3$ the number 1 if
+$\alpha$ satisfies the clause, and otherwise 0. To do this the TM iterates over
+all literals in the clause and determines the underlying variable and the sign
+of the literal. If the literal is positive and the variable is in the list
+representing $\alpha$ or if the literal is negative and the variable is not in
+the list, the number 1 is written to the tape $j_3$. Otherwise the tape remains
+unchanged. We assume $j_3$ is initialized with 0, and so it will be 1 if and
+only if at least one literal is satisfied by $\alpha$.
+
+The TM requires five auxiliary tapes $j_3 + 1, \dots, j_3 + 5$. Tape $j_3 + 1$
+stores the literals one at a time, and later the variable; tape $j_3 + 2$ stores
+the sign of the literal; tape $j_3 + 3$ stores whether the variable is contained
+in $\alpha$; tapes $j_3 + 4$ and $j_3 + 5$ are the auxiliary tapes of @{const
+tm_contains}.
+\<close>
+
+definition tm_sat_clause :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_sat_clause j1 j2 j3 \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! j2 \<noteq> \<box> DO
+      tm_nextract 4 j2 (j3 + 1) ;;
+      tm_mod2 (j3 + 1) (j3 + 2) ;;
+      tm_div2 (j3 + 1) ;;
+      tm_contains j1 (j3 + 1) (j3 + 3) ;;
+      IF \<lambda>rs. rs ! (j3 + 3) = \<box> \<and> rs ! (j3 + 2) = \<box> \<or> rs ! (j3 + 3) \<noteq> \<box> \<and> rs ! (j3 + 2) \<noteq> \<box> THEN
+        tm_setn j3 1
+      ELSE
+        []
+      ENDIF ;;
+      tm_setn (j3 + 1) 0 ;;
+      tm_setn (j3 + 2) 0 ;;
+      tm_setn (j3 + 3) 0
+    DONE ;;
+    tm_cr j2"
+
+lemma tm_sat_clause_tm:
+  assumes "k \<ge> 2" and "G \<ge> 5" and "j3 + 5 < k" "0 < j1" "j1 < k" "j2 < k" "j1 < j3"
+  shows "turing_machine k G (tm_sat_clause j1 j2 j3)"
+  using tm_sat_clause_def tm_mod2_tm tm_div2_tm tm_nextract_tm tm_setn_tm tm_contains_tm Nil_tm tm_cr_tm
+    assms turing_machine_loop_turing_machine turing_machine_branch_turing_machine
+  by simp
+
+locale turing_machine_sat_clause =
+  fixes j1 j2 j3 :: tapeidx
+begin
+
+definition "tmL1 \<equiv> tm_nextract 4 j2 (j3 + 1)"
+definition "tmL2 \<equiv> tmL1 ;; tm_mod2 (j3 + 1) (j3 + 2)"
+definition "tmL3 \<equiv> tmL2 ;; tm_div2 (j3 + 1)"
+definition "tmL4 \<equiv> tmL3 ;; tm_contains j1 (j3 + 1) (j3 + 3)"
+definition "tmI \<equiv> IF \<lambda>rs. rs ! (j3 + 3) = \<box> \<and> rs ! (j3 + 2) = \<box> \<or> rs ! (j3 + 3) \<noteq> \<box> \<and> rs ! (j3 + 2) \<noteq> \<box> THEN tm_setn j3 1 ELSE [] ENDIF"
+definition "tmL5 \<equiv> tmL4 ;; tmI"
+definition "tmL6 \<equiv> tmL5 ;; tm_setn (j3 + 1) 0"
+definition "tmL7 \<equiv> tmL6 ;; tm_setn (j3 + 2) 0"
+definition "tmL8 \<equiv> tmL7 ;; tm_setn (j3 + 3) 0"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! j2 \<noteq> \<box> DO tmL8 DONE"
+definition "tm2 \<equiv> tmL ;; tm_cr j2"
+
+lemma tm2_eq_tm_sat_clause: "tm2 = tm_sat_clause j1 j2 j3"
+  unfolding tm2_def tmL_def tmL8_def tmL7_def tmL6_def tmL5_def tmL4_def tmL3_def tmI_def
+    tmL2_def tmL1_def tm_sat_clause_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and vars :: "nat list" and clause :: clause
+  assumes jk: "0 < j1" "j1 \<noteq> j2" "j3 + 5 < k" "j1 < j3" "j2 < j3" "0 < j2" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = nltape' vars 0"
+    "tps0 ! j2 = nltape' (clause_n clause) 0"
+    "tps0 ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+abbreviation "sat_take t \<equiv> satisfies_clause (\<lambda>v. v \<in> set vars) (take t clause)"
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [j2 := nltape' (clause_n clause) t,
+     j3 := (\<lfloor>sat_take t\<rfloor>\<^sub>B, 1)]"
+
+lemma tpsL0: "tpsL 0 = tps0"
+proof -
+  have "nltape' (clause_n clause) 0 = tps0 ! j2"
+    using tps0(2) by presburger
+  moreover have "\<lfloor>sat_take 0\<rfloor>\<^sub>B = \<lfloor>0\<rfloor>\<^sub>N"
+    using satisfies_clause_def by simp
+  ultimately show ?thesis
+    using tpsL_def tps0 jk by (metis list_update_id)
+qed
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+  "tpsL1 t \<equiv> tps0
+    [j2 := nltape' (clause_n clause) (Suc t),
+     j3 := (\<lfloor>sat_take t\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>literal_n (clause ! t)\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL1 [transforms_intros]:
+  assumes "ttt = 12 + 2 * nlength (clause_n clause ! t)" and "t < length (clause_n clause)"
+  shows "transforms tmL1 (tpsL t) ttt (tpsL1 t)"
+  unfolding tmL1_def
+proof (tform tps: assms tps0 tpsL_def tpsL1_def jk)
+  have len: "t < length clause"
+    using assms(2) clause_n_def by simp
+  show "ttt = 12 + 2 * nlength 0 + 2 * nlength (clause_n clause ! t)"
+    using assms(1) by simp
+  have *: "j2 \<noteq> j3"
+    using jk by simp
+  have **: "clause_n clause ! t = literal_n (clause ! t)"
+    using len by (simp add: clause_n_def)
+  show "tpsL1 t = (tpsL t)
+    [j2 := nltape' (clause_n clause) (Suc t),
+     j3 + 1 := (\<lfloor>clause_n clause ! t\<rfloor>\<^sub>N, 1)]"
+    unfolding tpsL_def tpsL1_def using list_update_swap[OF *, of tps0] by (simp add: **)
+qed
+
+definition tpsL2 :: "nat \<Rightarrow> tape list" where
+  "tpsL2 t \<equiv> tps0
+    [j2 := nltape' (clause_n clause) (Suc t),
+     j3 := (\<lfloor>sat_take t\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>literal_n (clause ! t)\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>literal_n (clause ! t) mod 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL2 [transforms_intros]:
+  assumes "ttt = 12 + 2 * nlength (clause_n clause ! t) + 1"
+    and "t < length (clause_n clause)"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL2 t)"
+  unfolding tmL2_def by (tform tps: assms tps0 tpsL2_def tpsL1_def jk)
+
+definition tpsL3 :: "nat \<Rightarrow> tape list" where
+  "tpsL3 t \<equiv> tps0
+    [j2 := nltape' (clause_n clause) (Suc t),
+     j3 := (\<lfloor>sat_take t\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>literal_n (clause ! t) div 2\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>literal_n (clause ! t) mod 2\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL3 [transforms_intros]:
+  assumes "ttt = 16 + 4 * nlength (clause_n clause ! t)"
+    and "t < length (clause_n clause)"
+  shows "transforms tmL3 (tpsL t) ttt (tpsL3 t)"
+  unfolding tmL3_def
+proof (tform tps: assms(2) tps0 tpsL3_def tpsL2_def jk)
+  have len: "t < length clause"
+    using assms(2) clause_n_def by simp
+  have **: "clause_n clause ! t = literal_n (clause ! t)"
+    using len by (simp add: clause_n_def)
+  show "ttt = 12 + 2 * nlength (clause_n clause ! t) + 1 + (2 * nlength (literal_n (clause ! t)) + 3)"
+    using assms(1) ** by simp
+qed
+
+definition tpsL4 :: "nat \<Rightarrow> tape list" where
+  "tpsL4 t \<equiv> tps0
+    [j2 := nltape' (clause_n clause) (Suc t),
+     j3 := (\<lfloor>sat_take t\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>literal_n (clause ! t) div 2\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>literal_n (clause ! t) mod 2\<rfloor>\<^sub>N, 1),
+     j3 + 3 := (\<lfloor>literal_n (clause ! t) div 2 \<in> set vars\<rfloor>\<^sub>B, 1)]"
+
+lemma tmL4 [transforms_intros]:
+  assumes "ttt = 20 + 4 * nlength (clause_n clause ! t) + 67 * (nllength vars)\<^sup>2"
+    and "t < length (clause_n clause)"
+  shows "transforms tmL4 (tpsL t) ttt (tpsL4 t)"
+  unfolding tmL4_def
+proof (tform tps: assms(2) tps0 tpsL4_def tpsL3_def jk time: assms(1))
+  have "tpsL3 t ! (j3 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL3_def tps0 jk by simp
+  then show "tpsL3 t ! (j3 + 3 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    by (metis ab_semigroup_add_class.add_ac(1) numeral_plus_one semiring_norm(2) semiring_norm(8))
+  have "tpsL3 t ! (j3 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL3_def tps0 jk by simp
+  then show "tpsL3 t ! (j3 + 3 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    by (simp add: numeral_Bit1)
+qed
+
+definition tpsL5 :: "nat \<Rightarrow> tape list" where
+  "tpsL5 t \<equiv> tps0
+    [j2 := nltape' (clause_n clause) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>literal_n (clause ! t) div 2\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>literal_n (clause ! t) mod 2\<rfloor>\<^sub>N, 1),
+     j3 + 3 := (\<lfloor>literal_n (clause ! t) div 2 \<in> set vars\<rfloor>\<^sub>B, 1)]"
+
+lemma tmI [transforms_intros]:
+  assumes "ttt = 16" and "t < length (clause_n clause)"
+  shows "transforms tmI (tpsL4 t) ttt (tpsL5 t)"
+  unfolding tmI_def
+proof (tform tps: jk tpsL4_def time: assms(1))
+  show "10 + 2 * nlength (if sat_take t then 1 else 0) + 2 * nlength 1 + 2 \<le> ttt"
+    using assms(1) nlength_0 nlength_1_simp by simp
+
+  have len: "t < length clause"
+    using assms(2) by (simp add: clause_n_def)
+
+  let ?l = "clause ! t"
+  have 1: "read (tpsL4 t) ! (j3 + 3) = \<box> \<longleftrightarrow> literal_n ?l div 2 \<notin> set vars"
+    using tpsL4_def jk read_ncontents_eq_0[of "tpsL4 t" "j3 + 3"] by simp
+  have 2: "read (tpsL4 t) ! (j3 + 2) = \<box> \<longleftrightarrow> literal_n ?l mod 2 = 0"
+    using tpsL4_def jk read_ncontents_eq_0[of "tpsL4 t" "j3 + 2"] by simp
+
+  let ?a = "\<lambda>v. v \<in> set vars"
+  let ?cond = "read (tpsL4 t) ! (j3 + 3) = \<box> \<and> read (tpsL4 t) ! (j3 + 2) = \<box> \<or>
+    read (tpsL4 t) ! (j3 + 3) \<noteq> \<box> \<and> read (tpsL4 t) ! (j3 + 2) \<noteq> \<box>"
+  have *: "?cond \<longleftrightarrow> satisfies_literal ?a ?l"
+  proof (cases ?l)
+    case (Neg v)
+    then have "literal_n ?l div 2 = v" "literal_n ?l mod 2 = 0"
+      by simp_all
+    moreover from this have "satisfies_literal ?a ?l \<longleftrightarrow> v \<notin> set vars"
+      using Neg by simp
+    ultimately show ?thesis
+      using 1 2 by simp
+  next
+    case (Pos v)
+    then have "literal_n ?l div 2 = v" "literal_n ?l mod 2 = 1"
+      by simp_all
+    moreover from this have "satisfies_literal ?a ?l \<longleftrightarrow> v \<in> set vars"
+      using Pos by simp
+    ultimately show ?thesis
+      using 1 2 by simp
+  qed
+
+  have **: "sat_take (Suc t) \<longleftrightarrow> sat_take t \<or> satisfies_literal ?a ?l"
+    using satisfies_clause_take[OF len] by simp
+
+  show "tpsL5 t = (tpsL4 t)[j3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]" if ?cond
+  proof -
+    have "(if sat_take (Suc t) then 1::nat else 0) = 1"
+      using that * ** by simp
+    then show ?thesis
+      unfolding tpsL5_def tpsL4_def using that by (simp add: list_update_swap)
+  qed
+  show "tpsL5 t = (tpsL4 t)" if "\<not> ?cond"
+  proof -
+    have "sat_take t = sat_take (Suc t)"
+      using * ** that by simp
+    then show ?thesis
+      unfolding tpsL5_def tpsL4_def using that by (simp add: list_update_swap)
+  qed
+qed
+
+lemma tmL5 [transforms_intros]:
+  assumes "ttt = 36 + 4 * nlength (clause_n clause ! t) + 67 * (nllength vars)\<^sup>2"
+    and "t < length (clause_n clause)"
+  shows "transforms tmL5 (tpsL t) ttt (tpsL5 t)"
+  unfolding tmL5_def by (tform tps: assms)
+
+definition tpsL6 :: "nat \<Rightarrow> tape list" where
+  "tpsL6 t \<equiv> tps0
+    [j2 := nltape' (clause_n clause) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>literal_n (clause ! t) mod 2\<rfloor>\<^sub>N, 1),
+     j3 + 3 := (\<lfloor>literal_n (clause ! t) div 2 \<in> set vars\<rfloor>\<^sub>B, 1)]"
+
+lemma tmL6 [transforms_intros]:
+  assumes "ttt = 46 + 4 * nlength (clause_n clause ! t) + 67 * (nllength vars)\<^sup>2 + 2 * nlength (literal_n (clause ! t) div 2)"
+    and "t < length (clause_n clause)"
+  shows "transforms tmL6 (tpsL t) ttt (tpsL6 t)"
+  unfolding tmL6_def by (tform tps: assms tps0 tpsL6_def tpsL5_def jk)
+
+definition tpsL7 :: "nat \<Rightarrow> tape list" where
+  "tpsL7 t \<equiv> tps0
+    [j2 := nltape' (clause_n clause) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j3 + 3 := (\<lfloor>literal_n (clause ! t) div 2 \<in> set vars\<rfloor>\<^sub>B, 1)]"
+
+lemma tmL7 [transforms_intros]:
+  assumes "ttt = 56 + 4 * nlength (clause_n clause ! t) + 67 * (nllength vars)\<^sup>2 + 2 * nlength (literal_n (clause ! t) div 2) +
+      2 * nlength (literal_n (clause ! t) mod 2)"
+    and "t < length (clause_n clause)"
+  shows "transforms tmL7 (tpsL t) ttt (tpsL7 t)"
+  unfolding tmL7_def by (tform tps: assms tps0 tpsL7_def tpsL6_def jk)
+
+definition tpsL8 :: "nat \<Rightarrow> tape list" where
+  "tpsL8 t \<equiv> tps0
+    [j2 := nltape' (clause_n clause) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j3 + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j3 + 3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL8:
+  assumes "ttt = 66 + 4 * nlength (clause_n clause ! t) + 67 * (nllength vars)\<^sup>2 +
+      2 * nlength (literal_n (clause ! t) div 2) +
+      2 * nlength (literal_n (clause ! t) mod 2) +
+      2 * nlength (if literal_n (clause ! t) div 2 \<in> set vars then 1 else 0)"
+    and "t < length (clause_n clause)"
+  shows "transforms tmL8 (tpsL t) ttt (tpsL8 t)"
+  unfolding tmL8_def by (tform tps: assms tps0 tpsL8_def tpsL7_def jk)
+
+lemma tmL8':
+  assumes "ttt = 70 + 6 * nllength (clause_n clause) + 67 * (nllength vars)\<^sup>2"
+    and "t < length (clause_n clause)"
+  shows "transforms tmL8 (tpsL t) ttt (tpsL8 t)"
+proof -
+  let ?l = "literal_n (clause ! t)"
+  let ?ll = "clause_n clause ! t"
+  let ?t = "66 + 4 * nlength ?ll + 67 * (nllength vars)\<^sup>2 +
+      2 * nlength (?l div 2) + 2 * nlength (?l mod 2) + 2 * nlength (if ?l div 2 \<in> set vars then 1 else 0)"
+  have "?t = 66 + 4 * nlength ?ll + 67 * (nllength vars)\<^sup>2 +
+      2 * nlength (?ll div 2) + 2 * nlength (?ll mod 2) + 2 * nlength (if ?ll div 2 \<in> set vars then 1 else 0)"
+    using assms(2) clause_n_def by simp
+  also have "... \<le> 66 + 4 * nlength ?ll + 67 * (nllength vars)\<^sup>2 +
+      2 * nlength ?ll + 2 * nlength (?ll mod 2) + 2 * nlength (if ?ll div 2 \<in> set vars then 1 else 0)"
+    using nlength_mono[of "?ll div 2" "?ll"] by simp
+  also have "... = 66 + 6 * nlength ?ll + 67 * (nllength vars)\<^sup>2 +
+      2 * nlength (?ll mod 2) + 2 * nlength (if ?ll div 2 \<in> set vars then 1 else 0)"
+    by simp
+  also have "... \<le> 66 + 6 * nlength ?ll + 67 * (nllength vars)\<^sup>2 +
+      2 * nlength 1 + 2 * nlength (if ?ll div 2 \<in> set vars then 1 else 0)"
+    using nlength_mono by simp
+  also have "... \<le> 66 + 6 * nlength ?ll + 67 * (nllength vars)\<^sup>2 + 2 * nlength 1 + 2 * nlength 1"
+    using nlength_mono by simp
+  also have "... = 70 + 6 * nlength ?ll + 67 * (nllength vars)\<^sup>2"
+    using nlength_1_simp by simp
+  also have "... \<le> 70 + 6 * nllength (clause_n clause) + 67 * (nllength vars)\<^sup>2"
+    using assms(2) member_le_nllength by simp
+  finally have "?t \<le> ttt"
+    using assms(1) by simp
+  then show ?thesis
+    using assms tmL8 transforms_monotone by blast
+qed
+
+definition tpsL8' :: "nat \<Rightarrow> tape list" where
+  "tpsL8' t \<equiv> tps0
+    [j2 := nltape' (clause_n clause) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1)]"
+
+lemma tpsL8': "tpsL8' = tpsL8"
+proof -
+  { fix t :: nat
+    have "tpsL8 t = tps0
+      [j2 := nltape' (clause_n clause) (Suc t),
+       j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1),
+       j3 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+       j3 + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+      unfolding tpsL8_def
+      using tps0 list_update_id[of "tps0" "j3 + 3"] jk
+      by (simp add: list_update_swap[of _ "j3 + 3"])
+    also have "... = tps0
+      [j2 := nltape' (clause_n clause) (Suc t),
+       j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1),
+       j3 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+      unfolding tpsL8_def
+      using tps0 list_update_id[of "tps0" "j3 + 2"] jk
+      by (simp add: list_update_swap[of _ "Suc (Suc j3)"])
+    also have "... = tps0
+      [j2 := nltape' (clause_n clause) (Suc t),
+       j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1)]"
+      unfolding tpsL8_def
+      using tps0 list_update_id[of "tps0" "j3 + 1"] jk
+      by (simp add: list_update_swap[of _ "Suc j3"])
+    also have "... = tpsL8' t"
+      using tpsL8'_def by simp
+    finally have "tpsL8 t = tpsL8' t" .
+  }
+  then show ?thesis
+    by auto
+qed
+
+lemma tmL8'' [transforms_intros]:
+  assumes "ttt = 70 + 6 * nllength (clause_n clause) + 67 * (nllength vars)\<^sup>2"
+    and "t < length (clause_n clause)"
+  shows "transforms tmL8 (tpsL t) ttt (tpsL8' t)"
+  using tmL8' tpsL8' assms by simp
+
+lemma tmL [transforms_intros]:
+  assumes "ttt = length (clause_n clause) * (72 + 6 * nllength (clause_n clause) + 67 * (nllength vars)\<^sup>2) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (length (clause_n clause)))"
+  unfolding tmL_def
+proof (tform)
+  let ?t = "70 + 6 * nllength (clause_n clause) + 67 * (nllength vars)\<^sup>2"
+  have "tpsL8' t = tpsL (Suc t)" for t
+    using tpsL8'_def tpsL_def by simp
+  then show "\<And>i. i < length (clause_n clause) \<Longrightarrow> transforms tmL8 (tpsL i) ?t (tpsL (Suc i))"
+    using tmL8'' by simp
+
+  let ?ns = "clause_n clause"
+  have *: "tpsL t ! j2 = nltape' ?ns t" for t
+    using tpsL_def jk by simp
+  moreover have "read (tpsL t) ! j2 = tpsL t :.: j2" for t
+    using tapes_at_read'[of j2 "tpsL t"] tpsL_def jk by simp
+  ultimately have "read (tpsL t) ! j2 = |.| (nltape' ?ns t)" for t
+    by simp
+  then have "read (tpsL t) ! j2 = \<box> \<longleftrightarrow> (t \<ge> length ?ns)" for t
+    using nltape'_tape_read by simp
+  then show
+      "\<And>i. i < length ?ns \<Longrightarrow> read (tpsL i) ! j2 \<noteq> \<box>"
+      "\<not> read (tpsL (length ?ns)) ! j2 \<noteq> \<box>"
+    using * by simp_all
+
+  show "length ?ns * (70 + 6 * nllength ?ns + 67 * (nllength vars)\<^sup>2 + 2) + 1 \<le> ttt"
+    using assms by simp
+qed
+
+definition tps1 :: "tape list" where
+  "tps1 \<equiv> tps0
+    [j2 := nltape' (clause_n clause) (length (clause_n clause)),
+     j3 := (\<lfloor>satisfies_clause (\<lambda>v. v \<in> set vars) clause\<rfloor>\<^sub>B, 1)]"
+
+lemma tps1: "tps1 = tpsL (length (clause_n clause))"
+proof -
+  have "length (clause_n clause) = length clause"
+    by (simp add: clause_n_def)
+  then show ?thesis
+    using tps1_def tpsL_def by simp
+qed
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = length (clause_n clause) * (72 + 6 * nllength (clause_n clause) + 67 * (nllength vars)\<^sup>2) + 1"
+  shows "transforms tmL tps0 ttt tps1"
+  using tmL tpsL0 assms tps1 by simp
+
+definition tps2 :: "tape list" where
+  "tps2 \<equiv> tps0
+    [j2 := nltape' (clause_n clause) 0,
+     j3 := (\<lfloor>satisfies_clause (\<lambda>v. v \<in> set vars) clause\<rfloor>\<^sub>B, 1)]"
+
+lemma tm2:
+  assumes "ttt = length (clause_n clause) * (72 + 6 * nllength (clause_n clause) + 67 * (nllength vars)\<^sup>2) +
+      nllength (clause_n clause) + 4"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: assms tps0 tps1_def jk)
+  have *: "tps1 ! j2 = nltape' (clause_n clause) (length (clause_n clause))"
+    using tps1_def jk by simp
+  then show "clean_tape (tps1 ! j2)"
+    using clean_tape_nlcontents by simp
+  have neq: "j3 \<noteq> j2"
+    using jk by simp
+  have "tps2 = tps1[j2 := nltape' (clause_n clause) 0]"
+    unfolding tps2_def tps1_def by (simp add: list_update_swap[OF neq])
+  moreover have "tps1 ! j2 |#=| 1 = nltape' (clause_n clause) 0"
+    using * by simp
+  ultimately show "tps2 = tps1[j2 := tps1 ! j2 |#=| 1]"
+    by simp
+qed
+
+definition tps2' :: "tape list" where
+  "tps2' \<equiv> tps0
+    [j3 := (\<lfloor>satisfies_clause (\<lambda>v. v \<in> set vars) clause\<rfloor>\<^sub>B, 1)]"
+
+lemma tm2':
+  assumes "ttt = 79 * (nllength (clause_n clause)) ^ 2 + 67 * (nllength (clause_n clause)) * nllength vars ^ 2 + 4"
+  shows "transforms tm2 tps0 ttt tps2'"
+proof -
+  let ?l = "nllength (clause_n clause)"
+  let ?t = "length (clause_n clause) * (72 + 6 * ?l + 67 * (nllength vars)\<^sup>2) + ?l + 4"
+  have "?t \<le> ?l * (72 + 6 * ?l + 67 * (nllength vars)\<^sup>2) + ?l + 4"
+    by (simp add: length_le_nllength)
+  also have "... = ?l * (73 + 6 * ?l + 67 * (nllength vars)\<^sup>2) + 4"
+    by algebra
+  also have "... = 73 * ?l + 6 * ?l ^ 2 + 67 * ?l * (nllength vars)\<^sup>2 + 4"
+    by algebra
+  also have "... \<le> 79 * ?l ^ 2 + 67 * ?l * (nllength vars)\<^sup>2 + 4"
+    using linear_le_pow by simp
+  finally have "?t \<le> ttt"
+    using assms by simp
+  moreover have "tps2' = tps2"
+    unfolding tps2'_def tps2_def using jk tps0 by (metis tape_list_eq)
+  ultimately show ?thesis
+    using tps2'_def tm2 assms transforms_monotone by simp
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_sat_clauseI [transforms_intros]:
+  fixes j1 j2 j3 :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k :: nat and vars :: "nat list" and clause :: "literal list"
+  assumes "0 < j1" "j1 \<noteq> j2" "j3 + 5 < k" "j1 < j3" "j2 < j3" "0 < j2" "length tps = k"
+  assumes
+    "tps ! j1 = nltape' vars 0"
+    "tps ! j2 = nltape' (clause_n clause) 0"
+    "tps ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "tps' = tps
+    [j3 := (\<lfloor>satisfies_clause (\<lambda>v. v \<in> set vars) clause\<rfloor>\<^sub>B, 1)]"
+  assumes "ttt = 79 * (nllength (clause_n clause)) ^ 2 + 67 * (nllength (clause_n clause)) * nllength vars ^ 2 + 4"
+  shows "transforms (tm_sat_clause j1 j2 j3) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_sat_clause j1 j2 j3 .
+  show ?thesis
+    using assms loc.tps2'_def loc.tm2' loc.tm2_eq_tm_sat_clause by simp
+qed
+
+text \<open>
+The following Turing machine expects a list of lists of numbers representing a
+formula $\phi$ on tape $j_1$ and a list of numbers representing an assignment
+$\alpha$ on tape $j_2$. It outputs on tape $j_3$ the number 1 if $\alpha$
+satisfies $\phi$, and otherwise the number 0. To do so the TM iterates over all
+clauses in $\phi$ and uses @{const tm_sat_clause} on each of them. It requires
+seven auxiliary tapes: $j_3 + 1$ to store the clauses one at a time, $j_3 + 2$ to
+store the results of @{const tm_sat_clause}, whose auxiliary tapes are $j_3 + 3,
+\dots, j_3 + 7$.
+\<close>
+
+definition tm_sat_formula :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_sat_formula j1 j2 j3 \<equiv>
+    tm_setn j3 1 ;;
+    WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO
+      tm_nextract \<sharp> j1 (j3 + 1) ;;
+      tm_sat_clause j2 (j3 + 1) (j3 + 2) ;;
+      IF \<lambda>rs. rs ! (j3 + 2) = \<box> THEN
+        tm_setn j3 0
+      ELSE
+        []
+      ENDIF ;;
+      tm_erase_cr (j3 + 1) ;;
+      tm_setn (j3 + 2) 0
+    DONE"
+
+lemma tm_sat_formula_tm:
+  assumes "k \<ge> 2" and "G \<ge> 6" and "0 < j1" "j1 \<noteq> j2" "j3 + 7 < k" "j1 < j3" "j2 < j3" "0 < j2"
+  shows "turing_machine k G (tm_sat_formula j1 j2 j3)"
+  using tm_sat_formula_def tm_sat_clause_tm tm_nextract_tm tm_setn_tm assms Nil_tm tm_erase_cr_tm
+    turing_machine_loop_turing_machine turing_machine_branch_turing_machine
+  by simp
+
+locale turing_machine_sat_formula =
+  fixes j1 j2 j3 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_setn j3 1"
+
+definition "tmL1 \<equiv> tm_nextract \<sharp> j1 (j3 + 1)"
+definition "tmL2 \<equiv> tmL1 ;; tm_sat_clause j2 (j3 + 1) (j3 + 2)"
+definition "tmI \<equiv> IF \<lambda>rs. rs ! (j3 + 2) = \<box> THEN tm_setn j3 0 ELSE [] ENDIF"
+definition "tmL3 \<equiv> tmL2 ;; tmI"
+definition "tmL4 \<equiv> tmL3 ;; tm_erase_cr (j3 + 1)"
+definition "tmL5 \<equiv> tmL4 ;; tm_setn (j3 + 2) 0"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO tmL5 DONE"
+
+definition "tm2 \<equiv> tm1 ;; tmL"
+
+lemma tm2_eq_tm_sat_formula: "tm2 = tm_sat_formula j1 j2 j3"
+  unfolding tm2_def tm1_def tmL_def tmL5_def tmL4_def tmL3_def tmI_def tmL2_def tmL1_def tm_sat_formula_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and vars :: "nat list" and \<phi> :: formula
+  assumes jk: "0 < j1" "j1 \<noteq> j2" "j3 + 7 < k" "j1 < j3" "j2 < j3" "0 < j2" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = nlltape' (formula_n \<phi>) 0"
+    "tps0 ! j2 = nltape' vars 0"
+    "tps0 ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 1) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps0 ! (j3 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 6) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps0 ! (j3 + 7) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j3 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 12"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps0 tps1_def jk)
+  show "ttt = 10 + 2 * nlength 0 + 2 * nlength 1"
+    using assms nlength_1_simp by simp
+qed
+
+abbreviation "sat_take t \<equiv> (\<lambda>v. v \<in> set vars) \<Turnstile> take t \<phi>"
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [j1 := nlltape' (formula_n \<phi>) t,
+     j3 := (\<lfloor>sat_take t\<rfloor>\<^sub>B, 1)]"
+
+lemma tpsL0: "tpsL 0 = tps1"
+proof -
+  have "nlltape' (formula_n \<phi>) 0 = tps1 ! j1"
+    using tps0(1) tps1_def jk by simp
+  moreover have "\<lfloor>sat_take 0\<rfloor>\<^sub>B = \<lfloor>1\<rfloor>\<^sub>N"
+    using satisfies_def by simp
+  ultimately show ?thesis
+    using tpsL_def tps0 jk tps1_def by (metis list_update_id)
+qed
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+  "tpsL1 t \<equiv> tps0
+    [j1 := nlltape' (formula_n \<phi>) (Suc t),
+     j3 := (\<lfloor>sat_take t\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>formula_n \<phi> ! t\<rfloor>\<^sub>N\<^sub>L, 1)]"
+
+lemma tmL1 [transforms_intros]:
+  assumes "ttt = 12 + 2 * nllength (formula_n \<phi> ! t)" and "t < length (formula_n \<phi>)"
+  shows "transforms tmL1 (tpsL t) ttt (tpsL1 t)"
+  unfolding tmL1_def
+proof (tform tps: assms tps0 tpsL_def tpsL1_def jk)
+  show "ttt = 12 + 2 * nllength [] + 2 * nllength (formula_n \<phi> ! t)"
+    using assms(1) by simp
+  show "tpsL1 t = (tpsL t)
+    [j1 := nlltape' (formula_n \<phi>) (Suc t),
+     j3 + 1 := (\<lfloor>formula_n \<phi> ! t\<rfloor>\<^sub>N\<^sub>L, 1)]"
+    using tpsL1_def tpsL_def jk by (simp add: list_update_swap)
+qed
+
+definition tpsL2 :: "nat \<Rightarrow> tape list" where
+  "tpsL2 t \<equiv> tps0
+    [j1 := nlltape' (formula_n \<phi>) (Suc t),
+     j3 := (\<lfloor>sat_take t\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>formula_n \<phi> ! t\<rfloor>\<^sub>N\<^sub>L, 1),
+     j3 + 2 := (\<lfloor>satisfies_clause (\<lambda>v. v \<in> set vars) (\<phi> ! t)\<rfloor>\<^sub>B, 1)]"
+
+lemma tmL2 [transforms_intros]:
+  assumes "ttt = 12 + 2 * nllength (formula_n \<phi> ! t) +
+    (79 * (nllength (formula_n \<phi> ! t))\<^sup>2 +
+     67 * nllength (formula_n \<phi> ! t) * (nllength vars)\<^sup>2 + 4)"
+    and "t < length (formula_n \<phi>)"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL2 t)"
+  unfolding tmL2_def
+proof (tform tps: assms tps0 tpsL_def tpsL1_def jk)
+  let ?clause = "\<phi> ! t"
+  have *: "formula_n \<phi> ! t = clause_n ?clause"
+    using assms(2) formula_n_def by simp
+  then have "(\<lfloor>formula_n \<phi> ! t\<rfloor>\<^sub>N\<^sub>L, 1) = nltape' (clause_n ?clause) 0"
+    by simp
+  then show "tpsL1 t ! (j3 + 1) = nltape' (clause_n ?clause) 0"
+    using tpsL1_def jk by simp
+  have "j3 + 2 + 1 = j3 + 3"
+    by simp
+  moreover have "tpsL1 t ! (j3 + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL1_def tps0 jk by simp
+  ultimately show "tpsL1 t ! (j3 + 2 + 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    by metis
+  have "j3 + 2 + 2 = j3 + 4"
+    by simp
+  moreover have "tpsL1 t ! (j3 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL1_def tps0 jk by simp
+  ultimately show "tpsL1 t ! (j3 + 2 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    by metis
+  have "j3 + 2 + 3 = j3 + 5"
+    by simp
+  moreover have "tpsL1 t ! (j3 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL1_def tps0 jk by simp
+  ultimately show "tpsL1 t ! (j3 + 2 + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    by metis
+  have "j3 + 2 + 4 = j3 + 6"
+    by simp
+  moreover have "tpsL1 t ! (j3 + 6) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL1_def tps0 jk by simp
+  ultimately show "tpsL1 t ! (j3 + 2 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    by metis
+  have "j3 + 2 + 5 = j3 + 7"
+    by simp
+  moreover have "tpsL1 t ! (j3 + 7) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsL1_def tps0 jk by simp
+  ultimately show "tpsL1 t ! (j3 + 2 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    by metis
+  show "tpsL2 t = (tpsL1 t)
+      [j3 + 2 := (\<lfloor>satisfies_clause (\<lambda>v. v \<in> set vars) (\<phi> ! t)\<rfloor>\<^sub>B, 1)]"
+    unfolding tpsL2_def tpsL1_def by simp
+  show "ttt = 12 + 2 * nllength (formula_n \<phi> ! t) +
+      (79 * (nllength (clause_n (\<phi> ! t)))\<^sup>2 +
+       67 * nllength (clause_n (\<phi> ! t)) * (nllength vars)\<^sup>2 + 4)"
+    using assms(1) * by simp
+qed
+
+definition tpsL3 :: "nat \<Rightarrow> tape list" where
+  "tpsL3 t \<equiv> tps0
+    [j1 := nlltape' (formula_n \<phi>) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>formula_n \<phi> ! t\<rfloor>\<^sub>N\<^sub>L, 1),
+     j3 + 2 := (\<lfloor>satisfies_clause (\<lambda>v. v \<in> set vars) (\<phi> ! t)\<rfloor>\<^sub>B, 1)]"
+
+lemma tmI [transforms_intros]:
+  assumes "ttt = 16" and "t < length (formula_n \<phi>)"
+  shows "transforms tmI (tpsL2 t) ttt (tpsL3 t)"
+  unfolding tmI_def
+proof (tform tps: assms(2) tps0 tpsL2_def tpsL3_def jk time: assms(1))
+  show "10 + 2 * nlength (if sat_take t then 1 else 0) + 2 * nlength 0 + 2 \<le> ttt"
+    using assms(1) nlength_1_simp by simp
+
+  let ?a = "\<lambda>v. v \<in> set vars"
+  let ?cl = "\<phi> ! t"
+  have *: "read (tpsL2 t) ! (j3 + 2) \<noteq> \<box> \<longleftrightarrow> satisfies_clause ?a ?cl"
+    using tpsL2_def jk read_ncontents_eq_0[of "tpsL2 t" "j3 + 2"] by force
+
+  have len: "t < length \<phi>"
+    using assms(2) by (simp add: formula_n_def)
+  have **: "sat_take (Suc t) \<longleftrightarrow> sat_take t \<and> satisfies_clause ?a ?cl"
+    using satisfies_take[OF len] by simp
+
+  show "tpsL3 t = (tpsL2 t)[j3 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]" if "read (tpsL2 t) ! (j3 + 2) = \<box>"
+  proof -
+    have "(if sat_take (Suc t) then 1::nat else 0) = 0"
+      using that * ** by simp
+    then show ?thesis
+      unfolding tpsL3_def tpsL2_def using that by (simp add: list_update_swap)
+  qed
+  show "tpsL3 t = (tpsL2 t)" if "read (tpsL2 t) ! (j3 + 2) \<noteq> \<box>"
+  proof -
+    have "sat_take t = sat_take (Suc t)"
+      using * ** that by simp
+    then show ?thesis
+      unfolding tpsL3_def tpsL2_def using that by (simp add: list_update_swap)
+  qed
+qed
+
+lemma tmL3 [transforms_intros]:
+  assumes "ttt = 32 + 2 * nllength (formula_n \<phi> ! t) +
+      79 * (nllength (formula_n \<phi> ! t))\<^sup>2 +
+      67 * nllength (formula_n \<phi> ! t) * (nllength vars)\<^sup>2"
+    and "t < length (formula_n \<phi>)"
+  shows "transforms tmL3 (tpsL t) ttt (tpsL3 t)"
+  unfolding tmL3_def by (tform tps: assms)
+
+definition tpsL4 :: "nat \<Rightarrow> tape list" where
+  "tpsL4 t \<equiv> tps0
+    [j1 := nlltape' (formula_n \<phi>) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+     j3 + 2 := (\<lfloor>satisfies_clause (\<lambda>v. v \<in> set vars) (\<phi> ! t)\<rfloor>\<^sub>B, 1)]"
+
+lemma tmL4 [transforms_intros]:
+  assumes "ttt = 39 + 4 * nllength (formula_n \<phi> ! t) +
+      79 * (nllength (formula_n \<phi> ! t))\<^sup>2 +
+      67 * nllength (formula_n \<phi> ! t) * (nllength vars)\<^sup>2"
+    and "t < length (formula_n \<phi>)"
+  shows "transforms tmL4 (tpsL t) ttt (tpsL4 t)"
+  unfolding tmL4_def
+proof (tform tps: assms(2) tps0 tpsL3_def tpsL4_def jk)
+  let ?zs = "numlist (formula_n \<phi> ! t)"
+  have *: "tpsL3 t ! (j3 + 1) = (\<lfloor>formula_n \<phi> ! t\<rfloor>\<^sub>N\<^sub>L, 1)"
+    using tpsL3_def jk by simp
+  then show "tpsL3 t ::: (j3 + 1) = \<lfloor>?zs\<rfloor>"
+    using nlcontents_def by simp
+  show "proper_symbols ?zs"
+    using proper_symbols_numlist by simp
+  show "tpsL4 t = (tpsL3 t)[j3 + 1 := (\<lfloor>[]\<rfloor>, 1)]"
+    unfolding tpsL4_def tpsL3_def using nlcontents_Nil by (simp add: list_update_swap)
+  show "ttt = 32 + 2 * nllength (formula_n \<phi> ! t) +
+      79 * (nllength (formula_n \<phi> ! t))\<^sup>2 +
+      67 * nllength (formula_n \<phi> ! t) * (nllength vars)\<^sup>2 +
+      (tpsL3 t :#: (j3 + 1) + 2 * length (numlist (formula_n \<phi> ! t)) + 6)"
+    using * assms(1) nllength_def by simp
+qed
+
+definition tpsL5 :: "nat \<Rightarrow> tape list" where
+  "tpsL5 t \<equiv> tps0
+    [j1 := nlltape' (formula_n \<phi>) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1),
+     j3 + 2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL5:
+  assumes "ttt = 49 + 4 * nllength (formula_n \<phi> ! t) +
+      79 * (nllength (formula_n \<phi> ! t))\<^sup>2 +
+      67 * nllength (formula_n \<phi> ! t) * (nllength vars)\<^sup>2 +
+      2 * nlength (if satisfies_clause (\<lambda>v. v \<in> set vars) (\<phi> ! t) then 1 else 0)"
+    and "t < length (formula_n \<phi>)"
+  shows "transforms tmL5 (tpsL t) ttt (tpsL5 t)"
+  unfolding tmL5_def by (tform tps: assms tps0 tpsL4_def tpsL5_def jk)
+
+definition tpsL5' :: "nat \<Rightarrow> tape list" where
+  "tpsL5' t \<equiv> tps0
+    [j1 := nlltape' (formula_n \<phi>) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1)]"
+
+lemma tpsL5': "tpsL5' = tpsL5"
+proof
+  fix t
+  have 5: "j1 \<noteq> j3 + 1"
+    using jk by simp
+  have 4: "j3 \<noteq> j3 + 1"
+    by simp
+  have 1: "j3 \<noteq> j3 + 2"
+    by simp
+  have 2: "j3 + 1 \<noteq> j3 + 2"
+    by simp
+  have 22: "Suc j3 \<noteq> Suc (Suc j3)"
+    by simp
+  have 3: "j1 \<noteq> j3 + 2"
+    using jk by simp
+  let ?tps1 = "tps0
+    [j1 := nlltape' (formula_n \<phi>) (Suc t)]"
+  let ?tps2 = "tps0
+    [j1 := nlltape' (formula_n \<phi>) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1)]"
+  have "tpsL5 t = tps0
+    [j1 := nlltape' (formula_n \<phi>) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1),
+     j3 + 1 := (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)]"
+    unfolding tpsL5_def
+    using tps0(5)
+      list_update_swap[OF 2, of ?tps2]
+      list_update_swap[OF 1, of ?tps1]
+      list_update_swap[OF 3, of tps0]
+      list_update_id[of tps0 "j3 + 2"]
+    by (simp only:)
+  also have "... = tps0
+    [j1 := nlltape' (formula_n \<phi>) (Suc t),
+     j3 := (\<lfloor>sat_take (Suc t)\<rfloor>\<^sub>B, 1)]"
+    using tps0(4)
+      list_update_swap[OF 4, of ?tps1]
+      list_update_swap[OF 5, of tps0]
+      list_update_id[of tps0 "j3 + 1"]
+    by (simp only:)
+  finally show "tpsL5' t = tpsL5 t"
+    using tpsL5'_def by simp
+qed
+
+lemma tmL5' [transforms_intros]:
+  assumes "ttt = 51 + 83 * (nlllength (formula_n \<phi>))\<^sup>2 +
+      67 * nlllength (formula_n \<phi>) * (nllength vars)\<^sup>2"
+    and "t < length (formula_n \<phi>)"
+  shows "transforms tmL5 (tpsL t) ttt (tpsL5' t)"
+proof -
+  let ?ttt = "49 + 4 * nllength (formula_n \<phi> ! t) +
+      79 * (nllength (formula_n \<phi> ! t))\<^sup>2 +
+      67 * nllength (formula_n \<phi> ! t) * (nllength vars)\<^sup>2 +
+      2 * nlength (if satisfies_clause (\<lambda>v. v \<in> set vars) (\<phi> ! t) then 1 else 0)"
+  have "?ttt \<le> 49 + 4 * nllength (formula_n \<phi> ! t) +
+      79 * (nllength (formula_n \<phi> ! t))\<^sup>2 +
+      67 * nllength (formula_n \<phi> ! t) * (nllength vars)\<^sup>2 +
+      2 * nlength 1"
+    by simp
+  also have "... = 51 + 4 * nllength (formula_n \<phi> ! t) +
+      79 * (nllength (formula_n \<phi> ! t))\<^sup>2 +
+      67 * nllength (formula_n \<phi> ! t) * (nllength vars)\<^sup>2"
+    using nlength_1_simp by simp
+  also have "... \<le> 51 + 4 * nlllength (formula_n \<phi>) +
+      79 * (nllength (formula_n \<phi> ! t))\<^sup>2 +
+      67 * nllength (formula_n \<phi> ! t) * (nllength vars)\<^sup>2"
+    using member_le_nlllength_1[of "formula_n \<phi> ! t" "formula_n \<phi>"] assms(2) by simp
+  also have "... \<le> 51 + 4 * nlllength (formula_n \<phi>) +
+      79 * (nlllength (formula_n \<phi>))\<^sup>2 +
+      67 * nllength (formula_n \<phi> ! t) * (nllength vars)\<^sup>2"
+    using member_le_nlllength_1[of "formula_n \<phi> ! t" "formula_n \<phi>"] assms(2) by simp
+  also have "... \<le> 51 + 4 * nlllength (formula_n \<phi>) +
+      79 * (nlllength (formula_n \<phi>))\<^sup>2 +
+      67 * nlllength (formula_n \<phi>) * (nllength vars)\<^sup>2"
+    using member_le_nlllength_1[of "formula_n \<phi> ! t" "formula_n \<phi>"] assms(2) by auto
+  also have "... \<le> 51 + 83 * (nlllength (formula_n \<phi>))\<^sup>2 +
+      67 * nlllength (formula_n \<phi>) * (nllength vars)\<^sup>2"
+    using linear_le_pow by simp
+  finally have "?ttt \<le> ttt"
+    using assms(1) by simp
+  then show ?thesis
+    using tpsL5' transforms_monotone[OF tmL5] assms by simp
+qed
+
+lemma tmL [transforms_intros]:
+  assumes "ttt = length (formula_n \<phi>) * (53 + 83 * (nlllength (formula_n \<phi>))\<^sup>2 + 67 * nlllength (formula_n \<phi>) * (nllength vars)\<^sup>2) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (length (formula_n \<phi>)))"
+  unfolding tmL_def
+proof (tform)
+  let ?t = "51 + 83 * (nlllength (formula_n \<phi>))\<^sup>2 + 67 * nlllength (formula_n \<phi>) * (nllength vars)\<^sup>2"
+  have "tpsL5' t = tpsL (Suc t)" for t
+    using tpsL5'_def tpsL_def by simp
+  then show "\<And>t. t < length (formula_n \<phi>) \<Longrightarrow> transforms tmL5 (tpsL t) ?t (tpsL (Suc t))"
+    using tmL5' by simp
+
+  let ?nss = "formula_n \<phi>"
+  have *: "tpsL t ! j1 = nlltape' ?nss t" for t
+    using tpsL_def jk by simp
+  moreover have "read (tpsL t) ! j1 = tpsL t :.: j1" for t
+    using tapes_at_read'[of j1 "tpsL t"] tpsL_def jk by simp
+  ultimately have "read (tpsL t) ! j1 = |.| (nlltape' ?nss t)" for t
+    by simp
+  then have "read (tpsL t) ! j1 = \<box> \<longleftrightarrow> (t \<ge> length ?nss)" for t
+    using nlltape'_tape_read by simp
+  then show
+      "\<And>i. i < length ?nss \<Longrightarrow> read (tpsL i) ! j1 \<noteq> \<box>"
+      "\<not> read (tpsL (length ?nss)) ! j1 \<noteq> \<box>"
+    using * by simp_all
+  show "length (formula_n \<phi>) * (?t + 2) + 1 \<le> ttt"
+    using assms by simp
+qed
+
+lemma tm2:
+  assumes "ttt = length (formula_n \<phi>) * (53 + 83 * (nlllength (formula_n \<phi>))\<^sup>2 + 67 * nlllength (formula_n \<phi>) * (nllength vars)\<^sup>2) + 13"
+  shows "transforms tm2 tps0 ttt (tpsL (length (formula_n \<phi>)))"
+  unfolding tm2_def
+proof (tform tps: assms tps0 tpsL4_def tpsL5_def jk tpsL0)
+  show "transforms tm1 tps0 12 (tpsL 0)"
+    using tm1 tpsL0 by simp
+qed
+
+definition tps2 :: "tape list" where
+  "tps2 \<equiv> tps0
+    [j1 := nlltape (formula_n \<phi>),
+     j3 := (\<lfloor>(\<lambda>v. v \<in> set vars) \<Turnstile> \<phi>\<rfloor>\<^sub>B, 1)]"
+
+lemma tps2: "tps2 = tpsL (length (formula_n \<phi>))"
+  using formula_n_def tps2_def tpsL_def by simp
+
+lemma tm2':
+  assumes "ttt = length (formula_n \<phi>) * (53 + 83 * (nlllength (formula_n \<phi>))\<^sup>2 + 67 * nlllength (formula_n \<phi>) * (nllength vars)\<^sup>2) + 13"
+  shows "transforms tm2 tps0 ttt tps2"
+  using tm2 tps2 assms by simp
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_sat_formulaI [transforms_intros]:
+  fixes j1 j2 j3 :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k :: nat and vars :: "nat list" and \<phi> :: formula
+  assumes "0 < j1" "j1 \<noteq> j2" "j3 + 7 < k" "j1 < j3" "j2 < j3" "0 < j2" "length tps = k"
+  assumes
+    "tps ! j1 = nlltape' (formula_n \<phi>) 0"
+    "tps ! j2 = nltape' vars 0"
+    "tps ! j3 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 1) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    "tps ! (j3 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 6) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tps ! (j3 + 7) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "tps' = tps
+    [j1 := nlltape (formula_n \<phi>),
+     j3 := (\<lfloor>(\<lambda>v. v \<in> set vars) \<Turnstile> \<phi>\<rfloor>\<^sub>B, 1)]"
+  assumes "ttt = length (formula_n \<phi>) * (53 + 83 * (nlllength (formula_n \<phi>))\<^sup>2 + 67 * nlllength (formula_n \<phi>) * (nllength vars)\<^sup>2) + 13"
+  shows "transforms (tm_sat_formula j1 j2 j3) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_sat_formula j1 j2 j3 .
+  show ?thesis
+    using assms loc.tps2_def loc.tm2' loc.tm2_eq_tm_sat_formula by metis
+qed
+
+
+subsection \<open>A Turing machine for verifying \SAT{} instances\<close>
+
+text \<open>
+The previous Turing machine, @{const tm_sat_formula}, expects a well-formed
+formula and a well-formed list representing an assignment on its tapes. The TM
+we ultimately need, however, is not guaranteed to be given anything well-formed
+as input and even the well-formed inputs require decoding from the binary
+alphabet to the quaternary alphabet used for lists of lists of numbers. The next
+TM takes care of all of that and, if everything was well-formed, runs @{const
+tm_sat_formula}. If the first element of the pair input is invalid, it outputs
+\textbf{1}, as required by the definition of \SAT{}.
+
+Thus, the next Turing machine implements the function @{const verify_sat} and
+therefore is a verifier for \SAT.
+\<close>
+
+definition tm_verify_sat :: machine where
+  "tm_verify_sat \<equiv>
+    tm_right_many {0..<22} ;;
+    tm_bindecode 0 2 ;;
+    tm_unpair 2 3 4 ;;
+    tm_even_length 3 5 ;;
+    tm_proper_symbols_lt 3 6 4 ;;
+    tm_and 6 5 ;;
+    IF \<lambda>rs. rs ! 6 \<noteq> \<box> THEN
+      tm_bindecode 3 7 ;;
+      tm_numlistlist_wf 7 8 ;;
+      IF \<lambda>rs. rs ! 8 \<noteq> \<box> THEN
+        tm_proper_symbols_lt 4 10 4 ;;
+        IF \<lambda>rs. rs ! 10 \<noteq> \<box> THEN
+          tm_bindecode 4 11 ;;
+          tm_rstrip \<sharp> 11 ;;
+          tm_numlist_wf 11 12 ;;
+          IF \<lambda>rs. rs ! 12 \<noteq> \<box> THEN
+            tm_sat_formula 7 11 14 ;;
+            tm_copyn 14 1
+          ELSE
+            []
+          ENDIF
+        ELSE
+          []
+        ENDIF
+      ELSE
+        tm_setn 1 1
+      ENDIF
+    ELSE
+      tm_setn 1 1
+    ENDIF"
+
+lemma tm_verify_sat_tm: "turing_machine 22 6 tm_verify_sat"
+  unfolding tm_verify_sat_def
+  using tm_copyn_tm tm_setn_tm turing_machine_branch_turing_machine tm_sat_formula_tm tm_bindecode_tm
+    tm_rstrip_tm tm_numlist_wf_tm tm_proper_symbols_lt_tm tm_numlistlist_wf_tm Nil_tm
+    tm_right_many_tm tm_unpair_tm tm_even_length_tm tm_and_tm
+  by simp
+
+locale turing_machine_verify_sat
+begin
+
+definition "tm1 \<equiv> tm_right_many {0..<22}"
+definition "tm2 \<equiv> tm1 ;; tm_bindecode 0 2"
+definition "tm3 \<equiv> tm2 ;; tm_unpair 2 3 4"
+definition "tm4 \<equiv> tm3 ;; tm_even_length 3 5"
+definition "tm5 \<equiv> tm4 ;; tm_proper_symbols_lt 3 6 4"
+definition "tm6 \<equiv> tm5 ;; tm_and 6 5"
+
+definition "tmTTT1 \<equiv> tm_bindecode 4 11"
+definition "tmTTT2 \<equiv> tmTTT1 ;; tm_rstrip \<sharp> 11"
+definition "tmTTT3 \<equiv> tmTTT2 ;; tm_numlist_wf 11 12"
+
+definition "tmTTTT1 \<equiv> tm_sat_formula 7 11 14"
+definition "tmTTTT2 \<equiv> tmTTTT1 ;; tm_copyn 14 1"
+definition "tmTTTI \<equiv> IF \<lambda>rs. rs ! 12 \<noteq> \<box> THEN tmTTTT2 ELSE [] ENDIF"
+
+definition "tmTTT \<equiv> tmTTT3 ;; tmTTTI"
+definition "tmTTI \<equiv> IF \<lambda>rs. rs ! 10 \<noteq> \<box> THEN tmTTT ELSE [] ENDIF"
+
+definition "tmTT1 \<equiv> tm_proper_symbols_lt 4 10 4"
+definition "tmTT \<equiv> tmTT1 ;; tmTTI"
+definition "tmTI \<equiv> IF \<lambda>rs. rs ! 8 \<noteq> \<box> THEN tmTT ELSE tm_setn 1 1 ENDIF"
+
+definition "tmT1 \<equiv> tm_bindecode 3 7"
+definition "tmT2 \<equiv> tmT1 ;; tm_numlistlist_wf 7 8"
+definition "tmT \<equiv> tmT2 ;; tmTI"
+
+definition "tmI \<equiv> IF \<lambda>rs. rs ! 6 \<noteq> \<box> THEN tmT ELSE tm_setn 1 1 ENDIF"
+definition "tm7 \<equiv> tm6 ;; tmI"
+
+lemma tm7_eq_tm_verify_sat: "tm7 = tm_verify_sat"
+  unfolding tm_verify_sat_def tm7_def tmI_def tmT_def tmT2_def tmTI_def tmT1_def tmTT_def tmTT1_def tmTTI_def
+    tmTTT_def tmTTT3_def tmTTTT1_def tmTTTI_def tmTTTT2_def tmTTT3_def tmTTT2_def tmTTT1_def tm6_def tm5_def
+    tm4_def tm3_def tm2_def tm1_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and zs :: "symbol list"
+  assumes zs: "bit_symbols zs"
+  assumes tps0: "tps0 = snd (start_config 22 zs)"
+begin
+
+definition "tps1 \<equiv> map (\<lambda>tp. tp |#=| 1) tps0"
+
+lemma map_upt_length: "map f xs = map (\<lambda>i. f (xs ! i)) [0..<length xs]"
+  by (smt (verit, ccfv_SIG) in_set_conv_nth length_map map_eq_conv map_nth nth_map)
+
+lemma tps1:
+  "tps1 ! 0 = (\<lfloor>zs\<rfloor>, 1)"
+  "0 < j \<Longrightarrow> j < 22 \<Longrightarrow> tps1 ! j = (\<lfloor>[]\<rfloor>, 1)"
+  "length tps1 = 22"
+  using tps0 start_config_def tps1_def by auto
+
+lemma tm1 [transforms_intros]: "transforms tm1 tps0 1 tps1"
+  unfolding tm1_def
+proof (tform tps: tps0 tps1_def)
+  have "length tps0 = 22"
+    using tps0 start_config_def by simp
+  then have "map (\<lambda>j. if j \<in> {0..<22} then tps0 ! j |+| 1 else tps0 ! j) [0..<length tps0] =
+      map (\<lambda>j. tps0 ! j |+| 1) [0..<length tps0]"
+    by simp
+  also have "... = map (\<lambda>j. tps0 ! j |#=| 1) [0..<length tps0]"
+    using tps0 \<open>length tps0 = 22\<close> start_config_pos by simp
+  also have "... = map (\<lambda>tp. tp |#=| 1) tps0"
+    using map_upt_length[of "\<lambda>tp. tp |#=| 1" tps0] by simp
+  also have "... = tps1"
+    using tps1_def by simp
+  finally show "tps1 = map (\<lambda>j. if j \<in> {0..<22} then tps0 ! j |+| 1 else tps0 ! j) [0..<length tps0]"
+    by simp
+qed
+
+definition "tps2 \<equiv> tps1
+  [2 := (\<lfloor>bindecode zs\<rfloor>, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 8 + 3 * length zs"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: assms zs tps1 tps2_def)
+
+definition "tps3 \<equiv> tps1
+  [2 := (\<lfloor>bindecode zs\<rfloor>, 1),
+   3 := (\<lfloor>first (bindecode zs)\<rfloor>, 1),
+   4 := (\<lfloor>second (bindecode zs)\<rfloor>, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 21 + 3 * length zs + 6 * length (bindecode zs)"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: assms zs tps2_def tps1 tps3_def)
+  show "proper_symbols (bindecode zs)"
+    using zs proper_bindecode by simp
+  show "ttt = 8 + 3 * length zs + (6 * length (bindecode zs) + 13)"
+    using assms by simp
+qed
+
+definition "tps4 \<equiv> tps1
+  [2 := (\<lfloor>bindecode zs\<rfloor>, 1),
+   3 := (\<lfloor>first (bindecode zs)\<rfloor>, 1),
+   4 := (\<lfloor>second (bindecode zs)\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first (bindecode zs)))\<rfloor>\<^sub>B, 1)]"
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 28 + 3 * length zs + 6 * length (bindecode zs) + 7 * length (first (bindecode zs))"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: assms zs tps1 tps3_def tps4_def)
+  show "proper_symbols (first (bindecode zs))"
+    using zs proper_bindecode first_def by simp
+  show "tps3 ! 5 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps3_def canrepr_0 tps1 by simp
+qed
+
+definition "tps5 \<equiv> tps1
+  [2 := (\<lfloor>bindecode zs\<rfloor>, 1),
+   3 := (\<lfloor>first (bindecode zs)\<rfloor>, 1),
+   4 := (\<lfloor>second (bindecode zs)\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first (bindecode zs)))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first (bindecode zs))\<rfloor>\<^sub>B, 1)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 33 + 3 * length zs + 6 * length (bindecode zs) + 14 * length (first (bindecode zs))"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def
+proof (tform tps: assms zs tps1 tps4_def tps5_def)
+  show "proper_symbols (first (bindecode zs))"
+    using zs proper_bindecode first_def by simp
+qed
+
+abbreviation "ys \<equiv> bindecode zs"
+abbreviation "xs \<equiv> bindecode (first ys)"
+abbreviation "vs \<equiv> rstrip 5 (bindecode (second ys))"
+
+definition "tps6 \<equiv> tps1
+  [2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1)]"
+
+lemma tm6 [transforms_intros]:
+  assumes "ttt = 36 + 3 * length zs + 6 * length (bindecode zs) + 14 * length (first (bindecode zs))"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def by (tform tps: assms zs tps1 tps5_def tps6_def)
+
+context
+  assumes bs_even: "proper_symbols_lt 4 (first ys) \<and> even (length (first ys))"
+begin
+
+lemma bs: "bit_symbols (first ys)"
+    using bs_even by fastforce
+
+definition "tpsT1 \<equiv> tps1
+  [2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1),
+   7 := (\<lfloor>bindecode (first ys)\<rfloor>, 1)]"
+
+lemma tmT1 [transforms_intros]:
+  assumes "ttt = 7 + 3 * length (first ys)"
+  shows "transforms tmT1 tps6 ttt tpsT1"
+  unfolding tmT1_def by (tform tps: assms bs tps1 tps6_def tpsT1_def)
+
+definition "tpsT2 \<equiv> tps1
+  [2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1),
+   7 := (\<lfloor>bindecode (first ys)\<rfloor>, 1),
+   8 := (\<lfloor>numlistlist_wf (bindecode (first ys))\<rfloor>\<^sub>B, 1)]"
+
+lemma tmT2 [transforms_intros]:
+  assumes "ttt = 213 + 3 * length (first ys) + 39 * length (bindecode (first ys))"
+  shows "transforms tmT2 tps6 ttt tpsT2"
+  unfolding tmT2_def
+proof (tform tps: assms tps1 tpsT1_def tpsT2_def)
+  show "proper_symbols (bindecode (first ys))"
+    using proper_bindecode by simp
+  show "ttt = 7 + 3 * length (first ys) + (206 + 39 * length (bindecode (first ys)))"
+    using assms by simp
+qed
+
+context
+  assumes first_wf: "numlistlist_wf (bindecode (first ys))"
+begin
+
+definition "tpsTT1 \<equiv> tps1
+  [2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1),
+   7 := (\<lfloor>bindecode (first ys)\<rfloor>, 1),
+   8 := (\<lfloor>numlistlist_wf (bindecode (first ys))\<rfloor>\<^sub>B, 1),
+   10 := (\<lfloor>proper_symbols_lt 4 (second ys)\<rfloor>\<^sub>B, 1)]"
+
+lemma tmTT1 [transforms_intros]:
+  assumes "ttt = 5 + 7 * length (second ys)"
+  shows "transforms tmTT1 tpsT2 ttt tpsTT1"
+  unfolding tmTT1_def
+proof (tform tps: tps1 tpsT2_def tpsTT1_def assms)
+  show "proper_symbols (second ys)"
+    using proper_bindecode second_def zs by simp
+qed
+
+context
+  assumes proper_second: "proper_symbols_lt 4 (second ys)"
+begin
+
+definition "tpsTTT1 \<equiv> tps1
+  [2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1),
+   7 := (\<lfloor>xs\<rfloor>, 1),
+   8 := (\<lfloor>numlistlist_wf xs\<rfloor>\<^sub>B, 1),
+   10 := (\<lfloor>proper_symbols_lt 4 (second ys)\<rfloor>\<^sub>B, 1),
+   11 := (\<lfloor>bindecode (second ys)\<rfloor>, 1)]"
+
+lemma tmTTT1 [transforms_intros]:
+  assumes "ttt = 7 + 3 * length (second ys)"
+  shows "transforms tmTTT1 tpsTT1 ttt tpsTTT1"
+  unfolding tmTTT1_def
+proof (tform tps: assms tps1 tpsT2_def tpsTT1_def tpsTTT1_def)
+  show "bit_symbols (second ys)"
+    using proper_second by fastforce
+qed
+
+definition "tpsTTT2 \<equiv> tps1
+  [2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1),
+   7 := (\<lfloor>xs\<rfloor>, 1),
+   8 := (\<lfloor>numlistlist_wf xs\<rfloor>\<^sub>B, 1),
+   10 := (\<lfloor>proper_symbols_lt 4 (second ys)\<rfloor>\<^sub>B, 1),
+   11 := (\<lfloor>vs\<rfloor>, 1)]"
+
+lemma tmTTT2 [transforms_intros]:
+  assumes "ttt = 12 + 3 * length (second ys) + 3 * length (bindecode (second ys))"
+  shows "transforms tmTTT2 tpsTT1 ttt tpsTTT2"
+  unfolding tmTTT2_def
+proof (tform tps: assms tps1 tpsTTT1_def tpsTTT2_def)
+  show "proper_symbols (bindecode (second ys))"
+    using proper_bindecode by simp
+  show "ttt = 7 + 3 * length (second ys) + (3 * length (bindecode (second ys)) + 5)"
+    using assms by simp
+qed
+
+definition "tpsTTT3 \<equiv> tps1
+  [2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1),
+   7 := (\<lfloor>xs\<rfloor>, 1),
+   8 := (\<lfloor>numlistlist_wf xs\<rfloor>\<^sub>B, 1),
+   10 := (\<lfloor>proper_symbols_lt 4 (second ys)\<rfloor>\<^sub>B, 1),
+   11 := (\<lfloor>vs\<rfloor>, 1),
+   12 := (\<lfloor>numlist_wf vs\<rfloor>\<^sub>B, 1)]"
+
+lemma tmTTT3 [transforms_intros]:
+  assumes "ttt = 106 + 3 * length (second ys) + 3 * length (bindecode (second ys)) + 19 * length vs"
+  shows "transforms tmTTT3 tpsTT1 ttt tpsTTT3"
+  unfolding tmTTT3_def
+proof (tform tps: assms tps1 tpsTTT2_def tpsTTT3_def)
+  show "proper_symbols vs"
+    using proper_bindecode rstrip_def by simp
+qed
+
+context
+  assumes second_wf: "numlist_wf vs"
+begin
+
+definition "tpsTTTT1 \<equiv> tps1
+  [2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1),
+   7 := (\<lfloor>xs\<rfloor>, 1),
+   8 := (\<lfloor>numlistlist_wf xs\<rfloor>\<^sub>B, 1),
+   10 := (\<lfloor>proper_symbols_lt 4 (second ys)\<rfloor>\<^sub>B, 1),
+   11 := (\<lfloor>vs\<rfloor>, 1),
+   12 := (\<lfloor>numlist_wf vs\<rfloor>\<^sub>B, 1),
+   7 := nlltape (formula_n (zs_formula xs)),
+   14 := (\<lfloor>(\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs\<rfloor>\<^sub>B, 1)]"
+
+lemma tmTTTT1 [transforms_intros]:
+  assumes "ttt = length (formula_n (zs_formula xs)) *
+    (53 + 83 * (nlllength (formula_n (zs_formula xs)))\<^sup>2 + 67 * nlllength (formula_n (zs_formula xs)) * (nllength (zs_numlist vs))\<^sup>2) +
+    13"
+  shows "transforms tmTTTT1 tpsTTT3 ttt tpsTTTT1"
+  unfolding tmTTTT1_def
+proof (tform time: assms)
+  show
+    "tpsTTT3 ! 14 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tpsTTT3 ! (14 + 2) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tpsTTT3 ! (14 + 3) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tpsTTT3 ! (14 + 4) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tpsTTT3 ! (14 + 5) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tpsTTT3 ! (14 + 6) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    "tpsTTT3 ! (14 + 7) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    unfolding tpsTTT3_def using tps1 canrepr_0 by auto
+  show "tpsTTT3 ! (14 + 1) = (\<lfloor>[]\<rfloor>\<^sub>N\<^sub>L, 1)"
+    unfolding tpsTTT3_def using tps1 nlcontents_Nil by simp
+  show "14 + 7 < length tpsTTT3"
+    unfolding tpsTTT3_def using tps1 by simp
+  let ?phi = "zs_formula xs"
+  have "numlistlist (formula_n ?phi) = xs"
+    using formula_zs_def formula_zs_formula first_wf by simp
+  then have "nlltape' (formula_n ?phi) 0 = (\<lfloor>xs\<rfloor>, 1)"
+    by (simp add: nllcontents_def)
+  then show "tpsTTT3 ! 7 = nlltape' (formula_n ?phi) 0"
+    unfolding tpsTTT3_def using tps1 by simp
+  let ?vars = "zs_numlist vs"
+  have "numlist ?vars = vs"
+    using numlist_zs_numlist second_wf by simp
+  then have "nltape' ?vars 0 = (\<lfloor>vs\<rfloor>, 1)"
+    by (simp add: nlcontents_def)
+  then show "tpsTTT3 ! 11 = nltape' ?vars 0"
+    unfolding tpsTTT3_def using tps1 by simp
+  show "tpsTTTT1 = tpsTTT3
+    [7 := nlltape (formula_n (zs_formula xs)),
+     14 := (\<lfloor>(\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs\<rfloor>\<^sub>B, 1)]"
+    unfolding tpsTTTT1_def tpsTTT3_def by fast
+qed
+
+definition "tpsTTTT2 \<equiv> tps1
+  [1 := (\<lfloor>(\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs\<rfloor>\<^sub>B, 1),
+   2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1),
+   7 := (\<lfloor>xs\<rfloor>, 1),
+   8 := (\<lfloor>numlistlist_wf xs\<rfloor>\<^sub>B, 1),
+   10 := (\<lfloor>proper_symbols_lt 4 (second ys)\<rfloor>\<^sub>B, 1),
+   11 := (\<lfloor>vs\<rfloor>, 1),
+   12 := (\<lfloor>numlist_wf vs\<rfloor>\<^sub>B, 1),
+   7 := nlltape (formula_n (zs_formula xs)),
+   14 := (\<lfloor>(\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs\<rfloor>\<^sub>B, 1)]"
+
+lemma tmTTTT2:
+  assumes "ttt = length (formula_n (zs_formula xs)) *
+    (53 + 83 * (nlllength (formula_n (zs_formula xs)))\<^sup>2 + 67 * nlllength (formula_n (zs_formula xs)) * (nllength (zs_numlist vs))\<^sup>2) +
+    27 + 3 * (nlength (if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then 1 else 0))"
+  shows "transforms tmTTTT2 tpsTTT3 ttt tpsTTTT2"
+  unfolding tmTTTT2_def
+proof (tform)
+  show "14 < length tpsTTTT1" "1 < length tpsTTTT1"
+    unfolding tpsTTTT1_def using tps1 by simp_all
+  show "tpsTTTT1 ! 1 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    unfolding tpsTTTT1_def using tps1 canrepr_0 by auto
+  let ?b = "if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then 1 else 0 :: nat"
+  show "tpsTTTT1 ! 14 = (\<lfloor>?b\<rfloor>\<^sub>N, 1)"
+    unfolding tpsTTTT1_def using tps1 by simp
+  show "ttt = length (formula_n (zs_formula xs)) *
+      (53 + 83 * (nlllength (formula_n (zs_formula xs)))\<^sup>2 +
+       67 * nlllength (formula_n (zs_formula xs)) * (nllength (zs_numlist vs))\<^sup>2) +
+      13 + (14 + 3 *
+      (nlength (if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then 1 else 0) + nlength 0))"
+    using assms by simp
+  show "tpsTTTT2 = tpsTTTT1
+      [1 := (\<lfloor>(\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs\<rfloor>\<^sub>B, 1)]"
+    unfolding tpsTTTT2_def tpsTTTT1_def by (simp add: list_update_swap)
+qed
+
+lemma tmTTTT2' [transforms_intros]:
+  assumes "ttt = 203 * length zs ^ 4 + 30"
+  shows "transforms tmTTTT2 tpsTTT3 ttt tpsTTTT2"
+proof -
+  let ?phi = "zs_formula xs"
+  let ?ttt = "length (formula_n ?phi) *
+    (53 + 83 * (nlllength (formula_n ?phi))\<^sup>2 + 67 * nlllength (formula_n ?phi) * (nllength (zs_numlist vs))\<^sup>2) +
+    27 + 3 * (nlength (if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> ?phi then 1 else 0))"
+  have "nlllength (formula_n ?phi) \<le> length xs"
+    using formula_zs_def formula_zs_formula first_wf nlllength_def by simp
+  then have 1: "nlllength (formula_n ?phi) \<le> length zs"
+    by (metis div_le_dividend le_trans length_bindecode length_first)
+  moreover have "length (formula_n ?phi) \<le> nlllength (formula_n ?phi)"
+    by (simp add: length_le_nlllength)
+  ultimately have 2: "length (formula_n ?phi) \<le> length zs"
+    by simp
+  have "nllength (zs_numlist vs) \<le> length vs"
+    using second_wf numlist_zs_numlist nllength_def by simp
+  moreover have "length vs \<le> length zs"
+    using second_def length_bindecode length_rstrip_le by (metis div_le_dividend dual_order.trans length_second)
+  ultimately have 3: "nllength (zs_numlist vs) \<le> length zs"
+    by simp
+  have 4: "nlength (if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> ?phi then 1 else 0) \<le> 1"
+    using nlength_1_simp by simp
+
+  have "?ttt \<le> length (formula_n ?phi) *
+      (53 + 83 * (nlllength (formula_n ?phi))\<^sup>2 + 67 * nlllength (formula_n ?phi) * (nllength (zs_numlist vs))\<^sup>2) + 30"
+    using 4 by simp
+  also have "... \<le> length zs *
+      (53 + 83 * (nlllength (formula_n ?phi))\<^sup>2 + 67 * nlllength (formula_n ?phi) * (nllength (zs_numlist vs))\<^sup>2) + 30"
+    using 2 by simp
+  also have "... \<le> length zs * (53 + 83 * (length zs)\<^sup>2 + 67 * length zs * (nllength (zs_numlist vs))\<^sup>2) + 30"
+    using 1 by (simp add: add_mono)
+  also have "... \<le> length zs * (53 + 83 * (length zs)\<^sup>2 + 67 * length zs * (length zs)\<^sup>2) + 30"
+    using 3 by simp
+  also have "... = 53 * length zs + 83 * length zs ^ 3 + 67 * length zs ^ 4 + 30"
+    by algebra
+  also have "... \<le> 53 * length zs + 83 * length zs ^ 4 + 67 * length zs ^ 4 + 30"
+    using pow_mono' by simp
+  also have "... \<le> 53 * length zs ^ 4 + 83 * length zs ^ 4 + 67 * length zs ^ 4 + 30"
+    using linear_le_pow by simp
+  also have "... = 203 * length zs ^ 4 + 30"
+    by simp
+  finally have "?ttt \<le> 203 * length zs ^ 4 + 30" .
+  then show ?thesis
+    using assms tmTTTT2 transforms_monotone by simp
+qed
+
+end  (* context second_wf: "numlist_wf vs" *)
+
+definition "tpsTTT \<equiv> (if numlist_wf vs then tpsTTTT2 else tpsTTT3)"
+
+lemma length_tpsTTT: "length tpsTTT = 22"
+  using tpsTTT_def tpsTTTT2_def tpsTTT3_def tps1 by (metis (no_types, lifting) length_list_update)
+
+lemma tpsTTT: "tpsTTT ! 1 =
+  (\<lfloor>if numlist_wf vs then (if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then 1 else 0) else 0\<rfloor>\<^sub>N, 1)"
+proof (cases "numlist_wf vs")
+  case True
+  then have "tpsTTT ! 1 = tpsTTTT2 ! 1"
+    using tpsTTT_def by simp
+  also have "... = (\<lfloor>(\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs\<rfloor>\<^sub>B, 1)"
+    unfolding tpsTTTT2_def[OF True] using tps1 by simp
+  finally show ?thesis
+    using True by simp
+next
+  case False
+  then have "tpsTTT ! 1 = tpsTTT3 ! 1"
+    using tpsTTT_def by simp
+  also have "... = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    unfolding tpsTTT3_def using tps1 canrepr_0 by simp
+  finally show ?thesis
+    using False by simp
+qed
+
+lemma tmTTTI [transforms_intros]:
+  assumes "ttt = 203 * length zs ^ 4 + 32"
+  shows "transforms tmTTTI tpsTTT3 ttt tpsTTT"
+  unfolding tmTTTI_def
+proof (tform time: assms)
+  have *: "read tpsTTT3 ! 12 \<noteq> \<box> \<longleftrightarrow> numlist_wf vs"
+    using tpsTTT3_def tps1 read_ncontents_eq_0 by simp
+  show "read tpsTTT3 ! 12 \<noteq> \<box> \<Longrightarrow> numlist_wf vs"
+    using * by simp
+  show "read tpsTTT3 ! 12 \<noteq> \<box> \<Longrightarrow> tpsTTT = tpsTTTT2"
+    using * tpsTTT_def by simp
+  show "\<not> read tpsTTT3 ! 12 \<noteq> \<box> \<Longrightarrow> tpsTTT = tpsTTT3"
+    using * tpsTTT_def by simp
+qed
+
+lemma tmTTT:
+  assumes "ttt = 138 + 3 * length (second ys) + 3 * length (bindecode (second ys)) +
+      19 * length vs + 203 * length zs ^ 4"
+  shows "transforms tmTTT tpsTT1 ttt tpsTTT"
+  unfolding tmTTT_def by (tform tps: assms)
+
+lemma tmTTT' [transforms_intros]:
+  assumes "ttt = 138 + 228 * length zs ^ 4"
+  shows "transforms tmTTT tpsTT1 ttt tpsTTT"
+proof -
+  let ?ttt = "138 + 3 * length (second ys) + 3 * length (bindecode (second ys)) +
+     19 * length vs + 203 * length zs ^ 4"
+  have "length ys \<le> length zs"
+    by simp
+  then have 1: "length (second ys) \<le> length zs"
+    using length_second dual_order.trans by blast
+  then have 2: "length (bindecode (second ys)) \<le> length zs"
+    by simp
+  then have 3: "length vs \<le> length zs"
+    by (meson dual_order.trans length_rstrip_le)
+
+  have "?ttt \<le> 138 + 3 * length zs + 3 * length zs + 19 * length zs + 203 * length zs ^ 4"
+    using 1 2 3 by simp
+  also have "... = 138 + 25 * length zs + 203 * length zs ^ 4"
+    by simp
+  also have "... \<le> 138 + 25 * length zs ^ 4 + 203 * length zs ^ 4"
+    using linear_le_pow by simp
+  also have "... = 138 + 228 * length zs ^ 4"
+    by simp
+  finally have "?ttt \<le> 138 + 228 * length zs ^ 4" .
+  then show ?thesis
+    using assms tmTTT transforms_monotone by blast
+qed
+
+end  (* context proper_second: "proper_symbols_lt 4 (second ys)" *)
+
+definition "tpsTT \<equiv> (if proper_symbols_lt 4 (second ys) then tpsTTT else tpsTT1)"
+
+lemma length_tpsTT: "length tpsTT = 22"
+  using tpsTT_def length_tpsTTT tpsTT1_def tps1 by simp
+
+lemma tpsTT: "tpsTT ! 1 =
+  (ncontents
+    (if proper_symbols_lt 4 (second ys) \<and> numlist_wf vs
+     then if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then 1 else 0
+     else 0),
+   1)"
+proof (cases "proper_symbols_lt 4 (second ys)")
+  case True
+  then have "tpsTT ! 1 = tpsTTT ! 1"
+    using tpsTT_def by simp
+  then show ?thesis
+    using tpsTTT True by simp
+next
+  case False
+  then have "tpsTT ! 1 = tpsTT1 ! 1"
+    using tpsTT_def by auto
+  then show ?thesis
+    using tpsTT1_def tps1 canrepr_0 False by auto
+qed
+
+lemma tmTTI [transforms_intros]:
+  assumes "ttt = 140 + 228 * length zs ^ 4"
+  shows "transforms tmTTI tpsTT1 ttt tpsTT"
+  unfolding tmTTI_def
+proof (tform time: assms)
+  have *: "read tpsTT1 ! 10 \<noteq> \<box> \<longleftrightarrow> proper_symbols_lt 4 (second ys)"
+    using tpsTT1_def tps1 read_ncontents_eq_0 by simp
+  show "read tpsTT1 ! 10 \<noteq> \<box> \<Longrightarrow> proper_symbols_lt 4 (second ys)"
+    using * by simp
+  let ?t = "138 + 228 * length zs ^ 4"
+  show "read tpsTT1 ! 10 \<noteq> \<box> \<Longrightarrow> tpsTT = tpsTTT"
+    using * tpsTT_def by simp
+  show "\<not> read tpsTT1 ! 10 \<noteq> \<box> \<Longrightarrow> tpsTT = tpsTT1"
+    using * tpsTT_def by auto
+qed
+
+lemma tmTT [transforms_intros]:
+  assumes "ttt = 145 + 7 * length (second ys) + 228 * length zs ^ 4"
+  shows "transforms tmTT tpsT2 ttt tpsTT"
+  unfolding tmTT_def by (tform time: assms)
+
+end  (* context first_wf: "numlistlist_wf (bindecode (first ys))" *)
+
+definition "tpsTE \<equiv> tps1
+  [2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1),
+   7 := (\<lfloor>bindecode (first ys)\<rfloor>, 1),
+   8 := (\<lfloor>numlistlist_wf xs\<rfloor>\<^sub>B, 1),
+   1 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+definition "tpsT \<equiv> (if numlistlist_wf xs then tpsTT else tpsTE)"
+
+lemma length_tpsT: "length tpsT = 22"
+  using tpsT_def length_tpsTT tpsTE_def tps1 by simp
+
+lemma tpsT: "tpsT ! 1 =
+  (ncontents
+   (if numlistlist_wf xs
+    then if proper_symbols_lt 4 (second ys) \<and> numlist_wf vs
+         then if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then 1 else 0
+         else 0
+    else 1),
+   1)"
+proof (cases "numlistlist_wf xs")
+  case True
+  then have "tpsT ! 1 = tpsTT ! 1"
+    using tpsT_def by simp
+  then show ?thesis
+    using tpsTT True by simp
+next
+  case False
+  then have "tpsT ! 1 = tpsTE ! 1"
+    using tpsT_def by auto
+  then show ?thesis
+    using tpsTE_def tps1 canrepr_0 False by auto
+qed
+
+lemma tmTI [transforms_intros]:
+  assumes "ttt = 147 + 7 * length (second ys) + 228 * length zs ^ 4"
+  shows "transforms tmTI tpsT2 ttt tpsT"
+  unfolding tmTI_def
+proof (tform time: assms)
+  have *: "read tpsT2 ! 8 \<noteq> \<box> \<longleftrightarrow> numlistlist_wf xs"
+    using tpsT2_def tps1 read_ncontents_eq_0 by simp
+  show "read tpsT2 ! 8 \<noteq> \<box> \<Longrightarrow> numlistlist_wf xs"
+    using * by simp
+  show "1 < length tpsT2"
+    using tpsT2_def tps1 by simp
+  show "tpsT2 ! 1 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tpsT2_def tps1 canrepr_0 by simp
+  show "\<not> read tpsT2 ! 8 \<noteq> \<box> \<Longrightarrow> tpsT = tpsT2[1 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+    using tpsT_def * tpsT2_def tpsTE_def by presburger
+  show "read tpsT2 ! 8 \<noteq> \<box> \<Longrightarrow> tpsT = tpsTT"
+    using * tpsT_def by simp
+  show "10 + 2 * nlength 0 + 2 * nlength 1 + 1 \<le> ttt"
+    using assms nlength_1_simp by simp
+qed
+
+lemma tmT [transforms_intros]:
+  assumes "ttt = 360 + 3 * length (first ys) + 39 * length xs + 7 * length (second ys) + 228 * length zs ^ 4"
+  shows "transforms tmT tps6 ttt tpsT"
+  unfolding tmT_def by (tform time: assms)
+
+end  (* context bs_even: "proper_symbols_lt 4 (first ys) \<and> even (length (first ys))" *)
+
+definition "tpsE \<equiv> tps1
+  [2 := (\<lfloor>ys\<rfloor>, 1),
+   3 := (\<lfloor>first ys\<rfloor>, 1),
+   4 := (\<lfloor>second ys\<rfloor>, 1),
+   5 := (\<lfloor>even (length (first ys))\<rfloor>\<^sub>B, 1),
+   6 := (\<lfloor>proper_symbols_lt 4 (first ys) \<and> even (length (first ys))\<rfloor>\<^sub>B, 1),
+   1 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+
+definition "tps7 \<equiv> (if proper_symbols_lt 4 (first ys) \<and> even (length (first ys)) then tpsT else tpsE)"
+
+lemma length_tps7: "length tps7 = 22"
+  using tps7_def length_tpsT tpsE_def tps1 by simp
+
+lemma tps7: "tps7 ! 1 =
+  (ncontents
+   (if proper_symbols_lt 4 (first ys) \<and> even (length (first ys)) \<and> numlistlist_wf xs
+    then if proper_symbols_lt 4 (second ys) \<and> numlist_wf vs
+         then if (\<lambda>v. v \<in> set (zs_numlist vs)) \<Turnstile> zs_formula xs then 1 else 0
+         else 0
+    else 1),
+   1)"
+proof (cases "proper_symbols_lt 4 (first ys) \<and> even (length (first ys))")
+  case True
+  then have "tps7 ! 1 = tpsT ! 1"
+    using tps7_def by simp
+  then show ?thesis
+    using tpsT True by simp
+next
+  case False
+  then have "tps7 ! 1 = tpsE ! 1"
+    using tps7_def by auto
+  then show ?thesis
+    using tpsE_def tps1 canrepr_0 False by auto
+qed
+
+lemma tps7': "tps7 ! 1 = (\<lfloor>verify_sat zs\<rfloor>, 1)"
+proof -
+  have "proper_symbols_lt 4 zs = bit_symbols zs" for zs
+    by fastforce
+  then show ?thesis
+    unfolding verify_sat_def Let_def using tps7 canrepr_0 canrepr_1 by auto
+qed
+
+lemma tmI [transforms_intros]:
+  assumes "ttt = 362 + 3 * length (first ys) + 39 * length xs + 7 * length (second ys) + 228 * length zs ^ 4"
+  shows "transforms tmI tps6 ttt tps7"
+  unfolding tmI_def
+proof (tform time: assms)
+  have *: "read tps6 ! 6 \<noteq> \<box> \<longleftrightarrow> (proper_symbols_lt 4 (first ys)) \<and> even (length (first ys))"
+    using tps6_def tps1 read_ncontents_eq_0 by simp
+  show "read tps6 ! 6 \<noteq> \<box> \<Longrightarrow> (proper_symbols_lt 4 (first ys)) \<and> even (length (first ys))"
+    using * by simp
+  show "1 < length tps6"
+    using tps6_def tps1 by simp
+  show "tps6 ! 1 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+    using tps6_def tps1 canrepr_0 by simp
+  show "\<not> read tps6 ! 6 \<noteq> \<box> \<Longrightarrow> tps7 = tps6[1 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+    using tps7_def * tps6_def tpsE_def by metis
+  show "read tps6 ! 6 \<noteq> \<box> \<Longrightarrow> tps7 = tpsT"
+    using tps7_def * by simp
+  show "10 + 2 * nlength 0 + 2 * nlength 1 + 1 \<le> ttt"
+    using assms nlength_1_simp by simp
+qed
+
+lemma tm7:
+  assumes "ttt = 398 + 3 * length zs + 6 * length ys + 17 * length (first ys) +
+     39 * length xs + 7 * length (second ys) + 228 * length zs ^ 4"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def by (tform time: assms)
+
+lemma tm7' [transforms_intros]:
+  assumes "ttt = 398 + 300 * length zs ^ 4"
+  shows "transforms tm7 tps0 ttt tps7"
+proof -
+  have *: "length ys \<le> length zs"
+    by simp
+  then have 1: "length (second ys) \<le> length zs"
+    using length_second dual_order.trans by blast
+  have 2: "length (first ys) \<le> length zs"
+    using * dual_order.trans length_first by blast
+  then have 3: "length xs \<le> length zs"
+    by simp
+  let ?ttt = "398 + 3 * length zs + 6 * length ys + 17 * length (first ys) +
+     39 * length xs + 7 * length (second ys) + 228 * length zs ^ 4"
+  have "?ttt \<le> 398 + 9 * length zs + 17 * length zs + 39 * length zs + 7 * length zs + 228 * length zs ^ 4"
+    using * 1 2 3 by simp
+  also have "... = 398 + 72 * length zs + 228 * length zs ^ 4"
+    by simp
+  also have "... \<le> 398 + 72 * length zs ^ 4 + 228 * length zs ^ 4"
+    using linear_le_pow by simp
+  also have "... = 398 + 300 * length zs ^ 4"
+    by simp
+  finally have "?ttt \<le> 398 + 300 * length zs ^ 4" .
+  then show ?thesis
+    using assms tm7 transforms_monotone by fast
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_verify_sat:
+  fixes zs :: "symbol list" and tps :: "tape list"
+  assumes "bit_symbols zs"
+    and "tps = snd (start_config 22 zs)"
+    and "ttt = 398 + 300 * length zs ^ 4"
+  shows "\<exists>tps'. tps' ! 1 = (\<lfloor>verify_sat zs\<rfloor>, 1) \<and> transforms tm_verify_sat tps ttt tps'"
+proof -
+  interpret loc: turing_machine_verify_sat .
+  show ?thesis
+    using assms loc.tm7' loc.tps7' loc.tm7_eq_tm_verify_sat by metis
+qed
+
+text \<open>
+With the Turing machine just constructed and the polynomial $p(n) = n$ we can
+satisfy the definition of $\NP$ and prove the main result of this chapter.
+\<close>
+
+theorem SAT_in_NP: "SAT \<in> \<N>\<P>"
+proof -
+  define p :: "nat \<Rightarrow> nat" where "p = (\<lambda>n. n)"
+  define T :: "nat \<Rightarrow> nat" where "T = (\<lambda>n. 398 + 300 * n ^ 4)"
+  define f :: "string \<Rightarrow> string" where
+    "f = (\<lambda>x. symbols_to_string (verify_sat (string_to_symbols x)))"
+  have "turing_machine 22 6 tm_verify_sat"
+    using tm_verify_sat_tm .
+  moreover have "polynomial p"
+    using p_def polynomial_id by (metis eq_id_iff)
+  moreover have "big_oh_poly T"
+    using T_def big_oh_poly_poly big_oh_poly_const big_oh_poly_sum big_oh_poly_prod by simp
+  moreover have "computes_in_time 22 tm_verify_sat f T"
+  proof
+    fix x :: string
+    let ?zs = "string_to_symbols x"
+    have bs: "bit_symbols ?zs"
+      by simp
+    have "bit_symbols (verify_sat ?zs)"
+      using bit_symbols_verify_sat by simp
+    then have *: "string_to_symbols (f x) = verify_sat ?zs"
+      unfolding f_def using bit_symbols_to_symbols by simp
+
+    obtain tps where tps:
+        "tps ! 1 = (\<lfloor>verify_sat ?zs\<rfloor>, 1)"
+        "transforms tm_verify_sat (snd (start_config 22 ?zs)) (T (length ?zs)) tps"
+      using bs transforms_tm_verify_sat T_def by blast
+    then have "tps ::: 1 = string_to_contents (f x)"
+      using * start_config_def contents_string_to_contents by simp
+    then show "\<exists>tps. tps ::: 1 = string_to_contents (f x) \<and>
+        transforms tm_verify_sat (snd (start_config_string 22 x)) (T (length x)) tps"
+      using tps(2) by auto
+  qed
+  moreover have "\<forall>x. x \<in> SAT \<longleftrightarrow> (\<exists>u. length u = p (length x) \<and> f \<langle>x, u\<rangle> = [\<bbbI>])"
+  proof
+    fix x :: string
+    show "(x \<in> SAT) = (\<exists>u. length u = p (length x) \<and> f \<langle>x, u\<rangle> = [\<bbbI>])"
+    proof
+      show "\<exists>u. length u = p (length x) \<and> f \<langle>x, u\<rangle> = [\<bbbI>]" if "x \<in> SAT"
+      proof (cases "\<exists>\<phi>. x = formula_to_string \<phi>")
+        case True
+        then obtain \<phi> where \<phi>: "x = formula_to_string \<phi>" "satisfiable \<phi>"
+          using SAT_def using \<open>x \<in> SAT\<close> by auto
+        then obtain us where us:
+            "bit_symbols us"
+            "length us = length (formula_to_string \<phi>)"
+            "verify_sat \<langle>formula_to_string \<phi>; symbols_to_string us\<rangle> = [\<one>]"
+          using ex_witness_linear_length by blast
+        let ?zs = "\<langle>formula_to_string \<phi>; symbols_to_string us\<rangle>"
+        define u where "u = symbols_to_string us"
+        have "length us = p (length x)"
+          using us(2) \<phi>(1) p_def by simp
+        then have 1: "length u = p (length x)"
+          using u_def by simp
+
+        have "f \<langle>x, u\<rangle> = symbols_to_string (verify_sat \<langle>x; u\<rangle>)"
+          using f_def by simp
+        also have "... = symbols_to_string (verify_sat ?zs)"
+          using \<phi>(1) u_def by simp
+        also have "... = symbols_to_string [\<one>]"
+          using us(3) by simp
+        also have "... = [\<bbbI>]"
+          by simp
+        finally have "f \<langle>x, u\<rangle> = [\<bbbI>]" .
+        then show ?thesis
+          using 1 by auto
+      next
+        case False
+        define u where "u = replicate (length x) \<bbbO>"
+        then have 1: "length u = p (length x)"
+          using p_def by simp
+        have "f \<langle>x, u\<rangle> = symbols_to_string (verify_sat \<langle>x; u\<rangle>)"
+          using f_def by simp
+        also have "... = symbols_to_string [\<one>]"
+          using verify_sat_not_wf_phi False by simp
+        also have "... = [\<bbbI>]"
+          by simp
+        finally have "f \<langle>x, u\<rangle> = [\<bbbI>]" .
+        then show ?thesis
+          using 1 by auto
+      qed
+      show "x \<in> SAT" if ex: "\<exists>u. length u = p (length x) \<and> f \<langle>x, u\<rangle> = [\<bbbI>]"
+      proof (rule ccontr)
+        assume notin: "x \<notin> SAT"
+        then obtain \<phi> where \<phi>: "x = formula_to_string \<phi>" "\<not> satisfiable \<phi>"
+          using SAT_def by auto
+        obtain u where u: "length u = p (length x)" "f \<langle>x, u\<rangle> = [\<bbbI>]"
+          using ex by auto
+        have "f \<langle>x, u\<rangle> = symbols_to_string (verify_sat \<langle>x; u\<rangle>)"
+          using f_def by simp
+        also have "... = symbols_to_string (verify_sat \<langle>formula_to_string \<phi>; u\<rangle>)"
+          using \<phi>(1) by simp
+        also have "... = symbols_to_string []"
+          using verify_sat_not_sat \<phi>(2) by simp
+        also have "... = []"
+          by simp
+        finally have "f \<langle>x, u\<rangle> = []" .
+        then show False
+          using u(2) by simp
+      qed
+    qed
+  qed
+  ultimately show ?thesis
+    using complexity_class_NP_def by fast
+qed
+
+end
diff --git a/thys/Cook_Levin/Symbol_Ops.thy b/thys/Cook_Levin/Symbol_Ops.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Symbol_Ops.thy
@@ -0,0 +1,1986 @@
+section \<open>Symbol sequence operations\<close>
+
+theory Symbol_Ops
+  imports Two_Four_Symbols
+begin
+
+text \<open>
+While previous sections have focused on ``formatted'' symbol sequences for
+numbers and lists, in this section we devise some Turing machines dealing with
+``unstructured'' arbitrary symbol sequences. The only ``structure'' that is
+often imposed is that of not containing a blank symbol because when reading a
+symbol sequence, say from the input tape, a blank would signal the end of the
+symbol sequence.
+\<close>
+
+
+subsection \<open>Checking for being over an alphabet\<close>
+
+text \<open>
+In this section we devise a Turing machine that checks if a proper symbol sequence
+is over a given alphabet represented by an upper bound symbol $z$.
+\<close>
+
+abbreviation proper_symbols_lt :: "symbol \<Rightarrow> symbol list \<Rightarrow> bool" where
+  "proper_symbols_lt z zs \<equiv> proper_symbols zs \<and> symbols_lt z zs"
+
+text \<open>
+The next Turing machine checks if the symbol sequence (up until the first blank)
+on tape $j_1$ contains only symbols from $\{2, \dots, z - 1\}$, where $z$ is a
+parameter of the TM, and writes to tape $j_2$ the number~1 or~0, representing
+True or False, respectively. It assumes that $j_2$ initially contains at most
+one symbol.
+\<close>
+
+definition tm_proper_symbols_lt :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol \<Rightarrow> machine" where
+  "tm_proper_symbols_lt j1 j2 z \<equiv>
+    tm_write j2 \<one> ;;
+    WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO
+      IF \<lambda>rs. rs ! j1 < 2 \<or> rs ! j1 \<ge> z THEN
+        tm_write j2 \<box>
+      ELSE
+        []
+      ENDIF ;;
+      tm_right j1
+    DONE ;;
+    tm_cr j1"
+
+lemma tm_proper_symbols_lt_tm:
+  assumes "0 < j2" "j1 < k" "j2 < k" and "G \<ge> 4"
+  shows "turing_machine k G (tm_proper_symbols_lt j1 j2 z)"
+  using assms tm_write_tm tm_right_tm tm_cr_tm Nil_tm tm_proper_symbols_lt_def
+    turing_machine_loop_turing_machine turing_machine_branch_turing_machine
+  by simp
+
+locale turing_machine_proper_symbols_lt =
+  fixes j1 j2 :: tapeidx and z :: symbol
+begin
+
+definition "tm1 \<equiv> tm_write j2 \<one>"
+definition "tm2 \<equiv> IF \<lambda>rs. rs ! j1 < 2 \<or> rs ! j1 \<ge> z THEN tm_write j2 \<box> ELSE [] ENDIF"
+definition "tm3 \<equiv> tm2 ;; tm_right j1"
+definition "tm4 \<equiv> WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO tm3 DONE"
+definition "tm5 \<equiv> tm1 ;; tm4"
+definition "tm6 \<equiv> tm5 ;; tm_cr j1"
+
+lemma tm6_eq_tm_proper_symbols_lt: "tm6 = tm_proper_symbols_lt j1 j2 z"
+  unfolding tm6_def tm5_def tm4_def tm3_def tm2_def tm1_def tm_proper_symbols_lt_def
+  by simp
+
+context
+  fixes zs :: "symbol list" and tps0 :: "tape list" and k :: nat
+  assumes jk: "k = length tps0" "j1 \<noteq> j2" "j1 < k" "j2 < k"
+    and zs: "proper_symbols zs"
+    and tps0:
+      "tps0 ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+      "tps0 ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 t \<equiv> tps0
+  [j1 := (\<lfloor>zs\<rfloor>, Suc t),
+   j2 := (if proper_symbols_lt z (take t zs) then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm1 [transforms_intros]: "transforms tm1 tps0 1 (tps1 0)"
+  unfolding tm1_def
+proof (tform tps: jk tps0)
+  have "(if proper_symbols_lt z (take 0 zs) then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[]\<rfloor>, 1) = (\<lfloor>[\<one>]\<rfloor>, 1)"
+    by simp
+  moreover have "tps0 ! j2 |:=| \<one> = (\<lfloor>[\<one>]\<rfloor>, 1)"
+    using tps0(2) contents_def by auto
+  moreover have "tps0[j1 := (\<lfloor>zs\<rfloor>, Suc 0)] = tps0"
+    using tps0(1) by (metis One_nat_def list_update_id)
+  ultimately show "tps1 0 = tps0[j2 := tps0 ! j2 |:=| \<one>]"
+    unfolding tps1_def by auto
+qed
+
+definition "tps2 t \<equiv> tps0
+  [j1 := (\<lfloor>zs\<rfloor>, Suc t),
+   j2 := (if proper_symbols_lt z (take (Suc t) zs) then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "t < length zs"
+  shows "transforms tm2 (tps1 t) 3 (tps2 t)"
+  unfolding tm2_def
+proof (tform tps: jk tps1_def)
+  have "tps1 t ! j1 = (\<lfloor>zs\<rfloor>, Suc t)"
+    using tps1_def jk by simp
+  moreover have "read (tps1 t) ! j1 = tps1 t :.: j1"
+    using tapes_at_read' jk tps1_def by (metis (no_types, lifting) length_list_update)
+  ultimately have *: "read (tps1 t) ! j1 = zs ! t"
+    using contents_inbounds assms(1) by simp
+  have j2: "tps1 t ! j2 = (if proper_symbols_lt z (take t zs) then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[]\<rfloor>, 1)"
+    using tps1_def jk by simp
+  show "tps2 t = (tps1 t)[j2 := tps1 t ! j2 |:=| \<box>]" if "read (tps1 t) ! j1 < 2 \<or> z \<le> read (tps1 t) ! j1"
+  proof -
+    have c3: "(\<lfloor>[\<one>]\<rfloor>, 1) |:=| \<box> = (\<lfloor>[]\<rfloor>, 1)"
+      using contents_def by auto
+    have "(if proper_symbols_lt z (take t zs) then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[]\<rfloor>, 1) |:=| \<box> =
+       (if proper_symbols_lt z (take (Suc t) zs) then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[]\<rfloor>, 1)"
+    proof (cases "proper_symbols_lt z (take t zs)")
+      case True
+      have "zs ! t < 2 \<or> z \<le> zs ! t"
+        using that * by simp
+      then have "\<not> proper_symbols_lt z (take (Suc t) zs)"
+        using assms(1) by auto
+      then show ?thesis
+        using c3 by auto
+    next
+      case False
+      then have "\<not> proper_symbols_lt z (take (Suc t) zs)"
+        by auto
+      then show ?thesis
+        using c3 False by auto
+    qed
+    then have "tps1 t ! j2 |:=| \<box> = (if proper_symbols_lt z (take (Suc t) zs) then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[]\<rfloor>, 1)"
+      using j2 by simp
+    then show "tps2 t = (tps1 t)[j2 := tps1 t ! j2 |:=| \<box>]"
+      unfolding tps2_def tps1_def using c3 jk(1,4) by simp
+  qed
+  show "tps2 t = tps1 t" if "\<not> (read (tps1 t) ! j1 < 2 \<or> z \<le> read (tps1 t) ! j1)"
+  proof -
+    have 1: "zs ! t \<ge> 2 \<and> z > zs ! t"
+      using that * by simp
+    show "tps2 t = tps1 t"
+    proof (cases "proper_symbols_lt z (take t zs)")
+      case True
+      have "proper_symbols_lt z (take (Suc t) zs)"
+        using True 1 assms(1) zs by (metis length_take less_antisym min_less_iff_conj nth_take)
+      then show ?thesis
+        using tps1_def tps2_def jk by simp
+    next
+      case False
+      then have "\<not> proper_symbols_lt z (take (Suc t) zs)"
+        by auto
+      then show ?thesis
+        using tps1_def tps2_def jk False by auto
+    qed
+  qed
+qed
+
+lemma tm3 [transforms_intros]:
+  assumes "t < length zs"
+  shows "transforms tm3 (tps1 t) 4 (tps1 (Suc t))"
+  unfolding tm3_def
+proof (tform tps: assms jk tps2_def)
+  have "tps2 t ! j1 |+| 1 = (\<lfloor>zs\<rfloor>, Suc (Suc t))"
+    using tps2_def jk by simp
+  then show "tps1 (Suc t) = (tps2 t)[j1 := tps2 t ! j1 |+| 1]"
+    unfolding tps1_def tps2_def
+    by (metis (no_types, lifting) jk(2) list_update_overwrite list_update_swap)
+qed
+
+lemma tm4 [transforms_intros]:
+  assumes "ttt = 1 + 6 * length zs"
+  shows "transforms tm4 (tps1 0) ttt (tps1 (length zs))"
+  unfolding tm4_def
+proof (tform time: assms)
+  show "read (tps1 t) ! j1 \<noteq> \<box>" if "t < length zs" for t
+  proof -
+    have "tps1 t ! j1 = (\<lfloor>zs\<rfloor>, Suc t)"
+      using tps1_def jk by simp
+    moreover have "read (tps1 t) ! j1 = tps1 t :.: j1"
+      using tapes_at_read' jk tps1_def by (metis (no_types, lifting) length_list_update)
+    ultimately have "read (tps1 t) ! j1 = zs ! t"
+      using contents_inbounds that by simp
+    then show ?thesis
+      using zs that by auto
+  qed
+  show "\<not> read (tps1 (length zs)) ! j1 \<noteq> \<box>"
+  proof -
+    have "tps1 (length zs) ! j1 = (\<lfloor>zs\<rfloor>, Suc (length zs))"
+      using tps1_def jk by simp
+    moreover have "read (tps1 (length zs)) ! j1 = tps1 (length zs) :.: j1"
+      using tapes_at_read' jk tps1_def by (metis (no_types, lifting) length_list_update)
+    ultimately show ?thesis
+      by simp
+  qed
+qed
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 2 + 6 * length zs"
+  shows "transforms tm5 tps0 ttt (tps1 (length zs))"
+  unfolding tm5_def
+  by (tform time: assms)
+
+definition "tps5 \<equiv> tps0
+  [j1 := (\<lfloor>zs\<rfloor>, 1),
+   j2 := (if proper_symbols_lt z zs then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[]\<rfloor>, 1)]"
+
+definition "tps5' \<equiv> tps0
+  [j2 := (if proper_symbols_lt z zs then \<lfloor>[\<one>]\<rfloor> else \<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm6:
+  assumes "ttt = 5 + 7 * length zs"
+  shows "transforms tm6 tps0 ttt tps5'"
+  unfolding tm6_def
+proof (tform time: assms tps1_def jk)
+  have *: "tps1 (length zs) ! j1 = (\<lfloor>zs\<rfloor>, Suc (length zs))"
+    using tps1_def jk by simp
+  show "clean_tape (tps1 (length zs) ! j1)"
+    using * zs by simp
+  have "tps5 = (tps1 (length zs))[j1 :=  (\<lfloor>zs\<rfloor>, Suc (length zs)) |#=| 1]"
+    unfolding tps5_def tps1_def by (simp add: list_update_swap[OF jk(2)])
+  then have "tps5 = (tps1 (length zs))[j1 := tps1 (length zs) ! j1 |#=| 1]"
+    using * by simp
+  moreover have "tps5' = tps5"
+    using tps5'_def tps5_def tps0 jk by (metis list_update_id)
+  ultimately show "tps5' = (tps1 (length zs))[j1 := tps1 (length zs) ! j1 |#=| 1]"
+    by simp
+qed
+
+definition "tps6 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt z zs\<rfloor>\<^sub>B, 1)]"
+
+lemma tm6':
+  assumes "ttt = 5 + 7 * length zs"
+  shows "transforms tm6 tps0 ttt tps6"
+proof -
+  have "tps6 = tps5'"
+    using tps6_def tps5'_def canrepr_0 canrepr_1 by auto
+  then show ?thesis
+    using tm6 assms by simp
+qed
+
+end
+
+end  (* locale *)
+
+lemma transforms_tm_proper_symbols_ltI [transforms_intros]:
+  fixes j1 j2 :: tapeidx and z :: symbol
+  fixes zs :: "symbol list" and tps tps' :: "tape list" and k :: nat
+  assumes "k = length tps" "j1 \<noteq> j2" "j1 < k" "j2 < k"
+    and "proper_symbols zs"
+  assumes
+    "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 5 + 7 * length zs"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>proper_symbols_lt z zs\<rfloor>\<^sub>B, 1)]"
+  shows "transforms (tm_proper_symbols_lt j1 j2 z) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_proper_symbols_lt j1 j2 .
+  show ?thesis
+    using assms loc.tm6_eq_tm_proper_symbols_lt loc.tps6_def loc.tm6' by simp
+qed
+
+
+subsection \<open>The length of the input\<close>
+
+text \<open>
+The Turing machine in this section reads the input tape until the first blank
+and increments a counter on tape $j$ for every symbol read. In the end
+it performs a carriage return on the input tape, and tape $j$ contains the
+length of the input as binary number. For this to work, tape $j$ must initially
+be empty.
+\<close>
+
+lemma proper_tape_read:
+  assumes "proper_symbols zs"
+  shows "|.| (\<lfloor>zs\<rfloor>, i) = \<box> \<longleftrightarrow> i > length zs"
+proof -
+  have "|.| (\<lfloor>zs\<rfloor>, i) = \<box>" if "i > length zs" for i
+    using that contents_outofbounds by simp
+  moreover have "|.| (\<lfloor>zs\<rfloor>, i) \<noteq> \<box>" if "i \<le> length zs" for i
+    using that contents_inbounds assms contents_def proper_symbols_ne0 by simp
+  ultimately show ?thesis
+    by (meson le_less_linear)
+qed
+
+definition tm_length_input :: "tapeidx \<Rightarrow> machine" where
+  "tm_length_input j \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! 0 \<noteq> \<box> DO
+      tm_incr j ;;
+      tm_right 0
+    DONE ;;
+    tm_cr 0"
+
+lemma tm_length_input_tm:
+  assumes "G \<ge> 4" and "0 < j" and "j < k"
+  shows "turing_machine k G (tm_length_input j)"
+  using tm_length_input_def tm_incr_tm assms Nil_tm tm_right_tm tm_cr_tm
+  by (simp add: turing_machine_loop_turing_machine)
+
+locale turing_machine_length_input =
+  fixes j :: tapeidx
+begin
+
+definition "tmL1 \<equiv> tm_incr j"
+definition "tmL2 \<equiv> tmL1 ;; tm_right 0"
+definition "tm1 \<equiv> WHILE [] ; \<lambda>rs. rs ! 0 \<noteq> \<box> DO tmL2 DONE"
+definition "tm2 \<equiv> tm1 ;; tm_cr 0"
+
+lemma tm2_eq_tm_length_input: "tm2 = tm_length_input j"
+  unfolding tm2_def tm1_def tmL2_def tmL1_def tm_length_input_def by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and zs :: "symbol list"
+  assumes jk: "0 < j" "j < k" "length tps0 = k"
+    and zs: "proper_symbols zs"
+    and tps0:
+      "tps0 ! 0 = (\<lfloor>zs\<rfloor>, 1)"
+      "tps0 ! j = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0[0 := (\<lfloor>zs\<rfloor>, 1 + t), j := (\<lfloor>t\<rfloor>\<^sub>N, 1)]"
+
+lemma tpsL_eq_tps0: "tpsL 0 = tps0"
+  using tpsL_def tps0 jk by (metis One_nat_def list_update_id plus_1_eq_Suc)
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+  "tpsL1 t \<equiv> tps0[0 := (\<lfloor>zs\<rfloor>, 1 + t), j := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1)]"
+
+definition tpsL2 :: "nat \<Rightarrow> tape list" where
+  "tpsL2 t \<equiv> tps0[0 := (\<lfloor>zs\<rfloor>, 1 + Suc t), j := (\<lfloor>Suc t\<rfloor>\<^sub>N, 1)]"
+
+lemma tmL1 [transforms_intros]:
+  assumes "t < length zs" and "ttt = 5 + 2 * nlength t"
+  shows "transforms tmL1 (tpsL t) ttt (tpsL1 t)"
+  unfolding tmL1_def
+  by (tform tps: assms(1) tpsL_def tpsL1_def tps0 jk time: assms(2))
+
+lemma tmL2:
+  assumes "t < length zs" and "ttt = 6 + 2 * nlength t"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL (Suc t))"
+  unfolding tmL2_def
+proof (tform tps: assms(1) tpsL_def tpsL1_def tps0 jk time: assms(2))
+  have "tpsL1 t ! 0 = (\<lfloor>zs\<rfloor>, 1 + t)"
+    using tpsL2_def tpsL1_def jk tps0 by simp
+  then have "tpsL2 t = (tpsL1 t)[0 := tpsL1 t ! 0 |#=| Suc (tpsL1 t :#: 0)]"
+    using tpsL2_def tpsL1_def jk tps0
+    by (smt (z3) fstI list_update_overwrite list_update_swap nat_neq_iff plus_1_eq_Suc prod.sel(2))
+  then show "tpsL (Suc t) = (tpsL1 t)[0 := tpsL1 t ! 0 |+| 1]"
+    using tpsL2_def tpsL_def tpsL1_def jk tps0 by simp
+qed
+
+lemma tmL2':
+  assumes "t < length zs" and "ttt = 6 + 2 * nlength (length zs)"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL (Suc t))"
+proof -
+  have "6 + 2 * nlength t \<le> 6 + 2 * nlength (length zs)"
+    using assms(1) nlength_mono by simp
+  then show ?thesis
+    using assms tmL2 transforms_monotone by blast
+qed
+
+lemma tm1:
+  assumes "ttt = length zs * (8 + 2 * nlength (length zs)) + 1"
+  shows "transforms tm1 (tpsL 0) ttt (tpsL (length zs))"
+  unfolding tm1_def
+proof (tform)
+  let ?t = "6 + 2 * nlength (length zs)"
+  show "\<And>t. t < length zs \<Longrightarrow> transforms tmL2 (tpsL t) ?t (tpsL (Suc t))"
+    using tmL2' by simp
+  have *: "tpsL t ! 0 = (\<lfloor>zs\<rfloor>, Suc t)" for t
+    using tpsL_def jk by simp
+  then show "\<And>t. t < length zs \<Longrightarrow> read (tpsL t) ! 0 \<noteq> \<box>"
+    using proper_tape_read[OF zs] tpsL_def jk tapes_at_read'
+    by (metis length_list_update less_Suc_eq_0_disj not_less_eq)
+  show "\<not> read (tpsL (length zs)) ! 0 \<noteq> \<box>"
+    using proper_tape_read[OF zs] tpsL_def jk tapes_at_read' *
+    by (metis length_list_update less_Suc_eq_0_disj less_imp_Suc_add nat_neq_iff not_less_less_Suc_eq)
+  show "length zs * (6 + 2 * nlength (length zs) + 2) + 1 \<le> ttt"
+    using assms by simp
+qed
+
+lemma tmL' [transforms_intros]:
+  assumes "ttt = 10 * length zs ^ 2 + 1"
+  shows "transforms tm1 (tpsL 0) ttt (tpsL (length zs))"
+proof -
+  let ?ttt = "length zs * (8 + 2 * nlength (length zs)) + 1"
+  have "?ttt \<le> length zs * (8 + 2 * length zs) + 1"
+    using nlength_le_n by simp
+  also have "... \<le> 8 * length zs + 2 * length zs ^ 2 + 1"
+    by (simp add: add_mult_distrib2 power2_eq_square)
+  also have "... \<le> 10 * length zs ^ 2 + 1"
+    using linear_le_pow by simp
+  finally have "?ttt \<le> 10 * length zs ^ 2 + 1" .
+  then show ?thesis
+    using tm1 assms transforms_monotone by simp
+qed
+
+definition tps2 :: "tape list" where
+  "tps2 \<equiv> tps0[0 := (\<lfloor>zs\<rfloor>, 1), j := (\<lfloor>length zs\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2:
+  assumes "ttt = 10 * length zs ^ 2 + length zs + 4"
+  shows "transforms tm2 (tpsL 0) ttt tps2"
+  unfolding tm2_def
+proof (tform time: assms tpsL_def jk tps: tpsL_def tpsL1_def tps0 jk)
+  show "clean_tape (tpsL (length zs) ! 0)"
+   using tpsL_def jk clean_contents_proper[OF zs] by simp
+  have "tpsL (length zs) ! 0 = (\<lfloor>zs\<rfloor>, Suc (length zs))"
+    using tpsL_def jk by simp
+  then show "tps2 = (tpsL (length zs))[0 := tpsL (length zs) ! 0 |#=| 1]"
+    using tps2_def tpsL_def jk by (simp add: list_update_swap_less)
+qed
+
+definition tps2' :: "tape list" where
+  "tps2' \<equiv> tps0[j := (\<lfloor>length zs\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2':
+  assumes "ttt = 11 * length zs ^ 2 + 4"
+  shows "transforms tm2 tps0 ttt tps2'"
+proof -
+  have "10 * length zs ^ 2 + length zs + 4 \<le> ttt"
+    using assms linear_le_pow[of 2 "length zs"] by simp
+  moreover have "tps2 = tps2'"
+    using tps2_def tps2'_def jk tps0 by (metis list_update_id)
+  ultimately show ?thesis
+    using transforms_monotone tm2 tpsL_eq_tps0 by simp
+qed
+
+end
+
+end
+
+lemma transforms_tm_length_inputI [transforms_intros]:
+  fixes j :: tapeidx
+  fixes tps tps' :: "tape list" and k :: nat and zs :: "symbol list"
+  assumes "0 < j" "j < k" "length tps = k"
+    and "proper_symbols zs"
+  assumes
+    "tps ! 0 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps ! j = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 11 * length zs ^ 2 + 4"
+  assumes "tps' = tps
+    [j := (\<lfloor>length zs\<rfloor>\<^sub>N, 1)]"
+  shows "transforms (tm_length_input j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_length_input j .
+  show ?thesis
+    using loc.tm2' loc.tps2'_def loc.tm2_eq_tm_length_input assms by simp
+qed
+
+
+subsection \<open>Whether the length is even\<close>
+
+text \<open>
+The next Turing machines reads the symbols on tape $j_1$ until the first blank
+and alternates between numbers~0 and~1 on tape $j_2$. Then tape $j_2$
+contains the parity of the length of the symbol sequence on tape $j_1$. Finally, the TM
+flips the output once more, so that tape $j_2$ contains a Boolean indicating
+whether the length was even or not. We assume tape $j_2$ is initially empty,
+that is, represents the number~0.
+\<close>
+
+definition tm_even_length :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_even_length j1 j2 \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO
+      tm_not j2 ;;
+      tm_right j1
+    DONE ;;
+    tm_not j2 ;;
+    tm_cr j1"
+
+lemma tm_even_length_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "j1 < k" "0 < j2" "j2 < k"
+  shows "turing_machine k G (tm_even_length j1 j2)"
+  using tm_even_length_def tm_right_tm tm_not_tm Nil_tm assms tm_cr_tm turing_machine_loop_turing_machine
+  by simp
+
+locale turing_machine_even_length =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tmB \<equiv> tm_not j2 ;; tm_right j1"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO tmB DONE"
+definition "tm2 \<equiv> tmL ;; tm_not j2"
+definition "tm3 \<equiv> tm2 ;; tm_cr j1"
+
+lemma tm3_eq_tm_even_length: "tm3 = tm_even_length j1 j2"
+  unfolding tm3_def tm2_def tmL_def tmB_def tm_even_length_def by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and zs :: "symbol list"
+  assumes zs: "proper_symbols zs"
+  assumes jk: "j1 < k" "j2 < k" "j1 \<noteq> j2" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps0 ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [j1 := (\<lfloor>zs\<rfloor>, Suc t),
+     j2 := (\<lfloor>odd t\<rfloor>\<^sub>B, 1)]"
+
+lemma tpsL0: "tpsL 0 = tps0"
+  unfolding tpsL_def using tps0 jk by (metis (mono_tags, opaque_lifting) One_nat_def even_zero list_update_id)
+
+lemma tmL2 [transforms_intros]: "transforms tmB (tpsL t) 4 (tpsL (Suc t))"
+  unfolding tmB_def
+proof (tform tps: tpsL_def jk)
+  have "(tpsL t)
+    [j2 := (\<lfloor>(if odd t then 1 else 0 :: nat) \<noteq> 1\<rfloor>\<^sub>B, 1),
+     j1 := (tpsL t)[j2 := (\<lfloor> (if odd t then 1 else 0 :: nat) \<noteq> 1 \<rfloor>\<^sub>B, 1)] ! j1 |+| 1] =
+    (tpsL t)
+    [j2 := (\<lfloor>odd (Suc t)\<rfloor>\<^sub>B, 1),
+     j1 := (tpsL t) ! j1 |+| 1]"
+    using jk by simp
+  also have "... = (tpsL t)
+    [j2 := (\<lfloor>odd (Suc t)\<rfloor>\<^sub>B, 1),
+     j1 := (\<lfloor>zs\<rfloor>, Suc (Suc t))]"
+    using tpsL_def jk by simp
+  also have "... = (tpsL t)
+    [j1 := (\<lfloor>zs\<rfloor>, Suc (Suc t)),
+     j2 := (\<lfloor>odd (Suc t)\<rfloor>\<^sub>B, 1)]"
+    using jk by (simp add: list_update_swap)
+  also have "... = tps0
+    [j1 := (\<lfloor>zs\<rfloor>, Suc (Suc t)),
+     j2 := (\<lfloor>odd (Suc t)\<rfloor>\<^sub>B, 1)]"
+    using jk tpsL_def by (simp add: list_update_swap)
+  also have "... = tpsL (Suc t)"
+    using tpsL_def by simp
+  finally show "tpsL (Suc t) = (tpsL t)
+    [j2 := (\<lfloor>(if odd t then 1 else 0 :: nat) \<noteq> 1\<rfloor>\<^sub>B, 1),
+     j1 := (tpsL t)[j2 := (\<lfloor>(if odd t then 1 else 0 :: nat) \<noteq> 1\<rfloor>\<^sub>B, 1)] ! j1 |+| 1]"
+    by simp
+qed
+
+lemma tmL:
+  assumes "ttt = 6 * length zs + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (length zs))"
+  unfolding tmL_def
+proof (tform time: assms)
+  have "read (tpsL t) ! j1 = tpsL t :.: j1" for t
+    using tpsL_def tapes_at_read' jk
+    by (metis (no_types, lifting) length_list_update)
+  then have "read (tpsL t) ! j1 = \<lfloor>zs\<rfloor> (Suc t)" for t
+    using tpsL_def jk by simp
+  then show "\<And>t. t < length zs \<Longrightarrow> read (tpsL t) ! j1 \<noteq> \<box>" and "\<not> read (tpsL (length zs)) ! j1 \<noteq> \<box>"
+    using zs by auto
+qed
+
+lemma tmL' [transforms_intros]:
+  assumes "ttt = 6 * length zs + 1"
+  shows "transforms tmL tps0 ttt (tpsL (length zs))"
+  using assms tmL tpsL0 by simp
+
+definition tps2 :: "tape list" where
+  "tps2 \<equiv> tps0
+    [j1 := (\<lfloor>zs\<rfloor>, Suc (length zs)),
+     j2 := (\<lfloor>even (length zs) \<rfloor>\<^sub>B, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 6 * length zs + 4"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tpsL_def jk time: assms)
+  show "tps2 = (tpsL (length zs))[j2 := (\<lfloor>(if odd (length zs) then 1 else 0 :: nat) \<noteq> 1\<rfloor>\<^sub>B, 1)]"
+    unfolding tps2_def tpsL_def by (simp add: list_update_swap)
+qed
+
+definition tps3 :: "tape list" where
+  "tps3 \<equiv> tps0
+    [j1 := (\<lfloor>zs\<rfloor>, 1),
+     j2 := (\<lfloor>even (length zs)\<rfloor>\<^sub>B, 1)]"
+
+lemma tm3:
+  assumes "ttt = 7 * length zs + 7"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps2_def jk time: assms)
+  show "clean_tape (tps2 ! j1)"
+    using tps2_def jk zs clean_contents_proper by simp
+  have "tps2 ! j1 |#=| 1 = (\<lfloor>zs\<rfloor>, 1)"
+    using tps2_def jk by simp
+  then show "tps3 = tps2[j1 := tps2 ! j1 |#=| 1]"
+    unfolding tps3_def tps2_def using jk by (simp add: list_update_swap)
+  show "ttt = 6 * length zs + 4 + (tps2 :#: j1 + 2)"
+    using assms tps2_def jk by simp
+qed
+
+definition tps3' :: "tape list" where
+  "tps3' \<equiv> tps0
+    [j2 := (\<lfloor>even (length zs)\<rfloor>\<^sub>B, 1)]"
+
+lemma tps3': "tps3' = tps3"
+  using tps3'_def tps3_def tps0 by (metis list_update_id)
+
+lemma tm3':
+  assumes "ttt = 7 * length zs + 7"
+  shows "transforms tm3 tps0 ttt tps3'"
+  using tps3' tm3 assms by simp
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_even_lengthI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and k :: nat and zs :: "symbol list"
+  assumes "j1 < k" "j2 < k" "j1 \<noteq> j2"
+    and "proper_symbols zs"
+    and "length tps = k"
+  assumes
+    "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>even (length zs)\<rfloor>\<^sub>B, 1)]"
+  assumes "ttt = 7 * length zs + 7"
+  shows "transforms (tm_even_length j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_even_length j1 j2 .
+  show ?thesis
+    using assms loc.tps3'_def loc.tm3' loc.tm3_eq_tm_even_length by simp
+qed
+
+
+subsection \<open>Checking for ends-with or empty\<close>
+
+text \<open>
+The next Turing machine implements a slightly idiosyncratic operation that we
+use in the next section for checking if a symbol sequence represents a list of
+numbers. The operation consists in checking if the symbol sequence on tape $j_1$
+either is empty or ends with the symbol $z$, which is another parameter of the
+TM.  If the condition is met, the number~1 is written to tape $j_2$, otherwise
+the number~0.
+\<close>
+
+definition tm_empty_or_endswith :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> symbol \<Rightarrow> machine" where
+  "tm_empty_or_endswith j1 j2 z \<equiv>
+      tm_right_until j1 {\<box>} ;;
+      tm_left j1 ;;
+      IF \<lambda>rs. rs ! j1 \<in> {\<triangleright>, z} THEN
+        tm_setn j2 1
+      ELSE
+        []
+      ENDIF ;;
+      tm_cr j1"
+
+lemma tm_empty_or_endswith_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j2" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_empty_or_endswith j1 j2 z)"
+  using assms Nil_tm tm_right_until_tm tm_left_tm tm_setn_tm tm_cr_tm
+    turing_machine_branch_turing_machine tm_empty_or_endswith_def
+  by simp
+
+locale turing_machine_empty_or_endswith =
+  fixes j1 j2 :: tapeidx and z :: symbol
+begin
+
+definition "tm1 \<equiv> tm_right_until j1 {\<box>}"
+definition "tm2 \<equiv> tm1 ;; tm_left j1"
+definition "tmI \<equiv> IF \<lambda>rs. rs ! j1 \<in> {\<triangleright>, z} THEN tm_setn j2 1 ELSE [] ENDIF"
+definition "tm3 \<equiv> tm2 ;; tmI"
+definition "tm4 \<equiv> tm3 ;; tm_cr j1"
+
+lemma tm4_eq_tm_empty_or_endswith: "tm4 = tm_empty_or_endswith j1 j2 z"
+  unfolding tm4_def tm3_def tmI_def tm2_def tm1_def tm_empty_or_endswith_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and zs :: "symbol list"
+  assumes jk: "j1 \<noteq> j2" "j1 < k" "j2 < k" "length tps0 = k"
+    and zs: "proper_symbols zs"
+    and tps0:
+      "tps0 ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+      "tps0 ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+begin
+
+definition tps1 :: "tape list" where
+  "tps1 \<equiv> tps0
+    [j1 := (\<lfloor>zs\<rfloor>, Suc (length zs))]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = Suc (length zs)"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform time: assms tps: tps0 tps1_def jk)
+  show "rneigh (tps0 ! j1) {0} (length zs)"
+  proof (rule rneighI)
+    show "(tps0 ::: j1) (tps0 :#: j1 + length zs) \<in> {0}"
+      using tps0 by simp
+    show "\<And>n'. n' < length zs \<Longrightarrow> (tps0 ::: j1) (tps0 :#: j1 + n') \<notin> {0}"
+      using zs tps0 by auto
+  qed
+qed
+
+definition tps2 :: "tape list" where
+  "tps2 \<equiv> tps0
+    [j1 := (\<lfloor>zs\<rfloor>, length zs)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 2 + length zs"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+  by (tform time: assms tps: tps1_def tps2_def jk)
+
+definition tps3 :: "tape list" where
+  "tps3 \<equiv> tps0
+    [j1 := (\<lfloor>zs\<rfloor>, length zs),
+     j2 := (\<lfloor>zs = [] \<or> last zs = z\<rfloor>\<^sub>B, 1)]"
+
+lemma tmI [transforms_intros]: "transforms tmI tps2 14 tps3"
+  unfolding tmI_def
+proof (tform tps: tps0 tps2_def jk)
+  have *: "read tps2 ! j1 = \<lfloor>zs\<rfloor> (length zs)"
+    using tps2_def jk tapes_at_read'[of j1 tps2] by simp
+
+  show "tps3 = tps2[j2 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]" if "read tps2 ! j1 \<in> {\<triangleright>, z}"
+  proof -
+    have "zs = [] \<or> last zs = z"
+      using that * contents_inbounds zs
+      by (metis diff_less dual_order.refl insert_iff last_conv_nth length_greater_0_conv proper_symbols_ne1 singletonD zero_less_one)
+    then have "(if zs = [] \<or> last zs = z then 1 else 0) = 1"
+      by simp
+    then show ?thesis
+      using tps2_def tps3_def jk by (smt (verit, best))
+  qed
+  show "tps3 = tps2" if "read tps2 ! j1 \<notin> {\<triangleright>, z}"
+  proof -
+    have "\<not> (zs = [] \<or> last zs = z)"
+      using that * contents_inbounds zs
+      by (metis contents_at_0 dual_order.refl insertCI last_conv_nth length_greater_0_conv list.size(3))
+    then have "(if zs = [] \<or> last zs = z then 1 else 0) = 0"
+      by simp
+    then show ?thesis
+      using tps2_def tps3_def jk tps0 by (smt (verit, best) list_update_id nth_list_update_neq)
+  qed
+  show "10 + 2 * nlength 0 + 2 * nlength 1 + 2 \<le> 14"
+    using nlength_1_simp by simp
+qed
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 16 + length zs"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def by (tform tps: assms)
+
+definition tps4 :: "tape list" where
+  "tps4 \<equiv> tps0
+    [j2 := (\<lfloor>zs = [] \<or> last zs = z\<rfloor>\<^sub>B, 1)]"
+
+lemma tm4:
+  assumes "ttt = 18 + 2 * length zs"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform time: assms tps3_def jk tps: tps3_def jk zs)
+  have "tps3 ! j1 |#=| 1 = (\<lfloor>zs\<rfloor>, 1)"
+    using tps3_def jk zs by simp
+  then show "tps4 = tps3[j1 := tps3 ! j1 |#=| 1]"
+    using tps4_def tps3_def jk tps0(1) by (metis list_update_id list_update_overwrite list_update_swap)
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_empty_or_endswithI [transforms_intros]:
+  fixes j1 j2 :: tapeidx and z :: symbol
+  fixes tps tps' :: "tape list" and k :: nat and zs :: "symbol list"
+  assumes "j1 \<noteq> j2" "j1 < k" "j2 < k"
+    and "length tps = k"
+    and "proper_symbols zs"
+  assumes
+    "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+  assumes "ttt = 18 + 2 * length zs"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>zs = [] \<or> last zs = z\<rfloor>\<^sub>B, 1)]"
+  shows "transforms (tm_empty_or_endswith j1 j2 z) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_empty_or_endswith j1 j2 z .
+  show ?thesis
+    using assms loc.tps4_def loc.tm4 loc.tm4_eq_tm_empty_or_endswith by simp
+qed
+
+
+subsection \<open>Stripping trailing symbols\<close>
+
+text \<open>
+Stripping the symbol $z$ from the end of a symbol sequence @{term zs} means:
+\<close>
+
+definition rstrip :: "symbol \<Rightarrow> symbol list \<Rightarrow> symbol list" where
+  "rstrip z zs \<equiv> take (LEAST i. i \<le> length zs \<and> set (drop i zs) \<subseteq> {z}) zs"
+
+lemma length_rstrip: "length (rstrip z zs) = (LEAST i. i \<le> length zs \<and> set (drop i zs) \<subseteq> {z})"
+  using rstrip_def wellorder_Least_lemma[where ?P="\<lambda>i. i \<le> length zs \<and> set (drop i zs) \<subseteq> {z}"] by simp
+
+lemma length_rstrip_le: "length (rstrip z zs) \<le> length zs"
+  using rstrip_def by simp
+
+lemma rstrip_stripped:
+  assumes "i \<ge> length (rstrip z zs)" and "i < length zs"
+  shows "zs ! i = z"
+proof -
+  let ?P = "\<lambda>i. i \<le> length zs \<and> set (drop i zs) \<subseteq> {z}"
+  have "?P (length zs)"
+    by simp
+  then have "?P i"
+    using assms length_rstrip LeastI[where ?P="?P"] Least_le[where ?P="?P"]
+    by (metis (mono_tags, lifting) dual_order.trans order_less_imp_le set_drop_subset_set_drop)
+  then have "set (drop i zs) \<subseteq> {z}"
+    by simp
+  then show ?thesis
+    using assms(2) by (metis Cons_nth_drop_Suc drop_eq_Nil2 leD list.set(2) set_empty singleton_insert_inj_eq subset_singletonD)
+qed
+
+lemma rstrip_replicate: "rstrip z (replicate n z) = []"
+  using rstrip_def
+  by (metis (no_types, lifting) Least_eq_0 empty_replicate set_drop_subset set_replicate take_eq_Nil zero_le)
+
+lemma rstrip_not_ex:
+  assumes "\<not> (\<exists>i<length zs. zs ! i \<noteq> z)"
+  shows "rstrip z zs = []"
+  using assms rstrip_def by (metis in_set_conv_nth replicate_eqI rstrip_replicate)
+
+lemma
+  assumes "\<exists>i<length zs. zs ! i \<noteq> z"
+  shows rstrip_ex_length: "length (rstrip z zs) > 0"
+    and rstrip_ex_last: "last (rstrip z zs) \<noteq> z"
+proof -
+  let ?P = "\<lambda>i. i \<le> length zs \<and> set (drop i zs) \<subseteq> {z}"
+  obtain i where i: "i < length zs" "zs ! i \<noteq> z"
+    using assms by auto
+  then have "\<not> set (drop i zs) \<subseteq> {z}"
+    by (metis Cons_nth_drop_Suc drop_eq_Nil2 leD list.set(2) set_empty singleton_insert_inj_eq' subset_singletonD)
+  then have "\<not> set (drop 0 zs) \<subseteq> {z}"
+    by (metis drop.simps(1) drop_0 set_drop_subset set_empty subset_singletonD)
+  then show len: "length (rstrip z zs) > 0"
+    using length_rstrip by (metis (no_types, lifting) LeastI bot.extremum drop_all dual_order.refl gr0I list.set(1))
+  let ?j = "length (rstrip z zs) - 1"
+  have 3: "?j < length (rstrip z zs)"
+    using len by simp
+  then have 4: "?j < Least ?P"
+    using length_rstrip by simp
+  have 5: "?P (length (rstrip z zs))"
+    using LeastI_ex[of "?P"] length_rstrip by fastforce
+  show "last (rstrip z zs) \<noteq> z"
+  proof (rule ccontr)
+    assume "\<not> last (rstrip z zs) \<noteq> z"
+    then have "last (rstrip z zs) = z"
+      by simp
+    then have "rstrip z zs ! ?j = z"
+      using len by (simp add: last_conv_nth)
+    then have 2: "zs ! ?j = z"
+      using len length_rstrip rstrip_def by auto
+    have "?P ?j"
+    proof -
+      have "?j \<le> length zs"
+        using 3 length_rstrip_le by (meson le_eq_less_or_eq order_less_le_trans)
+      moreover have "set (drop ?j zs) \<subseteq> {z}"
+        using 5 3 2
+        by (metis Cons_nth_drop_Suc One_nat_def Suc_pred insert_subset len list.simps(15) order_less_le_trans set_eq_subset)
+      ultimately show ?thesis
+        by simp
+    qed
+    then show False
+      using 4 Least_le[of "?P"] by fastforce
+  qed
+qed
+
+text \<open>
+A Turing machine stripping the non-blank, non-start symbol $z$ from a proper
+symbol sequence works in the obvious way.  First it moves to the end of the
+symbol sequence, that is, to the first blank. Then it moves left to the first
+non-$z$ symbol thereby overwriting every symbol with a blank. Finally it
+performs a ``carriage return''.
+\<close>
+
+definition tm_rstrip :: "symbol \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_rstrip z j \<equiv>
+     tm_right_until j {\<box>} ;;
+     tm_left j ;;
+     tm_lconst_until j j (UNIV - {z}) \<box> ;;
+     tm_cr j"
+
+lemma tm_rstrip_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j" and "j < k"
+  shows "turing_machine k G (tm_rstrip z j)"
+  using assms tm_right_until_tm tm_left_tm tm_lconst_until_tm tm_cr_tm tm_rstrip_def
+  by simp
+
+locale turing_machine_rstrip =
+  fixes z :: symbol and j :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_right_until j {\<box>}"
+definition "tm2 \<equiv> tm1 ;; tm_left j"
+definition "tm3 \<equiv> tm2 ;; tm_lconst_until j j (UNIV - {z}) \<box>"
+definition "tm4 \<equiv> tm3 ;; tm_cr j"
+
+lemma tm4_eq_tm_rstrip: "tm4 = tm_rstrip z j"
+  unfolding tm4_def tm3_def tm2_def tm1_def tm_rstrip_def by simp
+
+context
+  fixes tps0 :: "tape list" and zs :: "symbol list" and k :: nat
+  assumes z: "z > 1"
+  assumes zs: "proper_symbols zs"
+  assumes jk: "0 < j" "j < k" "length tps0 = k"
+  assumes tps0: "tps0 ! j = (\<lfloor>zs\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j := (\<lfloor>zs\<rfloor>, Suc (length zs))]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = Suc (length zs)"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: tps0 tps1_def jk time: assms)
+  have *: "tps0 ! j = (\<lfloor>zs\<rfloor>, 1)"
+    using tps0 jk by simp
+  show "rneigh (tps0 ! j) {\<box>} (length zs)"
+    using * zs by (intro rneighI) auto
+qed
+
+definition "tps2 \<equiv> tps0
+  [j := (\<lfloor>zs\<rfloor>, length zs)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = length zs + 2"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+  by (tform tps: tps1_def tps2_def jk time: assms)
+
+definition "tps3 \<equiv> tps0
+  [j := (\<lfloor>rstrip z zs\<rfloor>, length (rstrip z zs))]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = length zs + 2 + Suc (length zs - length (rstrip z zs))"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: tps2_def tps3_def jk time: assms jk tps2_def)
+  let ?n = "length zs - length (rstrip z zs)"
+  have *: "tps2 ! j = (\<lfloor>zs\<rfloor>, length zs)"
+    using tps2_def jk by simp
+  show "lneigh (tps2 ! j) (UNIV - {z}) ?n"
+  proof (cases "\<exists>i<length zs. zs ! i \<noteq> z")
+    case True
+    then have 1: "length (rstrip z zs) > 0"
+      using rstrip_ex_length by simp
+    show ?thesis
+    proof (rule lneighI)
+      show "(tps2 ::: j) (tps2 :#: j - ?n) \<in> UNIV - {z}"
+        using * 1 contents_inbounds True length_rstrip length_rstrip_le rstrip_def rstrip_ex_last
+        by (smt (verit, best) DiffI One_nat_def UNIV_I diff_diff_cancel diff_less fst_conv last_conv_nth
+          le_eq_less_or_eq length_greater_0_conv less_Suc_eq_le nth_take singletonD snd_conv)
+      have "\<And>n'. n' < ?n \<Longrightarrow> (tps2 ::: j) (tps2 :#: j - n') = z"
+        using * rstrip_stripped by simp
+      then show "\<And>n'. n' < ?n \<Longrightarrow> (tps2 ::: j) (tps2 :#: j - n') \<notin> UNIV - {z}"
+        by simp
+    qed
+  next
+    case False
+    then have 1: "rstrip z zs = []"
+      using rstrip_not_ex by simp
+    show ?thesis
+    proof (rule lneighI)
+      show "(tps2 ::: j) (tps2 :#: j - ?n) \<in> UNIV - {z}"
+        using * 1 z by simp
+      show "\<And>n'. n' < ?n \<Longrightarrow> (tps2 ::: j) (tps2 :#: j - n') \<notin> UNIV - {z}"
+        using * rstrip_stripped by simp
+    qed
+  qed
+
+  have "lconstplant (\<lfloor>zs\<rfloor>, length zs) \<box> ?n = (\<lfloor>rstrip z zs\<rfloor>, length (rstrip z zs))"
+    (is "?lhs = _")
+  proof -
+    have "?lhs = (\<lambda>i. if length zs - ?n < i \<and> i \<le> length zs then \<box> else \<lfloor>zs\<rfloor> i, length zs - ?n)"
+      using lconstplant[of "(\<lfloor>zs\<rfloor>, length zs)" 0 "?n"] by auto
+    moreover have "(\<lambda>i. if length zs - ?n < i \<and> i \<le> length zs then \<box> else \<lfloor>zs\<rfloor> i) = \<lfloor>rstrip z zs\<rfloor>"
+    proof
+      fix i
+      consider "length zs - ?n < i \<and> i \<le> length zs" | "i > length zs" | "i \<le> length (rstrip z zs)"
+        by linarith
+      then show "(if length zs - ?n < i \<and> i \<le> length zs then \<box> else \<lfloor>zs\<rfloor> i) = \<lfloor>rstrip z zs\<rfloor> i"
+      proof (cases)
+        case 1
+        then show ?thesis
+          by auto
+      next
+        case 2
+        then show ?thesis
+          by (metis contents_outofbounds diff_diff_cancel length_rstrip_le less_imp_diff_less)
+      next
+        case 3
+        then show ?thesis
+          using contents_def length_rstrip length_rstrip_le rstrip_def by auto
+      qed
+    qed
+    moreover have "length zs - ?n = length (rstrip z zs)"
+      using diff_diff_cancel length_rstrip_le by simp
+    ultimately show ?thesis
+      by simp
+  qed
+  then have "lconstplant (tps2 ! j) \<box> ?n = (\<lfloor>rstrip z zs\<rfloor>, length (rstrip z zs))"
+    using tps2_def jk by simp
+  then show "tps3 = tps2
+    [j := tps2 ! j |-| ?n,
+     j := lconstplant (tps2 ! j) \<box> ?n]"
+    unfolding tps3_def tps2_def by simp
+qed
+
+definition "tps4 \<equiv> tps0
+  [j := (\<lfloor>rstrip z zs\<rfloor>, 1)]"
+
+lemma tm4:
+  assumes "ttt = length zs + 2 + Suc (length zs - length (rstrip z zs)) + length (rstrip z zs) + 2"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: tps3_def tps4_def jk time: assms tps3_def jk)
+  show "clean_tape (tps3 ! j)"
+    using tps3_def jk zs rstrip_def by simp
+qed
+
+lemma tm4':
+  assumes "ttt = 3 * length zs + 5"
+  shows "transforms tm4 tps0 ttt tps4"
+proof -
+  let ?ttt = "length zs + 2 + Suc (length zs - length (rstrip z zs)) + length (rstrip z zs) + 2"
+  have "?ttt = length zs + 5 + (length zs - length (rstrip z zs)) + length (rstrip z zs)"
+    by simp
+  also have "... \<le> length zs + 5 + length zs + length (rstrip z zs)"
+    by simp
+  also have "... \<le> length zs + 5 + length zs + length zs"
+    using length_rstrip_le by simp
+  also have "... = 3 * length zs + 5"
+    by simp
+  finally have "?ttt \<le> 3 * length zs + 5" .
+  then show ?thesis
+    using assms transforms_monotone tm4 by simp
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_rstripI [transforms_intros]:
+  fixes z :: symbol and j :: tapeidx
+  fixes tps tps' :: "tape list" and zs :: "symbol list" and k :: nat
+  assumes "z > 1" and "0 < j" "j < k"
+    and "proper_symbols zs"
+    and "length tps = k"
+  assumes "tps ! j = (\<lfloor>zs\<rfloor>, 1)"
+  assumes "ttt = 3 * length zs + 5"
+  assumes "tps' = tps[j := (\<lfloor>rstrip z zs\<rfloor>, 1)]"
+  shows "transforms (tm_rstrip z j) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_rstrip z j .
+  show ?thesis
+    using assms loc.tm4' loc.tps4_def loc.tm4_eq_tm_rstrip by simp
+qed
+
+
+subsection \<open>Writing arbitrary length sequences of the same symbol\<close>
+
+text \<open>
+The next Turing machine accepts a number $n$ on tape $j_1$ and writes the symbol
+sequence $z^n$ to tape $j_2$. The symbol $z$ is a parameter of the TM. The TM
+decrements the number on tape $j_1$ until it reaches zero.
+\<close>
+
+definition tm_write_replicate :: "symbol \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_write_replicate z j1 j2 \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO
+      tm_char j2 z ;;
+      tm_decr j1
+    DONE ;;
+    tm_cr j2"
+
+lemma tm_write_replicate_tm:
+  assumes "0 < j1" and "0 < j2" and "j1 < k" and "j2 < k" and "j1 \<noteq> j2" and "G \<ge> 4" and "z < G"
+  shows "turing_machine k G (tm_write_replicate z j1 j2)"
+  unfolding tm_write_replicate_def
+  using turing_machine_loop_turing_machine Nil_tm tm_char_tm tm_decr_tm tm_cr_tm assms
+  by simp
+
+locale turing_machine_write_replicate =
+  fixes j1 j2 :: tapeidx and z :: symbol
+begin
+
+definition "tm1 \<equiv> tm_char j2 z"
+definition "tm2 \<equiv> tm1 ;; tm_decr j1"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO tm2 DONE"
+definition "tm3 \<equiv> tmL ;; tm_cr j2"
+
+lemma tm3_eq_tm_write_replicate: "tm3 = tm_write_replicate z j1 j2"
+  using tm3_def tm2_def tm1_def tm_write_replicate_def tmL_def by simp
+
+context
+  fixes tps0 :: "tape list" and k n :: nat
+  assumes jk: "length tps0 = k" "0 < j1" "0 < j2" "j1 \<noteq> j2" "j1 < k" "j2 < k"
+    and z: "1 < z"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    "tps0 ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [j1 := (\<lfloor>n - t\<rfloor>\<^sub>N, 1),
+     j2 := (\<lfloor>replicate t z\<rfloor>, Suc t)]"
+
+lemma tpsL0: "tpsL 0 = tps0"
+  using tpsL_def tps0 jk by (metis One_nat_def diff_zero list_update_id replicate_empty)
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+  "tpsL1 t \<equiv> tps0
+    [j1 := (\<lfloor>n - t\<rfloor>\<^sub>N, 1),
+     j2 := (\<lfloor>replicate (Suc t) z\<rfloor>, Suc (Suc t))]"
+
+lemma tmL1 [transforms_intros]: "transforms tm1 (tpsL t) 1 (tpsL1 t)"
+  unfolding tm1_def
+proof (tform tps: tpsL_def tpsL1_def tps0 jk)
+  have "tpsL t :#: j2 = Suc t"
+    using tpsL1_def jk by (metis length_list_update nth_list_update_eq snd_conv tpsL_def)
+  moreover have "tpsL t ::: j2 = \<lfloor>replicate t z\<rfloor>"
+    using tpsL1_def jk by (metis fst_conv length_list_update nth_list_update_eq tpsL_def)
+  moreover have "\<lfloor>replicate t z\<rfloor>(Suc t := z) = \<lfloor>replicate (Suc t) z\<rfloor>"
+    using contents_snoc by (metis length_replicate replicate_Suc replicate_append_same)
+  ultimately show "tpsL1 t = (tpsL t)[j2 := tpsL t ! j2 |:=| z |+| 1]"
+    unfolding tpsL1_def tpsL_def by simp
+qed
+
+lemma tmL2:
+  assumes "ttt = 9 + 2 * nlength (n - t)"
+  shows "transforms tm2 (tpsL t) ttt (tpsL (Suc t))"
+  unfolding tm2_def
+proof (tform tps: assms tpsL_def tpsL1_def tps0 jk)
+  show "tpsL (Suc t) = (tpsL1 t)[j1 := (\<lfloor>n - t - 1\<rfloor>\<^sub>N, 1)]"
+    unfolding tpsL_def tpsL1_def using jk by (simp add: list_update_swap)
+qed
+
+lemma tmL2' [transforms_intros]:
+  assumes "ttt = 9 + 2 * nlength n"
+  shows "transforms tm2 (tpsL t) ttt (tpsL (Suc t))"
+proof -
+  have "9 + 2 * nlength (n - t) \<le> 9 + 2 * nlength n"
+    using nlength_mono[of "n - t" n] by simp
+  then show ?thesis
+    using assms tmL2 transforms_monotone by blast
+qed
+
+lemma tmL [transforms_intros]:
+  assumes "ttt = n * (11 + 2 * nlength n) + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL n)"
+  unfolding tmL_def
+proof (tform)
+  let ?t = "9 + 2 * nlength n"
+  show "\<And>i. i < n \<Longrightarrow> read (tpsL i) ! j1 \<noteq> \<box>"
+    using jk tpsL_def read_ncontents_eq_0 by simp
+  show "\<not> read (tpsL n) ! j1 \<noteq> \<box>"
+    using jk tpsL_def read_ncontents_eq_0 by simp
+  show "n * (9 + 2 * nlength n + 2) + 1 \<le> ttt"
+    using assms by simp
+qed
+
+definition tps3 :: "tape list" where
+  "tps3 \<equiv> tps0
+    [j1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j2 := (\<lfloor>replicate n z\<rfloor>, 1)]"
+
+lemma tm3:
+  assumes "ttt = n * (12 + 2 * nlength n) + 4"
+  shows "transforms tm3 (tpsL 0) ttt tps3"
+  unfolding tm3_def
+proof (tform tps: z tpsL_def tps3_def tps0 jk)
+  have "ttt = Suc (n * (11 + 2 * nlength n)) + Suc (Suc (Suc n))"
+  proof -
+    have "Suc (n * (11 + 2 * nlength n)) + Suc (Suc (Suc n)) = n * (11 + 2 * nlength n) + 4 + n"
+      by simp
+    also have "... = n * (12 + 2 * nlength n) + 4"
+      by algebra
+    finally have "Suc (n * (11 + 2 * nlength n)) + Suc (Suc (Suc n)) = ttt"
+      using assms by simp
+    then show ?thesis
+      by simp
+  qed
+  then show "ttt = n * (11 + 2 * nlength n) + 1 + (tpsL n :#: j2 + 2)"
+    using tpsL_def jk by simp
+qed
+
+lemma tm3':
+  assumes "ttt = n * (12 + 2 * nlength n) + 4"
+  shows "transforms tm3 tps0 ttt tps3"
+  using tm3 tpsL0 assms by simp
+
+end
+
+end
+
+lemma transforms_tm_write_replicateI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k n :: nat
+  assumes "length tps = k" "0 < j1" "0 < j2" "j1 \<noteq> j2" "j1 < k" "j2 < k" and "1 < z"
+  assumes
+    "tps ! j1 = (\<lfloor>n\<rfloor>\<^sub>N, 1)"
+    "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = n * (12 + 2 * nlength n) + 4"
+  assumes "tps' = tps
+    [j1 := (\<lfloor>0\<rfloor>\<^sub>N, 1),
+     j2 := (\<lfloor>replicate n z\<rfloor>, 1)]"
+  shows "transforms (tm_write_replicate z j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_write_replicate j1 j2 .
+  show ?thesis
+    using assms loc.tm3' loc.tps3_def loc.tm3_eq_tm_write_replicate by simp
+qed
+
+
+subsection \<open>Extracting the elements of a pair\<close>
+
+text \<open>
+In Section~\ref{s:tm-basic-pair} we defined a pairing function for strings. For
+example, $\langle \bbbI\bbbI, \bbbO\bbbO\rangle$ is first mapped to
+$\bbbI\bbbI\#\bbbO\bbbO$ and ultimately represented as
+$\bbbO\bbbI\bbbO\bbbI\bbbI\bbbI\bbbO\bbbO\bbbO\bbbO$. A Turing machine that is
+to compute a function for the argument $\langle \bbbI\bbbI, \bbbO\bbbO\rangle$
+would receive as input the symbols \textbf{0101110000}. Typically the TM would
+then extract the two components \textbf{11} and \textbf{00}. In this section we
+devise TMs to do just that.
+
+As it happens, applying the quaternary alphabet decoding function @{const
+bindecode} (see Section~\ref{s:tm-quaternary}) to such a symbol sequence gets us
+halfway to extracting the elements of the pair. For example, decoding
+\textbf{0101110000} yields @{text "\<one>\<one>\<sharp>\<zero>\<zero>"}, and now the TM only has to
+locate the @{text \<sharp>}.
+
+A Turing machine cannot rely on being given a well-formed pair. After decoding,
+the symbol sequence might have more or fewer than one @{text \<sharp>} symbol or even
+@{text "\<bar>"} symbols. The following functions @{term first} and @{term second}
+are designed to extract the first and second element of a symbol sequence
+representing a pair, and for other symbol sequences at least allow for an
+efficient implementation. Implementations will come further down in this
+section.
+\<close>
+
+definition first :: "symbol list \<Rightarrow> symbol list" where
+  "first ys \<equiv> take (if \<exists>i<length ys. ys ! i \<in> {\<bar>, \<sharp>} then LEAST i. i < length ys \<and> ys ! i \<in> {\<bar>, \<sharp>} else length ys) ys"
+
+definition second :: "symbol list \<Rightarrow> symbol list" where
+  "second zs \<equiv> drop (Suc (length (first zs))) zs"
+
+lemma firstD:
+  assumes "\<exists>i<length ys. ys ! i \<in> {\<bar>, \<sharp>}" and "m = (LEAST i. i < length ys \<and> ys ! i \<in> {\<bar>, \<sharp>})"
+  shows "m < length ys" and "ys ! m \<in> {\<bar>, \<sharp>}" and "\<forall>i<m. ys ! i \<notin> {\<bar>, \<sharp>}"
+  using LeastI_ex[OF assms(1)] assms(2) by simp_all (use less_trans not_less_Least in blast)
+
+lemma firstI:
+  assumes "m < length ys" and "ys ! m \<in> {\<bar>, \<sharp>}" and "\<forall>i<m. ys ! i \<notin> {\<bar>, \<sharp>}"
+  shows "(LEAST i. i < length ys \<and> ys ! i \<in> {\<bar>, \<sharp>}) = m"
+  using assms by (metis (mono_tags, lifting) LeastI less_linear not_less_Least)
+
+lemma length_first_ex:
+  assumes "\<exists>i<length ys. ys ! i \<in> {\<bar>, \<sharp>}" and "m = (LEAST i. i < length ys \<and> ys ! i \<in> {\<bar>, \<sharp>})"
+  shows "length (first ys) = m"
+proof -
+  have "m < length ys"
+    using assms firstD(1) by presburger
+  moreover have "first ys = take m ys"
+    using assms first_def by simp
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma first_notex:
+  assumes "\<not> (\<exists>i<length ys. ys ! i \<in> {\<bar>, \<sharp>})"
+  shows "first ys = ys"
+  using assms first_def by auto
+
+lemma length_first: "length (first ys) \<le> length ys"
+  using length_first_ex first_notex first_def by simp
+
+lemma length_second_first: "length (second zs) = length zs - Suc (length (first zs))"
+  using second_def by simp
+
+lemma length_second: "length (second zs) \<le> length zs"
+  using second_def by simp
+
+text \<open>
+Our next goal is to show that @{const first} and @{const second} really extract
+the first and second element of a pair.
+\<close>
+
+lemma bindecode_bitenc:
+  fixes x :: string
+  shows "bindecode (string_to_symbols (bitenc x)) = string_to_symbols x"
+proof (induction x)
+  case Nil
+  then show ?case
+    using less_2_cases_iff by force
+next
+  case (Cons a x)
+  have "bitenc (a # x) = bitenc [a] @ bitenc x"
+    by simp
+  then have "string_to_symbols (bitenc (a # x)) = string_to_symbols (bitenc [a] @ bitenc x)"
+    by simp
+  then have "string_to_symbols (bitenc (a # x)) = string_to_symbols (bitenc [a]) @ string_to_symbols (bitenc x)"
+    by simp
+  then have "bindecode (string_to_symbols (bitenc (a # x))) =
+      bindecode (string_to_symbols (bitenc [a]) @ string_to_symbols (bitenc x))"
+    by simp
+  also have "... = bindecode (string_to_symbols (bitenc [a])) @ bindecode (string_to_symbols (bitenc x))"
+    using bindecode_append length_bitenc by (metis (no_types, lifting) dvd_triv_left length_map)
+  also have "... = bindecode (string_to_symbols (bitenc [a])) @ string_to_symbols x"
+    using Cons by simp
+  also have "... = string_to_symbols [a] @ string_to_symbols x"
+    using bindecode_def by simp
+  also have "... = string_to_symbols ([a] @ x)"
+    by simp
+  also have "... = string_to_symbols (a # x)"
+    by simp
+  finally show ?case .
+qed
+
+lemma bindecode_string_pair:
+  fixes x u :: string
+  shows "bindecode \<langle>x; u\<rangle> = string_to_symbols x @ [\<sharp>] @ string_to_symbols u"
+proof -
+  have "bindecode \<langle>x; u\<rangle> = bindecode (string_to_symbols (bitenc x @ [True, True] @ bitenc u))"
+    using string_pair_def by simp
+  also have "... = bindecode
+     (string_to_symbols (bitenc x) @
+      string_to_symbols [\<bbbI>, \<bbbI>] @
+      string_to_symbols (bitenc u))"
+    by simp
+  also have "... = bindecode (string_to_symbols (bitenc x)) @
+      bindecode (string_to_symbols [\<bbbI>, \<bbbI>]) @
+      bindecode (string_to_symbols (bitenc u))"
+  proof -
+    have "even (length (string_to_symbols [True, True]))"
+      by simp
+    moreover have "even (length (string_to_symbols (bitenc y)))" for y
+      by (simp add: length_bitenc)
+    ultimately show ?thesis
+      using bindecode_append length_bindecode length_bitenc
+      by (smt (z3) add_mult_distrib2 add_self_div_2 dvd_triv_left length_append length_map mult_2)
+  qed
+  also have "... = string_to_symbols x @ bindecode (string_to_symbols [\<bbbI>, \<bbbI>]) @ string_to_symbols u"
+    using bindecode_bitenc by simp
+  also have "... = string_to_symbols x @ [\<sharp>] @ string_to_symbols u"
+    using bindecode_def by simp
+  finally show ?thesis .
+qed
+
+lemma first_pair:
+  fixes ys :: "symbol list" and x u :: string
+  assumes "ys = bindecode \<langle>x; u\<rangle>"
+  shows "first ys = string_to_symbols x"
+proof -
+  have ys: "ys = string_to_symbols x @ [\<sharp>] @ string_to_symbols u"
+    using bindecode_string_pair assms by simp
+  have bs: "bit_symbols (string_to_symbols x)"
+    by simp
+  have "ys ! (length (string_to_symbols x)) = \<sharp>"
+    using ys by (metis append_Cons nth_append_length)
+  then have ex: "ys ! (length (string_to_symbols x)) \<in> {\<bar>, \<sharp>}"
+    by simp
+  have "(LEAST i. i < length ys \<and> ys ! i \<in> {\<bar>, \<sharp>}) = length (string_to_symbols x)"
+    using ex ys bs by (intro firstI) (simp_all add: nth_append)
+  moreover have "length (string_to_symbols x) < length ys"
+    using ys by simp
+  ultimately have "first ys = take (length (string_to_symbols x)) ys"
+    using ex first_def by auto
+  then show "first ys = string_to_symbols x"
+    using ys by simp
+qed
+
+lemma second_pair:
+  fixes ys :: "symbol list" and x u :: string
+  assumes "ys = bindecode \<langle>x; u\<rangle>"
+  shows "second ys = string_to_symbols u"
+proof -
+  have ys: "ys = string_to_symbols x @ [\<sharp>] @ string_to_symbols u"
+    using bindecode_string_pair assms by simp
+  let ?m = "length (string_to_symbols x)"
+  have "length (first ys) = ?m"
+    using assms first_pair by presburger
+  moreover have "drop (Suc ?m) ys = string_to_symbols u"
+    using ys by simp
+  ultimately have "drop (Suc (length (first ys))) ys = string_to_symbols u"
+    by simp
+  then show ?thesis
+    using second_def by simp
+qed
+
+
+subsubsection \<open>A Turing machine for extracting the first element\<close>
+
+text \<open>
+Unlike most other Turing machines, the one in this section is not meant to be
+reusable, but rather to compute a function, namely the function @{const first}.
+For this reason there are no tape index parameters. Instead, the encoded pair is
+expected on the input tape, and the output is written to the output tape.
+
+\null
+\<close>
+
+lemma bit_symbols_first:
+  assumes "ys = bindecode (string_to_symbols x)"
+  shows "bit_symbols (first ys)"
+proof (cases "\<exists>i<length ys. ys ! i \<in> {\<bar>, \<sharp>}")
+  case True
+  define m where "m = (LEAST i. i < length ys \<and> ys ! i \<in> {\<bar>, \<sharp>})"
+  then have m: "m < length ys" "ys ! m \<in> {\<bar>, \<sharp>}" "\<forall>i<m. ys ! i \<notin> {\<bar>, \<sharp>}"
+    using firstD[OF True] by blast+
+  have len: "length (first ys) = m"
+    using length_first_ex[OF True] m_def by simp
+  have "bit_symbols (string_to_symbols x)"
+    by simp
+  then have "\<forall>i<length ys. ys ! i \<in> {2..<6}"
+    using assms bindecode2345 by simp
+  then have "\<forall>i<m. ys ! i \<in> {2..<6}"
+    using m(1) by simp
+  then have "\<forall>i<m. ys ! i \<in> {2..<4}"
+    using m(3) by fastforce
+  then show ?thesis
+    using first_def len by auto
+next
+  case False
+  then have 1: "\<forall>i<length ys. ys ! i \<notin> {\<bar>, \<sharp>}"
+    by simp
+  have "bit_symbols (string_to_symbols x)"
+    by simp
+  then have "\<forall>i<length ys. ys ! i \<in> {2..<6}"
+    using assms bindecode2345 by simp
+  then have "\<forall>i<length ys. ys ! i \<in> {2..<4}"
+    using 1 by fastforce
+  then show ?thesis
+    using False first_notex by auto
+qed
+
+definition tm_first :: machine where
+  "tm_first \<equiv>
+    tm_right_many {0, 1, 2} ;;
+    tm_bindecode 0 2 ;;
+    tm_cp_until 2 1 {\<box>, \<bar>, \<sharp>}"
+
+lemma tm_first_tm: "G \<ge> 6 \<Longrightarrow> k \<ge> 3 \<Longrightarrow> turing_machine k G tm_first"
+  unfolding tm_first_def
+  using tm_cp_until_tm tm_start_tm tm_bindecode_tm tm_right_many_tm
+  by simp
+
+locale turing_machine_fst_pair =
+  fixes k :: nat
+  assumes k: "k \<ge> 3"
+begin
+
+definition "tm1 \<equiv> tm_right_many {0, 1, 2}"
+definition "tm2 \<equiv> tm1 ;; tm_bindecode 0 2"
+definition "tm3 \<equiv> tm2 ;; tm_cp_until 2 1 {\<box>, \<bar>, \<sharp>}"
+
+lemma tm3_eq_tm_first: "tm3 = tm_first"
+  using tm1_def tm2_def tm3_def tm_first_def by simp
+
+context
+  fixes xs :: "symbol list"
+  assumes bs: "bit_symbols xs"
+begin
+
+definition "tps0 \<equiv> snd (start_config k xs)"
+
+lemma lentps [simp]: "length tps0 = k"
+  using tps0_def start_config_length k by simp
+
+lemma tps0_0: "tps0 ! 0 = (\<lfloor>xs\<rfloor>, 0)"
+  using tps0_def start_config_def contents_def by auto
+
+lemma tps0_gt_0: "j > 0 \<Longrightarrow> j < k \<Longrightarrow> tps0 ! j = (\<lfloor>[]\<rfloor>, 0)"
+  using tps0_def start_config_def contents_def by auto
+
+definition "tps1 \<equiv> tps0
+  [0 := (\<lfloor>xs\<rfloor>, 1),
+   1 := (\<lfloor>[]\<rfloor>, 1),
+   2 := (\<lfloor>[]\<rfloor>, 1)]"
+
+lemma tm1 [transforms_intros]: "transforms tm1 tps0 1 tps1"
+  unfolding tm1_def
+proof (tform)
+  show "tps1 = map (\<lambda>j. if j \<in> {0, 1, 2} then tps0 ! j |+| 1 else tps0 ! j) [0..<length tps0]"
+    (is "_ = ?rhs")
+  proof (rule nth_equalityI)
+    show "length tps1 = length ?rhs"
+      using tps0_def tps1_def by simp
+    show "tps1 ! j = ?rhs ! j" if "j < length tps1" for j
+      using that tps0_0 tps0_gt_0 tps1_def by simp
+  qed
+qed
+
+definition "tps2 \<equiv> tps0
+  [0 := (\<lfloor>xs\<rfloor>, 1),
+   1 := (\<lfloor>[]\<rfloor>, 1),
+   2 := (\<lfloor>bindecode xs\<rfloor>, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 8 + 3 * length xs"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: bs k tps1_def assms tps2_def)
+
+definition "tps3 \<equiv> tps0
+  [0 := (\<lfloor>xs\<rfloor>, 1),
+   1 := (\<lfloor>first (bindecode xs)\<rfloor>, Suc (length (first (bindecode xs)))),
+   2 := (\<lfloor>bindecode xs\<rfloor>, Suc (length (first (bindecode xs))))]"
+
+lemma tm3:
+  assumes "ttt = 8 + 3 * length xs + Suc (length (first (bindecode xs)))"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: k tps2_def time: assms)
+  let ?ys = "bindecode xs"
+  have tps2: "tps2 ! 2 = (\<lfloor>?ys\<rfloor>, 1)"
+    using tps2_def k by simp
+  show "rneigh (tps2 ! 2) {\<box>, \<bar>, \<sharp>} (length (first ?ys))"
+  proof (cases "\<exists>i<length ?ys. ?ys ! i \<in> {\<bar>, \<sharp>}")
+    case ex5: True
+    define m where "m = (LEAST i. i < length ?ys \<and> ?ys ! i \<in> {\<bar>, \<sharp>})"
+    then have m: "m = length (first ?ys)"
+      using length_first_ex ex5 by simp
+    show ?thesis
+    proof (rule rneighI)
+      have "?ys ! m \<in> {\<bar>, \<sharp>}"
+        using firstD m_def ex5 by blast
+      then show "(tps2 ::: 2) (tps2 :#: 2 + length (first ?ys)) \<in> {\<box>, \<bar>, \<sharp>}"
+        using m tps2 contents_def by simp
+      show "(tps2 ::: 2) (tps2 :#: 2 + i) \<notin> {\<box>, \<bar>, \<sharp>}" if "i < length (first ?ys)" for i
+      proof -
+        have "m < length ?ys"
+          using ex5 firstD(1) length_first_ex m by blast
+        then have "length (first ?ys) < length ?ys"
+          using m by simp
+        then have "i < length ?ys"
+          using that by simp
+        then have "?ys ! i \<noteq> 0"
+          using proper_bindecode by fastforce
+        moreover have "?ys ! i \<notin> {\<bar>, \<sharp>}"
+          using ex5 firstD(3) length_first_ex that by blast
+        ultimately show ?thesis
+          using Suc_neq_Zero \<open>i < length (bindecode xs)\<close> tps2 by simp
+      qed
+    qed
+  next
+    case notex5: False
+    then have ys: "?ys = first ?ys"
+      using first_notex by simp
+    show ?thesis
+    proof (rule rneighI)
+      show "(tps2 ::: 2) (tps2 :#: 2 + length (first ?ys)) \<in> {\<box>, \<bar>, \<sharp>}"
+        using ys tps2 by simp
+      show "(tps2 ::: 2) (tps2 :#: 2 + i) \<notin> {\<box>, \<bar>, \<sharp>}" if "i < length (first ?ys)" for i
+        using notex5 that ys proper_bindecode contents_inbounds
+        by (metis Suc_leI add_gr_0 diff_Suc_1 fst_conv gr_implies_not0 insert_iff
+          plus_1_eq_Suc snd_conv tps2 zero_less_one)
+    qed
+  qed
+  show "tps3 = tps2[2 := tps2 ! 2 |+| length (first ?ys), 1 := implant (tps2 ! 2) (tps2 ! 1) (length (first ?ys))]"
+    (is "_ = ?tps")
+  proof -
+    have 0: "tps3 ! 0 = ?tps ! 0"
+      using tps2_def tps3_def by simp
+    have 1: "tps3 ! 2 = ?tps ! 2"
+      using tps2_def tps3_def k by simp
+    have lentps2: "length tps2 > 2"
+      using k tps2_def by simp
+    have "implant (tps2 ! 2) (tps2 ! 1) (length (first ?ys)) =
+      (\<lfloor>first ?ys\<rfloor>, Suc (length (first ?ys)))"
+    proof -
+      have len: "length (first ?ys) \<le> length ?ys"
+        using first_def by simp
+      have "tps2 ! 1 = (\<lfloor>[]\<rfloor>, 1)"
+        using tps2_def lentps2 by simp
+      then have "implant (tps2 ! 2) (tps2 ! 1) (length (first ?ys)) =
+          implant (\<lfloor>?ys\<rfloor>, 1) (\<lfloor>[]\<rfloor>, 1) (length (first ?ys))"
+        using tps2 by simp
+      also have "... = (\<lfloor>take (length (first ?ys)) ?ys\<rfloor>, Suc (length (first ?ys)))"
+        using implant_contents[of 1 "length (first ?ys)" ?ys "[]"] len by simp
+      also have "... = (\<lfloor>first ?ys\<rfloor>, Suc (length (first ?ys)))"
+        using first_def using first_notex length_first_ex by presburger
+      finally show ?thesis .
+    qed
+    moreover have "length tps2 > 2"
+      using k tps2_def by simp
+    ultimately show ?thesis
+      using 0 1 tps2_def tps3_def tps0_def lentps k tps2
+      by (smt (z3) length_list_update list_update_overwrite list_update_swap nth_list_update)
+  qed
+qed
+
+lemma tm3':
+  assumes "ttt = 9 + 4 * length xs"
+  shows "transforms tm3 tps0 ttt tps3"
+proof -
+  let ?t = "8 + 3 * length xs + Suc (length (first (bindecode xs)))"
+  have "?t \<le> 8 + 3 * length xs + Suc (length (bindecode xs))"
+    using length_first by (meson Suc_le_mono add_le_mono order_refl)
+  also have "... \<le> 8 + 3 * length xs + Suc (length xs)"
+    using length_bindecode by simp
+  also have "... = 9 + 3 * length xs + length xs"
+    by simp
+  also have "... = 9 + 4 * length xs"
+    by simp
+  finally have "?t \<le> ttt"
+    using assms(1) by simp
+  moreover have "transforms tm3 tps0 ?t tps3"
+    using tm3 by simp
+  ultimately show ?thesis
+    using transforms_monotone by simp
+qed
+
+end  (* context tps *)
+
+lemma tm3_computes:
+  "computes_in_time k tm3 (\<lambda>x. symbols_to_string (first (bindecode (string_to_symbols x)))) (\<lambda>n. 9 + 4 * n)"
+proof -
+  define f where "f = (\<lambda>x. symbols_to_string (first (bindecode (string_to_symbols x))))"
+  define T :: "nat \<Rightarrow> nat" where "T = (\<lambda>n. 9 + 4 * n)"
+  have "computes_in_time k tm3 f T"
+  proof
+    fix x :: string
+    let ?xs = "string_to_symbols x"
+    have bs: "bit_symbols ?xs"
+      by simp
+    define tps where "tps = tps3 ?xs"
+    have trans: "transforms tm3 (tps0 ?xs) (9 + 4 * length ?xs) tps"
+      using bs tm3' tps_def by blast
+    have "tps3 ?xs ::: 1 = \<lfloor>first (bindecode ?xs)\<rfloor>"
+      using bs tps3_def k by simp
+    moreover have "bit_symbols (first (bindecode ?xs))"
+      using bit_symbols_first by simp
+    ultimately have "tps3 ?xs ::: 1 = string_to_contents (symbols_to_string (first (bindecode ?xs)))"
+      using bit_symbols_to_symbols contents_string_to_contents by simp
+    then have *: "tps ::: 1 = string_to_contents (f x)"
+      using tps_def f_def by auto
+    then have "transforms tm3 (snd (start_config k (string_to_symbols x))) (T (length x)) tps"
+      using trans T_def tps0_def by simp
+    then show "\<exists>tps. tps ::: 1 = string_to_contents (f x) \<and>
+        transforms tm3 (snd (start_config k (string_to_symbols x))) (T (length x)) tps"
+      using * by auto
+  qed
+  then show ?thesis
+    using f_def T_def by simp
+qed
+
+end  (* locale turing_machine_fst_pair *)
+
+lemma tm_first_computes:
+  assumes "k \<ge> 3"
+  shows "computes_in_time
+    k
+    tm_first
+    (\<lambda>x. symbols_to_string (first (bindecode (string_to_symbols x))))
+    (\<lambda>n. 9 + 4 * n)"
+proof -
+  interpret loc: turing_machine_fst_pair k
+    using turing_machine_fst_pair.intro assms by simp
+  show ?thesis
+    using loc.tm3_eq_tm_first loc.tm3_computes by simp
+qed
+
+
+subsubsection \<open>A Turing machine for splitting pairs\<close>
+
+text \<open>
+The next Turing machine expects a proper symbol sequence @{term zs} on tape
+$j_1$ and outputs @{term "first zs"} and @{term "second zs"} on tapes $j_2$ and
+$j_3$, respectively.
+\<close>
+
+definition tm_unpair :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_unpair j1 j2 j3 \<equiv>
+    tm_cp_until j1 j2 {\<box>, \<bar>, \<sharp>} ;;
+    tm_right j1 ;;
+    tm_cp_until j1 j3 {\<box>} ;;
+    tm_cr j1 ;;
+    tm_cr j2 ;;
+    tm_cr j3"
+
+lemma tm_unpair_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j2" and "0 < j3" and "j1 < k" "j2 < k" "j3 < k"
+  shows "turing_machine k G (tm_unpair j1 j2 j3)"
+  using tm_cp_until_tm tm_right_tm tm_cr_tm assms tm_unpair_def by simp
+
+locale turing_machine_unpair =
+  fixes j1 j2 j3 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_cp_until j1 j2 {\<box>, \<bar>, \<sharp>}"
+definition "tm2 \<equiv> tm1 ;; tm_right j1"
+definition "tm3 \<equiv> tm2 ;; tm_cp_until j1 j3 {\<box>}"
+definition "tm4 \<equiv> tm3 ;; tm_cr j1"
+definition "tm5 \<equiv> tm4 ;; tm_cr j2"
+definition "tm6 \<equiv> tm5 ;; tm_cr j3"
+
+lemma tm6_eq_tm_unpair: "tm6 = tm_unpair j1 j2 j3"
+  unfolding tm6_def tm5_def tm4_def tm3_def tm2_def tm1_def tm_unpair_def by simp
+
+context
+  fixes tps0 :: "tape list" and k :: nat and zs :: "symbol list"
+  assumes jk: "0 < j2" "0 < j3" "j1 \<noteq> j2" "j1 \<noteq> j3" "j2 \<noteq> j3" "j1 < k" "j2 < k" "j3 < k" "length tps0 = k"
+    and zs: "proper_symbols zs"
+    and tps0:
+      "tps0 ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+      "tps0 ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+      "tps0 ! j3 = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j1 := (\<lfloor>zs\<rfloor>, Suc (length (first zs))),
+   j2 := (\<lfloor>first zs\<rfloor>, Suc (length (first zs)))]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = Suc (length (first zs))"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+proof (tform tps: assms tps0 tps1_def jk)
+  let ?n = "length (first zs)"
+  have *: "tps0 ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    using tps0 jk by simp
+  show "rneigh (tps0 ! j1) {\<box>, \<bar>, \<sharp>} (length (first zs))"
+  proof (cases "\<exists>i<length zs. zs ! i \<in> {\<bar>, \<sharp>}")
+    case ex5: True
+    define m where "m = (LEAST i. i < length zs \<and> zs ! i \<in> {\<bar>, \<sharp>})"
+    then have m: "m = length (first zs)"
+      using length_first_ex ex5 by simp
+    show ?thesis
+    proof (rule rneighI)
+      have "zs ! m \<in> {\<bar>, \<sharp>}"
+        using firstD m_def ex5 by blast
+      then show "(tps0 ::: j1) (tps0 :#: j1 + length (first zs)) \<in> {\<box>, \<bar>, \<sharp>}"
+        using m * contents_def by simp
+      show "(tps0 ::: j1) (tps0 :#: j1 + i) \<notin> {\<box>, \<bar>, \<sharp>}" if "i < length (first zs)" for i
+      proof -
+        have "m < length zs"
+          using ex5 firstD(1) length_first_ex m by blast
+        then have "length (first zs) < length zs"
+          using m by simp
+        then have "i < length zs"
+          using that by simp
+        then have "zs ! i \<noteq> \<box>"
+          using zs by fastforce
+        moreover have "zs ! i \<notin> {\<bar>, \<sharp>}"
+          using ex5 firstD(3) length_first_ex that by blast
+        ultimately show ?thesis
+          using Suc_neq_Zero `i < length zs` * by simp
+      qed
+    qed
+  next
+    case notex5: False
+    then have ys: "zs = first zs"
+      using first_notex by simp
+    show ?thesis
+    proof (rule rneighI)
+      show "(tps0 ::: j1) (tps0 :#: j1 + length (first zs)) \<in> {\<box>, \<bar>, \<sharp>}"
+        using ys * by simp
+      show "(tps0 ::: j1) (tps0 :#: j1 + i) \<notin> {\<box>, \<bar>, \<sharp>}" if "i < length (first zs)" for i
+        using notex5 that ys proper_bindecode contents_inbounds * zs by auto
+    qed
+  qed
+
+  have 1: "implant (tps0 ! j1) (tps0 ! j2) ?n = (\<lfloor>first zs\<rfloor>, Suc ?n)"
+  proof -
+    have "implant (tps0 ! j1) (tps0 ! j2) ?n =
+        (\<lfloor>[] @ take (length (first zs)) (drop (1 - 1) zs)\<rfloor>,
+         Suc (length []) + length (first zs))"
+      using implant_contents[of 1 "length (first zs)" zs "[]"] tps0(1,2)
+      by (metis (mono_tags, lifting) add.right_neutral diff_Suc_1 le_eq_less_or_eq
+        firstD(1) first_notex length_first_ex less_one list.size(3) plus_1_eq_Suc)
+    then have "implant (tps0 ! j1) (tps0 ! j2) ?n = (\<lfloor>take ?n zs\<rfloor>, Suc ?n)"
+      by simp
+    then show "implant (tps0 ! j1) (tps0 ! j2) ?n = (\<lfloor>first zs\<rfloor>, Suc ?n)"
+      using first_def length_first_ex by auto
+  qed
+  have 2: "tps0 ! j1 |+| ?n = (\<lfloor>zs\<rfloor>, Suc ?n)"
+    using tps0 jk by simp
+  show "tps1 = tps0
+      [j1 := tps0 ! j1 |+| ?n,
+       j2 := implant (tps0 ! j1) (tps0 ! j2) ?n]"
+    unfolding tps1_def using jk 1 2 by simp
+qed
+
+definition "tps2 \<equiv> tps0
+  [j1 := (\<lfloor>zs\<rfloor>, length (first zs) + 2),
+   j2 := (\<lfloor>first zs\<rfloor>, Suc (length (first zs)))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = length (first zs) + 2"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+proof (tform tps: tps1_def jk tps2_def time: assms)
+  have "tps1 ! j1 |+| 1 = (\<lfloor>zs\<rfloor>, length (first zs) + 2)"
+    using tps1_def jk by simp
+  then show "tps2 = tps1[j1 := tps1 ! j1 |+| 1]"
+    unfolding tps2_def tps1_def using jk by (simp add: list_update_swap)
+qed
+
+definition "tps3 \<equiv> tps0
+  [j1 := (\<lfloor>zs\<rfloor>, length (first zs) + 2 + (length zs - Suc (length (first zs)))),
+   j2 := (\<lfloor>first zs\<rfloor>, Suc (length (first zs))),
+   j3 := (\<lfloor>second zs\<rfloor>, Suc (length (second zs)))]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = length (first zs) + 2 + Suc (length zs - Suc (length (first zs)))"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: assms tps2_def tps3_def jk)
+  let ?ll = "length (first zs)"
+  let ?n = "length zs - Suc ?ll"
+  have at_j1: "tps2 ! j1 = (\<lfloor>zs\<rfloor>, length (first zs) + 2)"
+    using tps2_def jk by simp
+  show "rneigh (tps2 ! j1) {0} ?n"
+  proof (rule rneighI)
+    show "(tps2 ::: j1) (tps2 :#: j1 + (length zs - Suc ?ll)) \<in> {0}"
+      using at_j1 by simp
+    show "(tps2 ::: j1) (tps2 :#: j1 + m) \<notin> {0}" if "m < length zs - Suc ?ll" for m
+    proof -
+      have *: "(tps2 ::: j1) (tps2 :#: j1 + m) = \<lfloor>zs\<rfloor> (?ll + 2 + m)"
+        using at_j1 by simp
+      have "Suc ?ll < length zs"
+        using that by simp
+      then have "?ll + 2 + m \<le> Suc (length zs)"
+        using that by simp
+      then have "\<lfloor>zs\<rfloor> (?ll + 2 + m) = zs ! (?ll + 1 + m)"
+        using that by simp
+      then have "\<lfloor>zs\<rfloor> (?ll + 2 + m) > 0"
+        using zs that by (metis add.commute gr0I less_diff_conv not_add_less2 plus_1_eq_Suc)
+      then show ?thesis
+        using * by simp
+    qed
+  qed
+
+  have 1: "implant (tps2 ! j1) (tps2 ! j3) ?n = (\<lfloor>second zs\<rfloor>, Suc (length (second zs)))"
+  proof (cases "Suc ?ll \<le> length zs")
+    case True
+    have "implant (tps2 ! j1) (tps2 ! j3) ?n = implant (\<lfloor>zs\<rfloor>, ?ll + 2) (\<lfloor>[]\<rfloor>, 1) ?n"
+      using tps2_def jk by (metis at_j1 nth_list_update_neq' tps0(3))
+    also have "... = (\<lfloor>take ?n (drop (Suc ?ll) zs)\<rfloor>, Suc ?n)"
+      using True implant_contents
+      by (metis (no_types, lifting) One_nat_def add.commute add_2_eq_Suc' append.simps(1) diff_Suc_1
+        dual_order.refl le_add_diff_inverse2 list.size(3) plus_1_eq_Suc zero_less_Suc)
+    also have "... = (\<lfloor>take (length (second zs)) (drop (Suc ?ll) zs)\<rfloor>, Suc (length (second zs)))"
+      using length_second_first by simp
+    also have "... = (\<lfloor>second zs\<rfloor>, Suc (length (second zs)))"
+      using second_def by simp
+    finally show ?thesis .
+  next
+    case False
+    then have "?n = 0"
+      by simp
+    then have "implant (tps2 ! j1) (tps2 ! j3) ?n = implant (\<lfloor>zs\<rfloor>, ?ll + 2) (\<lfloor>[]\<rfloor>, 1) 0"
+      using tps2_def jk by (metis at_j1 nth_list_update_neq' tps0(3))
+    then have "implant (tps2 ! j1) (tps2 ! j3) ?n = (\<lfloor>[]\<rfloor>, 1)"
+      using transplant_0 by simp
+    moreover have "second zs = []"
+      using False second_def by simp
+    ultimately show ?thesis
+      by simp
+  qed
+
+  show "tps3 = tps2
+      [j1 := tps2 ! j1 |+| ?n,
+       j3 := implant (tps2 ! j1) (tps2 ! j3) ?n]"
+    using tps3_def tps2_def using 1 jk at_j1 by (simp add: list_update_swap[of j1])
+qed
+
+definition "tps4 \<equiv> tps0
+  [j1 := (\<lfloor>zs\<rfloor>, 1),
+   j2 := (\<lfloor>first zs\<rfloor>, Suc (length (first zs))),
+   j3 := (\<lfloor>second zs\<rfloor>, Suc (length (second zs)))]"
+
+lemma tm4:
+  assumes "ttt = 2 * length (first zs) + 7 + 2 * (length zs - Suc (length (first zs)))"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def
+proof (tform tps: assms tps3_def tps4_def jk zs)
+  have "tps3 ! j1 |#=| 1 = (\<lfloor>zs\<rfloor>, 1)"
+    using tps3_def jk by simp
+  then show "tps4 = tps3[j1 := tps3 ! j1 |#=| 1]"
+    unfolding tps4_def tps3_def using jk by (simp add: list_update_swap)
+qed
+
+lemma tm4' [transforms_intros]:
+  assumes "ttt = 4 * length zs + 7"
+  shows "transforms tm4 tps0 ttt tps4"
+proof -
+  have "2 * length (first zs) + 7 + 2 * (length zs - Suc (length (first zs))) \<le> 2 * length (first zs) + 7 + 2 * length zs"
+    by simp
+  also have "... \<le> 2 * length zs + 7 + 2 * length zs"
+    using length_first by simp
+  also have "... = ttt"
+    using assms by simp
+  finally have "2 * length (first zs) + 7 + 2 * (length zs - Suc (length (first zs))) \<le> ttt" .
+  then show ?thesis
+    using assms tm4 transforms_monotone by simp
+qed
+
+definition "tps5 \<equiv> tps0
+  [j1 := (\<lfloor>zs\<rfloor>, 1),
+   j2 := (\<lfloor>first zs\<rfloor>, 1),
+   j3 := (\<lfloor>second zs\<rfloor>, Suc (length (second zs)))]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 4 * length zs + 9 + Suc (length (first zs))"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def
+proof (tform tps: assms tps4_def tps5_def jk)
+  show "clean_tape (tps4 ! j2)"
+    using zs first_def tps4_def jk by simp
+  have "tps4 ! j2 |#=| 1 = (\<lfloor>first zs\<rfloor>, 1)"
+    using tps4_def jk by simp
+  then show "tps5 = tps4[j2 := tps4 ! j2 |#=| 1]"
+    unfolding tps5_def tps4_def using jk by (simp add: list_update_swap)
+qed
+
+definition "tps6 \<equiv> tps0
+  [j1 := (\<lfloor>zs\<rfloor>, 1),
+   j2 := (\<lfloor>first zs\<rfloor>, 1),
+   j3 := (\<lfloor>second zs\<rfloor>, 1)]"
+
+lemma tm6:
+  assumes "ttt = 4 * length zs + 11 + Suc (length (first zs)) + Suc (length (second zs))"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+proof (tform tps: assms tps5_def tps6_def jk)
+  show "clean_tape (tps5 ! j3)"
+    using zs second_def tps5_def jk by simp
+qed
+
+definition "tps6' \<equiv> tps0
+  [j2 := (\<lfloor>first zs\<rfloor>, 1),
+   j3 := (\<lfloor>second zs\<rfloor>, 1)]"
+
+lemma tps6': "tps6' = tps6"
+  using tps6_def tps6'_def list_update_id tps0(1) by metis
+
+lemma tm6':
+  assumes "ttt = 6 * length zs + 13"
+  shows "transforms tm6 tps0 ttt tps6'"
+proof -
+  have "4 * length zs + 11 + Suc (length (first zs)) + Suc (length (second zs)) \<le>
+      4 * length zs + 13 + length zs + length (second zs)"
+    using length_first by simp
+  also have "... \<le> 6 * length zs + 13"
+    using length_second by simp
+  finally have "4 * length zs + 11 + Suc (length (first zs)) + Suc (length (second zs)) \<le> ttt"
+    using assms by simp
+  then show ?thesis
+    using tm6 tps6' transforms_monotone by simp
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_unpairI [transforms_intros]:
+  fixes j1 j2 j3 :: tapeidx
+  fixes tps tps' :: "tape list" and k :: nat and zs :: "symbol list"
+  assumes "0 < j2" "0 < j3" "j1 \<noteq> j2" "j1 \<noteq> j3" "j2 \<noteq> j3" "j1 < k" "j2 < k" "j3 < k"
+    and "length tps = k"
+    and "proper_symbols zs"
+  assumes
+    "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! j3 = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 6 * length zs + 13"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>first zs\<rfloor>, 1),
+     j3 := (\<lfloor>second zs\<rfloor>, 1)]"
+  shows "transforms (tm_unpair j1 j2 j3) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_unpair j1 j2 j3 .
+  show ?thesis
+    using assms loc.tps6'_def loc.tm6' loc.tm6_eq_tm_unpair by metis
+qed
+
+end
diff --git a/thys/Cook_Levin/Two_Four_Symbols.thy b/thys/Cook_Levin/Two_Four_Symbols.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Two_Four_Symbols.thy
@@ -0,0 +1,1514 @@
+section \<open>Mapping between a binary and a quaternary alphabet\label{s:tm-quaternary}\<close>
+
+theory Two_Four_Symbols
+  imports Arithmetic
+begin
+
+text \<open>
+Functions are defined over bit strings. For Turing machines these bits are
+represented by the symbols \textbf{0} and \textbf{1}. Sometimes we want a TM to
+receive a pair of bit strings or output a list of numbers. Or we might want the
+TM to interpret the input as a list of lists of numbers. All these objects can
+naturally be represented over a four-symbol (quaternary) alphabet, as we have
+seen for pairs in Section~\ref{s:tm-basic-pair} and for the lists in
+Sections~\ref{s:tm-numlist} and~\ref{s:tm-numlistlist}.
+
+To accommodate the aforementioned use cases, we define a straightforward mapping
+between the binary alphabet \textbf{01} and the quaternary alphabet @{text
+"\<zero>\<one>\<bar>\<sharp>"} and devise Turing machines to encode and decode symbol sequences.
+\<close>
+
+
+subsection \<open>Encoding and decoding\label{s:tm-quaternary-encoding}\<close>
+
+text \<open>
+The encoding maps:
+
+\begin{tabular}{lcl}
+    @{text \<zero>} & $\mapsto$ & @{text "\<zero>\<zero>"}\\
+    @{text \<one>} & $\mapsto$ & @{text "\<zero>\<one>"}\\
+    @{text "\<bar>"} & $\mapsto$ & @{text "\<one>\<zero>"}\\
+    @{text \<sharp>} & $\mapsto$ & @{text "\<one>\<one>"}\\
+\end{tabular}
+\<close>
+
+text \<open>
+For example, the list $[6,0,1]$ is represented by the symbols @{text
+"\<zero>\<one>\<one>\<bar>\<bar>\<one>\<bar>"}, which is encoded as @{text "\<zero>\<zero>\<zero>\<one>\<zero>\<one>\<one>\<zero>\<one>\<zero>\<zero>\<one>\<one>\<zero>"}.
+Pairing this sequence with the symbol sequence @{text "\<zero>\<one>\<one>\<zero>"} yields @{text
+"\<zero>\<zero>\<zero>\<one>\<zero>\<one>\<one>\<zero>\<one>\<zero>\<zero>\<one>\<one>\<zero>\<sharp>\<zero>\<one>\<one>\<zero>"}, which is encoded as @{text
+"\<zero>\<zero>\<zero>\<zero>\<zero>\<zero>\<zero>\<one>\<zero>\<zero>\<zero>\<one>\<zero>\<one>\<zero>\<zero>\<zero>\<one>\<zero>\<zero>\<zero>\<zero>\<zero>\<one>\<zero>\<one>\<zero>\<zero>\<one>\<one>\<zero>\<zero>\<zero>\<one>\<zero>\<one>\<zero>\<zero>"}.
+
+\null
+\<close>
+
+definition binencode :: "symbol list \<Rightarrow> symbol list" where
+  "binencode ys \<equiv> concat (map (\<lambda>y. [tosym ((y - 2) div 2), tosym ((y - 2) mod 2)]) ys)"
+
+lemma length_binencode [simp]: "length (binencode ys) = 2 * length ys"
+  using binencode_def by (induction ys) simp_all
+
+lemma binencode_snoc:
+  "binencode (zs @ [\<zero>]) = binencode zs @ [\<zero>, \<zero>]"
+  "binencode (zs @ [\<one>]) = binencode zs @ [\<zero>, \<one>]"
+  "binencode (zs @ [\<bar>]) = binencode zs @ [\<one>, \<zero>]"
+  "binencode (zs @ [\<sharp>]) = binencode zs @ [\<one>, \<one>]"
+  using binencode_def by simp_all
+
+lemma binencode_at_even:
+  assumes "i < length ys"
+  shows "binencode ys ! (2 * i) = 2 + (ys ! i - 2) div 2"
+  using assms
+proof (induction ys arbitrary: i)
+  case Nil
+  then show ?case
+    by simp
+next
+  case (Cons y ys)
+  have *: "binencode (y # ys) = [2 + (y - 2) div 2, 2 + (y - 2) mod 2] @ binencode ys"
+    using binencode_def by simp
+  show ?case
+  proof (cases "i = 0")
+    case True
+    then show ?thesis
+      using * by simp
+  next
+    case False
+    then have "binencode (y # ys) ! (2 * i) = binencode ys ! (2 * i - 2)"
+      using *
+      by (metis One_nat_def length_Cons less_one list.size(3) mult_2 nat_mult_less_cancel_disj
+        nth_append numerals(2) plus_1_eq_Suc)
+    also have "... = binencode ys ! (2 * (i - 1))"
+      using False by (simp add: right_diff_distrib')
+    also have "... = 2 + (ys ! (i - 1) - 2) div 2"
+      using False Cons by simp
+    also have "... = 2 + ((y # ys) ! i - 2) div 2"
+      using False by simp
+    finally show ?thesis .
+  qed
+qed
+
+lemma binencode_at_odd:
+  assumes "i < length ys"
+  shows "binencode ys ! (2 * i + 1) = 2 + (ys ! i - 2) mod 2"
+  using assms
+proof (induction ys arbitrary: i)
+  case Nil
+  then show ?case
+    by simp
+next
+  case (Cons y ys)
+  have *: "binencode (y # ys) = [2 + (y - 2) div 2, 2 + (y - 2) mod 2] @ binencode ys"
+    using binencode_def by simp
+  show ?case
+  proof (cases "i = 0")
+    case True
+    then show ?thesis
+      using * by simp
+  next
+    case False
+    then have "binencode (y # ys) ! (2 * i + 1) = binencode ys ! (2 * i + 1 - 2)"
+      using * by simp
+    also have "... = binencode ys ! (2 * (i - 1) + 1)"
+      using False
+      by (metis Nat.add_diff_assoc2 One_nat_def Suc_leI diff_mult_distrib2 mult_2 mult_le_mono2 nat_1_add_1 neq0_conv)
+    also have "... = 2 + (ys ! (i - 1) - 2) mod 2"
+      using False Cons by simp
+    also have "... = 2 + ((y # ys) ! i - 2) mod 2"
+      using False by simp
+    finally show ?thesis .
+  qed
+qed
+
+text \<open>
+While @{const binencode} is defined for arbitrary symbol sequences, we only
+consider sequences over @{text "\<zero>\<one>\<bar>\<sharp>"} to be binencodable.
+\<close>
+
+abbreviation binencodable :: "symbol list \<Rightarrow> bool" where
+  "binencodable ys \<equiv> \<forall>i<length ys. 2 \<le> ys ! i \<and> ys ! i < 6"
+
+lemma binencodable_append:
+  assumes "binencodable xs" and "binencodable ys"
+  shows "binencodable (xs @ ys)"
+  using assms prop_list_append by (simp add: nth_append)
+
+lemma bit_symbols_binencode:
+  assumes "binencodable ys"
+  shows "bit_symbols (binencode ys)"
+proof -
+  have "2 \<le> binencode ys ! i \<and> binencode ys ! i \<le> 3" if "i < length (binencode ys)" for i
+  proof (cases "even i")
+    case True
+    then have len: "i div 2 < length ys"
+      using length_binencode that by simp
+    moreover have "2 * (i div 2) = i"
+      using True by simp
+    ultimately have "binencode ys ! i = 2 + (ys ! (i div 2) - 2) div 2"
+      using binencode_at_even[of "i div 2" ys] by simp
+    moreover have "2 \<le> ys ! (i div 2) \<and> ys ! (i div 2) < 6"
+      using len assms by simp
+    ultimately show ?thesis
+      by auto
+  next
+    case False
+    then have len: "i div 2 < length ys"
+      using length_binencode that by simp
+    moreover have "2 * (i div 2) + 1 = i"
+      using False by simp
+    ultimately have "binencode ys ! i = 2 + (ys ! (i div 2) - 2) mod 2"
+      using binencode_at_odd[of "i div 2" ys] by simp
+    moreover have "2 \<le> ys ! (i div 2) \<and> ys ! (i div 2) < 6"
+      using len assms by simp
+    ultimately show ?thesis
+      by simp
+  qed
+  then show ?thesis
+    by fastforce
+qed
+
+text \<open>
+An encoded symbol sequence is of even length. When decoding a symbol sequence of
+odd length, we ignore the last symbol. For example, @{text "\<zero>\<one>\<one>\<one>\<zero>\<zero>"} and
+@{text "\<zero>\<one>\<one>\<one>\<zero>\<zero>\<one>"} are both decoded to @{text "\<one>\<sharp>\<zero>"}.
+
+The bit symbol sequence @{term "[a, b]"} is decoded to this symbol:
+\<close>
+
+abbreviation decsym :: "symbol \<Rightarrow> symbol \<Rightarrow> symbol" where
+  "decsym a b \<equiv> tosym (2 * todigit a + todigit b)"
+
+definition bindecode :: "symbol list \<Rightarrow> symbol list" where
+  "bindecode zs \<equiv> map (\<lambda>i. decsym (zs ! (2 * i)) (zs ! (Suc (2 * i)))) [0..<length zs div 2]"
+
+lemma length_bindecode [simp]: "length (bindecode zs) = length zs div 2"
+  using bindecode_def by simp
+
+lemma bindecode_at:
+  assumes "i < length zs div 2"
+  shows "bindecode zs ! i = decsym (zs ! (2 * i)) (zs ! (Suc (2 * i)))"
+  using assms bindecode_def by simp
+
+lemma proper_bindecode: "proper_symbols (bindecode zs)"
+  using bindecode_at by simp
+
+lemma bindecode2345:
+  assumes "bit_symbols zs"
+  shows "\<forall>i<length (bindecode zs). bindecode zs ! i \<in> {2..<6}"
+  using assms bindecode_at by simp
+
+lemma bindecode_odd:
+  assumes "length zs = 2 * n + 1"
+  shows "bindecode zs = bindecode (take (2 * n) zs)"
+proof -
+  have 1: "take (2 * n) zs ! (2 * i) = zs ! (2 * i)" if "i < n" for i
+    using assms that by simp
+  have 2: "take (2 * n) zs ! (Suc (2 * i)) = zs ! (Suc (2 * i))" if "i < n" for i
+    using assms that by simp
+  have "bindecode (take (2 * n) zs) =
+      map (\<lambda>i. decsym ((take (2 * n) zs) ! (2 * i)) ((take (2 * n) zs) ! (Suc (2 * i)))) [0..<length (take (2 * n) zs) div 2]"
+    using bindecode_def by simp
+  also have "... = map (\<lambda>i. decsym ((take (2 * n) zs) ! (2 * i)) ((take (2 * n) zs) ! (Suc (2 * i)))) [0..<n]"
+    using assms by (simp add: min_absorb2)
+  also have "... = map (\<lambda>i. decsym (zs ! (2 * i)) (zs ! (Suc (2 * i)))) [0..<n]"
+    by simp
+  also have "... = map (\<lambda>i. decsym (zs ! (2 * i)) (zs ! (Suc (2 * i)))) [0..<length zs div 2]"
+    using assms by simp
+  also have "... = bindecode zs"
+    using bindecode_def by simp
+  finally show ?thesis
+    by simp
+qed
+
+lemma bindecode_append:
+  assumes "even (length ys)" and "even (length zs)"
+  shows "bindecode (ys @ zs) = bindecode ys @ bindecode zs"
+    (is "?lhs = ?rhs")
+proof (rule nth_equalityI)
+  show 1: "length ?lhs = length ?rhs"
+    using assms by simp
+  show "?lhs ! i = ?rhs ! i" if "i < length ?lhs" for i
+  proof (cases "i < length ys div 2")
+    case True
+    have "?lhs ! i = decsym ((ys @ zs) ! (2 * i)) ((ys @ zs) ! (Suc (2 * i)))"
+      using that bindecode_at length_bindecode by simp
+    also have "... = decsym (ys ! (2 * i)) ((ys @ zs) ! (Suc (2 * i)))"
+      using True assms(1)
+      by (metis Suc_1 dvd_mult_div_cancel nat_mult_less_cancel_disj nth_append zero_less_Suc)
+    also have "... = decsym (ys ! (2 * i)) (ys ! (Suc (2 * i)))"
+      using True assms(1)
+      by (metis Suc_1 Suc_lessI Suc_mult_less_cancel1 dvd_mult_div_cancel dvd_triv_left even_Suc nth_append)
+    also have "... = bindecode ys ! i"
+      using True bindecode_at by simp
+    also have "... = ?rhs ! i"
+      by (simp add: True nth_append)
+    finally show ?thesis .
+  next
+    case False
+    let ?l = "length ys"
+    have l: "length (bindecode ys) = ?l div 2"
+      by simp
+    have "?lhs ! i = decsym ((ys @ zs) ! (2 * i)) ((ys @ zs) ! (Suc (2 * i)))"
+      using that bindecode_at length_bindecode by simp
+    also have "... = decsym (zs ! (2 * i - ?l)) ((ys @ zs) ! (Suc (2 * i)))"
+      using False assms
+      by (metis dvd_mult_div_cancel nat_mult_less_cancel_disj nth_append)
+    also have "... = decsym (zs ! (2 * i - ?l)) (zs ! (Suc (2 * i) - ?l))"
+      using False assms
+      by (metis (no_types, lifting) Suc_eq_plus1 add_lessD1 dvd_mult_div_cancel nat_mult_less_cancel_disj nth_append)
+    also have "... = bindecode zs ! (i - ?l div 2)"
+      using False bindecode_at that assms 1
+       by (smt (z3) Suc_eq_plus1 add_diff_inverse_nat diff_add_inverse diff_mult_distrib2 dvd_mult_div_cancel
+         left_add_mult_distrib length_append length_bindecode mult.commute nat_add_left_cancel_less)
+    also have "... = (bindecode ys @ bindecode zs) ! i"
+      using l False by (simp add: nth_append)
+    finally show ?thesis .
+  qed
+qed
+
+lemma bindecode_take_snoc:
+  assumes "i < length zs div 2"
+  shows "bindecode (take (2 * i) zs) @ [decsym (zs ! (2*i)) (zs ! (Suc (2*i)))] = bindecode (take (2 * Suc i) zs)"
+proof -
+  let ?ys = "take (2 * i) zs"
+  let ?zs = "take 2 (drop (2 * i) zs)"
+  have "?zs ! 0 = zs ! (2 * i)"
+    using assms by simp
+  moreover have "?zs ! 1 = zs ! (Suc (2 * i))"
+    using assms by simp
+  moreover have "length ?zs = 2"
+    using assms by simp
+  ultimately have "?zs = [zs ! (2 * i), zs ! (Suc (2 * i))]"
+    by (metis (no_types, lifting) Cons_nth_drop_Suc One_nat_def Suc_1 diff_Suc_1 drop0
+     length_0_conv length_drop lessI list.inject zero_less_Suc)
+  moreover have "take (2 * i + 2) zs = ?ys @ ?zs"
+    using assms take_add by blast
+  ultimately have "take (2 * Suc i) zs = ?ys @ [zs ! (2 * i), zs ! (Suc (2 * i))]"
+    by simp
+  moreover have "even (length ?ys)"
+  proof -
+    have "length ?ys = 2 * i"
+      using assms by simp
+    then show ?thesis
+      by simp
+  qed
+  ultimately have "bindecode (take (2 * Suc i) zs) = bindecode ?ys @ bindecode [zs ! (2 * i), zs ! (Suc (2 * i))]"
+    using bindecode_append by simp
+  then show ?thesis
+    using bindecode_def by simp
+qed
+
+lemma bindecode_encode:
+  assumes "binencodable ys"
+  shows "bindecode (binencode ys) = ys"
+proof (rule nth_equalityI)
+  show 1: "length (bindecode (binencode ys)) = length ys"
+    using binencode_def bindecode_def by fastforce
+  show "bindecode (binencode ys) ! i = ys ! i" if "i < length (bindecode (binencode ys))" for i
+  proof -
+    have len: "i < length ys"
+      using that 1 by simp
+    let ?zs = "binencode ys"
+    have "i < length ?zs div 2"
+      using len by simp
+    then have "bindecode ?zs ! i = decsym (?zs ! (2 * i)) (?zs ! (Suc (2 * i)))"
+      using bindecode_def by simp
+    also have "... = decsym (2 + (ys ! i - 2) div 2) (2 + (ys ! i - 2) mod 2)"
+      using binencode_at_even[OF len] binencode_at_odd[OF len] by simp
+    also have "... = ys ! i"
+    proof -
+      have "ys ! i = 2 \<or> ys ! i = 3 \<or> ys ! i = 4 \<or> ys ! i = 5"
+        using assms len
+        by (smt (z3) Suc_1 add_Suc_shift add_cancel_right_left eval_nat_numeral(3)
+          less_Suc_eq numeral_3_eq_3 numeral_Bit0 verit_comp_simplify1(3))
+      then show ?thesis
+        by auto
+    qed
+    finally show "bindecode ?zs ! i = ys ! i" .
+  qed
+qed
+
+lemma binencode_decode:
+  assumes "bit_symbols zs" and "even (length zs)"
+  shows "binencode (bindecode zs) = zs"
+proof (rule nth_equalityI)
+  let ?ys = "bindecode zs"
+  show 1: "length (binencode ?ys) = length zs"
+    using binencode_def bindecode_def assms(2) by fastforce
+  show "binencode ?ys ! i = zs ! i" if "i < length (binencode ?ys)" for i
+  proof -
+    have ilen: "i < length zs"
+      using 1 that by simp
+    show ?thesis
+    proof (cases "even i")
+      case True
+      let ?j = "i div 2"
+      have jlen: "?j < length zs div 2"
+        using ilen by (simp add: assms(2) less_mult_imp_div_less)
+      then have ysj: "?ys ! ?j = decsym (zs ! (2 * ?j)) (zs ! (Suc (2 * ?j)))"
+        using bindecode_def by simp
+      have "binencode ?ys ! i = binencode ?ys ! (2 * ?j)"
+        by (simp add: True)
+      also have "... = 2 + (?ys ! ?j - 2) div 2"
+        using binencode_at_even jlen by simp
+      also have "... = zs ! (2 * ?j)"
+        using ysj True assms(1) ilen by auto
+      also have "... = zs ! i"
+        using True by simp
+      finally show "binencode ?ys ! i = zs ! i" .
+    next
+      case False
+      let ?j = "i div 2"
+      have jlen: "?j < length zs div 2"
+        using ilen by (simp add: assms(2) less_mult_imp_div_less)
+      then have ysj: "?ys ! ?j = decsym (zs ! (2 * ?j)) (zs ! (Suc (2 * ?j)))"
+        using bindecode_def by simp
+      have "binencode ?ys ! i = binencode ?ys ! (2 * ?j + 1)"
+        by (simp add: False)
+      also have "... = 2 + (?ys ! ?j - 2) mod 2"
+        using binencode_at_odd jlen by simp
+      also have "... = zs ! (2 * ?j + 1)"
+        using ysj False assms(1) ilen by auto
+      also have "... = zs ! i"
+        using False by simp
+      finally show "binencode ?ys ! i = zs ! i" .
+    qed
+  qed
+qed
+
+lemma binencode_inj:
+  assumes "binencodable xs" and "binencodable ys" and "binencode xs = binencode ys"
+  shows "xs = ys"
+  using assms bindecode_encode by metis
+
+
+subsection \<open>Turing machines for encoding and decoding\<close>
+
+text \<open>
+The next Turing machine implements @{const binencode} for @{const binencodable}
+symbol sequences. It expects a symbol sequence @{term zs} on tape $j_1$ and
+writes @{term "binencode zs"} to tape $j_2$.
+\<close>
+
+definition tm_binencode :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_binencode j1 j2 \<equiv>
+    WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO
+      IF \<lambda>rs. rs ! j1 = \<zero> THEN
+        tm_print j2 [\<zero>, \<zero>]
+      ELSE
+        IF \<lambda>rs. rs ! j1 = \<one> THEN
+          tm_print j2 [\<zero>, \<one>]
+        ELSE
+          IF \<lambda>rs. rs ! j1 = \<bar> THEN
+            tm_print j2 [\<one>, \<zero>]
+          ELSE
+            tm_print j2 [\<one>, \<one>]
+          ENDIF
+        ENDIF
+      ENDIF ;;
+      tm_right j1
+    DONE"
+
+lemma tm_binencode_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "j1 < k" and "j2 < k" and "0 < j2"
+  shows "turing_machine k G (tm_binencode j1 j2)"
+proof -
+  have *: "symbols_lt G [\<zero>, \<zero>]" "symbols_lt G [\<zero>, \<one>]" "symbols_lt G [\<one>, \<zero>]" "symbols_lt G [\<one>, \<one>]"
+    using assms(2) by (simp_all add: nth_Cons')
+  then have "turing_machine k G (tm_print j2 [\<zero>, \<zero>])"
+    using tm_print_tm[OF assms(5,4,2)] assms by blast
+  moreover have "turing_machine k G (tm_print j2 [\<zero>, \<one>])"
+    using * tm_print_tm[OF assms(5,4,2)] assms by blast
+  moreover have "turing_machine k G (tm_print j2 [\<one>, \<zero>])"
+    using * tm_print_tm[OF assms(5,4,2)] assms by blast
+  moreover have "turing_machine k G (tm_print j2 [\<one>, \<one>])"
+    using * tm_print_tm[OF assms(5,4,2)] assms by blast
+  ultimately show ?thesis
+    unfolding tm_binencode_def
+    using turing_machine_loop_turing_machine Nil_tm turing_machine_branch_turing_machine tm_right_tm assms
+    by simp
+qed
+
+locale turing_machine_binencode =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> IF \<lambda>rs. rs ! j1 = \<bar> THEN tm_print j2 [\<one>, \<zero>] ELSE tm_print j2 [\<one>, \<one>] ENDIF"
+definition "tm2 \<equiv> IF \<lambda>rs. rs ! j1 = \<one> THEN tm_print j2 [\<zero>, \<one>] ELSE tm1 ENDIF"
+definition "tm3 \<equiv> IF \<lambda>rs. rs ! j1 = \<zero> THEN tm_print j2 [\<zero>, \<zero>] ELSE tm2 ENDIF"
+definition "tm4 \<equiv> tm3 ;; tm_right j1"
+definition "tm5 \<equiv> WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO tm4 DONE"
+
+lemma tm5_eq_tm_binencode: "tm5 = tm_binencode j1 j2"
+  using tm5_def tm4_def tm3_def tm2_def tm1_def tm_binencode_def by simp
+
+context
+  fixes k :: nat and tps0 :: "tape list" and zs :: "symbol list"
+  assumes jk: "k = length tps0" "j1 \<noteq> j2" "0 < j2" "j1 < k" "j2 < k"
+  assumes zs: "binencodable zs"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps0 ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [j1 := (\<lfloor>zs\<rfloor>, Suc t),
+     j2 := (\<lfloor>binencode (take t zs)\<rfloor>, Suc (2 * t))]"
+
+lemma tpsL_0: "tpsL 0 = tps0"
+  unfolding tpsL_def using tps0 jk
+  by (metis One_nat_def length_0_conv length_binencode list_update_id mult_0_right take0)
+
+definition tpsL1 :: "nat \<Rightarrow> tape list" where
+  "tpsL1 t \<equiv> tps0
+    [j1 := (\<lfloor>zs\<rfloor>, Suc t),
+     j2 := (\<lfloor>binencode (take (Suc t) zs)\<rfloor>, Suc (2 * t) + 2)]"
+
+lemma read_tpsL:
+  assumes "t < length zs"
+  shows "read (tpsL t) ! j1 = zs ! t"
+proof -
+  have "tpsL t ! j1 = (\<lfloor>zs\<rfloor>, Suc t)"
+    using tpsL_def jk by simp
+  moreover have "j1 < length (tpsL t)"
+    using tpsL_def jk by simp
+  ultimately show "read (tpsL t) ! j1 = zs ! t"
+    using assms tapes_at_read'
+    by (metis Suc_leI contents_inbounds diff_Suc_1 fst_conv snd_conv zero_less_Suc)
+qed
+
+lemma tm1 [transforms_intros]:
+  assumes "t < length zs" and "zs ! t = \<bar> \<or> zs ! t = \<sharp>"
+  shows "transforms tm1 (tpsL t) 4 (tpsL1 t)"
+  unfolding tm1_def
+proof (tform tps: jk tpsL_def)
+  have 1: "tpsL t ! j2 = (\<lfloor>binencode (take t zs)\<rfloor>, Suc (2 * t))"
+    using tpsL_def jk by simp
+  have 2: "length (binencode (take t zs)) = 2 * t"
+    using assms(1) by simp
+  have "inscribe (tpsL t ! j2) [\<one>, \<zero>] = (\<lfloor>binencode (take t zs) @ [\<one>, \<zero>]\<rfloor>, Suc (2 * t) + 2)"
+    using inscribe_contents 1 2
+    by (metis (no_types, lifting) One_nat_def Suc_1 Suc_eq_plus1 add_Suc_shift list.size(3) list.size(4))
+  moreover have "binencode (take t zs) @ [\<one>, \<zero>] = binencode (take (Suc t) zs)" if "zs ! t = \<bar>"
+    using that assms(1) binencode_snoc by (metis take_Suc_conv_app_nth)
+  ultimately have 5: "inscribe (tpsL t ! j2) [\<one>, \<zero>] = (\<lfloor>binencode (take (Suc t) zs)\<rfloor>, Suc (2 * t) + 2)"
+      if "zs ! t = \<bar>"
+    using that by simp
+  have "inscribe (tpsL t ! j2) [\<one>, \<one>] = (\<lfloor>binencode (take t zs) @ [\<one>, \<one>]\<rfloor>, Suc (2 * t) + 2)"
+    using inscribe_contents 1 2
+    by (metis (no_types, lifting) One_nat_def Suc_1 Suc_eq_plus1 add_Suc_shift list.size(3) list.size(4))
+  moreover have "binencode (take t zs) @ [\<one>, \<one>] = binencode (take (Suc t) zs)" if "zs ! t = 5"
+    using that assms(1) binencode_snoc by (metis take_Suc_conv_app_nth)
+  ultimately have 6: "inscribe (tpsL t ! j2) [\<one>, \<one>] = (\<lfloor>binencode (take (Suc t) zs)\<rfloor>, Suc (2 * t) + 2)"
+      if "zs ! t = \<sharp>"
+    using that by simp
+  have 7: "tpsL1 t = (tpsL t)[j2 := (\<lfloor>binencode (take (Suc t) zs)\<rfloor>, Suc (2 * t) + 2)]"
+    unfolding tpsL1_def tpsL_def by (simp only: list_update_overwrite)
+  then have 8: "tpsL1 t = (tpsL t)[j2 := inscribe (tpsL t ! j2) [\<one>, \<zero>]]" if "zs ! t = \<bar>"
+      using that 5 by simp
+  have 9: "tpsL1 t = (tpsL t)[j2 := inscribe (tpsL t ! j2) [\<one>, \<one>]]" if "zs ! t = \<sharp>"
+      using that 6 7 by simp
+  show "read (tpsL t) ! j1 = \<bar> \<Longrightarrow>
+      tpsL1 t = (tpsL t)[j2 := inscribe (tpsL t ! j2) [\<one>, \<zero>]]"
+    using read_tpsL[OF assms(1)] 8 by simp
+  show "read (tpsL t) ! j1 \<noteq> \<bar> \<Longrightarrow>
+      tpsL1 t = (tpsL t)[j2 := inscribe (tpsL t ! j2) [\<one>, \<one>]]"
+    using read_tpsL[OF assms(1)] 9 assms(2) by simp
+qed
+
+lemma tm2 [transforms_intros]:
+  assumes "t < length zs" and "zs ! t = \<bar> \<or> zs ! t = \<sharp> \<or> zs ! t = \<one>"
+  shows "transforms tm2 (tpsL t) 5 (tpsL1 t)"
+  unfolding tm2_def
+proof (tform tps: tpsL_def jk assms(1))
+  have 1: "tpsL t ! j2 = (\<lfloor>binencode (take t zs)\<rfloor>, Suc (2 * t))"
+    using tpsL_def jk by simp
+  have 2: "length (binencode (take t zs)) = 2 * t"
+    using assms(1) by simp
+  show "read (tpsL t) ! j1 \<noteq> \<one> \<Longrightarrow> zs ! t = \<bar> \<or> zs ! t = \<sharp>"
+    using read_tpsL[OF assms(1)] assms(2) by simp
+  show "tpsL1 t = (tpsL t)[j2 := inscribe (tpsL t ! j2) [\<zero>, \<one>]]" if "read (tpsL t) ! j1 = \<one>"
+  proof -
+    have *: "zs ! t = \<one>"
+      using read_tpsL[OF assms(1)] that by simp
+    have "inscribe (tpsL t ! j2) [\<zero>, \<one>] = (\<lfloor>binencode (take t zs) @ [2, \<one>]\<rfloor>, Suc (2 * t) + 2)"
+      using inscribe_contents 1 2
+      by (metis (no_types, lifting) One_nat_def Suc_1 Suc_eq_plus1 add_Suc_shift list.size(3) list.size(4))
+    moreover have "binencode (take t zs) @ [\<zero>, \<one>] = binencode (take (Suc t) zs)"
+      using * assms(1) binencode_snoc by (metis take_Suc_conv_app_nth)
+    ultimately have "inscribe (tpsL t ! j2) [\<zero>, \<one>] = (\<lfloor>binencode (take (Suc t) zs)\<rfloor>, Suc (2 * t) + 2)"
+      by simp
+    moreover have "tpsL1 t = (tpsL t)[j2 := (\<lfloor>binencode (take (Suc t) zs)\<rfloor>, Suc (2 * t) + 2)]"
+      unfolding tpsL1_def tpsL_def by (simp only: list_update_overwrite)
+    ultimately show "tpsL1 t = (tpsL t)[j2 := inscribe (tpsL t ! j2) [\<zero>, \<one>]]"
+      using that by simp
+  qed
+qed
+
+lemma tm3 [transforms_intros]:
+  assumes "t < length zs"
+  shows "transforms tm3 (tpsL t) 6 (tpsL1 t)"
+  unfolding tm3_def
+proof (tform tps: jk assms tpsL_def)
+  have 1: "tpsL t ! j2 = (\<lfloor>binencode (take t zs)\<rfloor>, Suc (2 * t))"
+    using tpsL_def jk by simp
+  have 2: "length (binencode (take t zs)) = 2 * t"
+    using assms by simp
+  show "read (tpsL t) ! j1 \<noteq> \<zero> \<Longrightarrow> zs ! t = \<bar> \<or> zs ! t = \<sharp> \<or> zs ! t = \<one>"
+    using assms zs read_tpsL by auto
+  show "tpsL1 t = (tpsL t)[j2 := inscribe (tpsL t ! j2) [\<zero>, \<zero>]]" if "read (tpsL t) ! j1 = \<zero>"
+  proof -
+    have *: "zs ! t = \<zero>"
+      using read_tpsL[OF assms] that by simp
+    have "inscribe (tpsL t ! j2) [\<zero>, \<zero>] = (\<lfloor>binencode (take t zs) @ [\<zero>, \<zero>]\<rfloor>, Suc (2 * t) + 2)"
+      using inscribe_contents 1 2
+      by (metis (no_types, lifting) One_nat_def Suc_1 Suc_eq_plus1 add_Suc_shift list.size(3) list.size(4))
+    moreover have "binencode (take t zs) @ [\<zero>, \<zero>] = binencode (take (Suc t) zs)"
+      using * assms binencode_snoc by (metis take_Suc_conv_app_nth)
+    ultimately have "inscribe (tpsL t ! j2) [\<zero>, \<zero>] = (\<lfloor>binencode (take (Suc t) zs)\<rfloor>, Suc (2 * t) + 2)"
+      by simp
+    moreover have "tpsL1 t = (tpsL t)[j2 := (\<lfloor>binencode (take (Suc t) zs)\<rfloor>, Suc (2 * t) + 2)]"
+      unfolding tpsL1_def tpsL_def by (simp only: list_update_overwrite)
+    ultimately show "tpsL1 t = (tpsL t)[j2 := inscribe (tpsL t ! j2) [\<zero>, \<zero>]]"
+      using that by simp
+  qed
+qed
+
+lemma tm4 [transforms_intros]:
+  assumes "t < length zs"
+  shows "transforms tm4 (tpsL t) 7 (tpsL (Suc t))"
+  unfolding tm4_def
+proof (tform tps: assms tpsL1_def jk)
+  have *: "tpsL1 t ! j1 = (\<lfloor>zs\<rfloor>, Suc t)"
+    using tpsL1_def jk by simp
+  show "tpsL (Suc t) = (tpsL1 t)[j1 := tpsL1 t ! j1 |+| 1]"
+    using tpsL_def tpsL1_def using jk * by (auto simp add: list_update_swap[of _ j1])
+qed
+
+lemma tm5:
+  assumes "ttt = 9 * length zs + 1"
+  shows "transforms tm5 (tpsL 0) ttt (tpsL (length zs))"
+  unfolding tm5_def
+proof (tform)
+  show "\<And>t. t < length zs \<Longrightarrow> read (tpsL t) ! j1 \<noteq> \<box>"
+    using read_tpsL zs by auto
+  show "\<not> read (tpsL (length zs)) ! j1 \<noteq> \<box>"
+  proof -
+    have "tpsL (length zs) ! j1 = (\<lfloor>zs\<rfloor>, Suc (length zs))"
+      using tpsL_def jk by simp
+    moreover have "j1 < length (tpsL (length zs))"
+      using tpsL_def jk by simp
+    ultimately have "read (tpsL (length zs)) ! j1 = tape_read (\<lfloor>zs\<rfloor>, Suc (length zs))"
+      using tapes_at_read' by fastforce
+    also have "... = \<box>"
+      using contents_outofbounds by simp
+    finally show ?thesis
+      by simp
+  qed
+  show "length zs * (7 + 2) + 1 \<le> ttt"
+    using assms by simp
+qed
+
+lemma tpsL: "tpsL (length zs) = tps0
+  [j1 := (\<lfloor>zs\<rfloor>, Suc (length zs)),
+   j2 := (\<lfloor>binencode zs\<rfloor>, Suc (2 * (length zs)))]"
+  unfolding tpsL_def using tps0 jk by simp
+
+lemma tm5':
+  assumes "ttt = 9 * length zs + 1"
+  shows "transforms tm5 tps0 ttt (tpsL (length zs))"
+  using assms tm5 tpsL_0 by simp
+
+end
+
+end  (* locale turing_machine_binencode *)
+
+lemma transforms_tm_binencodeI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and ttt k :: nat and zs :: "symbol list"
+  assumes "k = length tps" "j1 \<noteq> j2" "0 < j2" "j1 < k" "j2 < k"
+    and "binencodable zs"
+  assumes
+    "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 9 * length zs + 1"
+  assumes "tps' \<equiv> tps
+    [j1 := (\<lfloor>zs\<rfloor>, Suc (length zs)),
+     j2 := (\<lfloor>binencode zs\<rfloor>, Suc (2 * (length zs)))]"
+  shows "transforms (tm_binencode j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_binencode j1 j2 .
+  show ?thesis
+    using assms loc.tm5' loc.tm5_eq_tm_binencode loc.tpsL by simp
+qed
+
+text \<open>
+The next command reads chunks of two symbols over @{text "\<zero>\<one>"} from one tape
+and writes to another tape the corresponding symbol over @{text "\<zero>\<one>\<bar>\<sharp>"}.  The
+first symbol of each chunk is memorized on the last tape.  If the end of the
+input (that is, a blank symbol) is encountered, the command stops without
+writing another symbol.
+\<close>
+
+definition cmd_bindec :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> command" where
+  "cmd_bindec j1 j2 rs \<equiv>
+    if rs ! j1 = 0 then (1, map (\<lambda>z. (z, Stay)) rs)
+    else (0,
+     map (\<lambda>i.
+       if last rs = \<triangleright>
+       then if i = j1 then (rs ! i, Right)
+            else if i = j2 then (rs ! i, Stay)
+            else if i = length rs - 1 then (tosym (todigit (rs ! j1)), Stay)
+            else (rs ! i, Stay)
+       else if i = j1 then (rs ! i, Right)
+            else if i = j2 then (decsym (last rs) (rs ! j1), Right)
+            else if i = length rs - 1 then (1, Stay)
+            else (rs ! i, Stay))
+     [0..<length rs])"
+
+text \<open>
+The Turing machine performing the decoding:
+\<close>
+
+definition tm_bindec :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_bindec j1 j2 = [cmd_bindec j1 j2]"
+
+context
+  fixes j1 j2 :: tapeidx and k :: nat
+  assumes j_less: "j1 < k" "j2 < k"
+    and j_gt: "0 < j2"
+begin
+
+lemma turing_command_bindec:
+  assumes "G \<ge> 6"
+  shows "turing_command (Suc k) 1 G (cmd_bindec j1 j2)"
+proof
+  show "\<And>gs. length gs = Suc k \<Longrightarrow> length ([!!] cmd_bindec j1 j2 gs) = length gs"
+    using cmd_bindec_def by simp
+  show "cmd_bindec j1 j2 gs [.] j < G"
+      if "length gs = Suc k" "\<And>i. i < length gs \<Longrightarrow> gs ! i < G" "j < length gs"
+      for gs j
+  proof (cases "gs ! j1 = \<box>")
+    case True
+    then show ?thesis
+      using that cmd_bindec_def by simp
+  next
+    case else: False
+    show ?thesis
+    proof (cases "last gs = \<triangleright>")
+      case True
+      then have "snd (cmd_bindec j1 j2 gs) = map (\<lambda>i.
+              if i = j1 then (gs ! i, Right)
+              else if i = j2 then (gs ! i, Stay)
+              else if i = length gs - 1 then (todigit (gs ! j1) + 2, Stay)
+              else (gs ! i, Stay)) [0..<length gs]"
+        using cmd_bindec_def else by simp
+      then have "cmd_bindec j1 j2 gs [!] j =
+            (if j = j1 then (gs ! j, Right)
+              else if j = j2 then (gs ! j, Stay)
+              else if j = length gs - 1 then (todigit (gs ! j1) + 2, Stay)
+              else (gs ! j, Stay))"
+        using that(3) by simp
+      then have "cmd_bindec j1 j2 gs [.] j =
+            (if j = j1 then gs ! j
+              else if j = j2 then gs ! j
+              else if j = length gs - 1 then todigit (gs ! j1) + 2
+              else gs ! j)"
+        by simp
+      then show ?thesis
+        using that assms by simp
+    next
+      case False
+      then have "snd (cmd_bindec j1 j2 gs) = map (\<lambda>i.
+            if i = j1 then (gs ! i, Right)
+            else if i = j2 then (2 * todigit (last gs) + todigit (gs ! j1) + 2, Right)
+            else if i = length gs - 1 then (1, Stay)
+            else (gs ! i, Stay)) [0..<length gs]"
+        using cmd_bindec_def else by simp
+      then have "cmd_bindec j1 j2 gs [!] j =
+          (if j = j1 then (gs ! j, Right)
+            else if j = j2 then (2 * todigit (last gs) + todigit (gs ! j1) + 2, Right)
+            else if j = length gs - 1 then (1, Stay)
+            else (gs ! j, Stay))"
+        using that(3) by simp
+      then have "cmd_bindec j1 j2 gs [.] j =
+          (if j = j1 then gs ! j
+            else if j = j2 then 2 * todigit (last gs) + todigit (gs ! j1) + 2
+            else if j = length gs - 1 then 1
+            else gs ! j)"
+        by simp
+      moreover have "last gs < G"
+        using that assms
+        by (metis add_lessD1 diff_less last_conv_nth length_greater_0_conv less_numeral_extra(1)
+          less_numeral_extra(4) list.size(3) plus_1_eq_Suc)
+      ultimately show ?thesis
+        using that assms by simp
+    qed
+  qed
+  show "cmd_bindec j1 j2 gs [.] 0 = gs ! 0" if "length gs = Suc k" "0 < Suc k" for gs
+  proof (cases "last gs = 1")
+    case True
+    moreover have "0 < length gs" "0 \<noteq> length gs - 1"
+      using that j_less by simp_all
+    ultimately show ?thesis
+      using cmd_bindec_def by simp
+  next
+    case False
+    moreover have "0 < length gs" "0 \<noteq> j2" "0 \<noteq> length gs - 1"
+      using that j_gt j_less by simp_all
+    ultimately show ?thesis
+      using cmd_bindec_def by simp
+  qed
+  show "\<And>gs. length gs = Suc k \<Longrightarrow> [*] (cmd_bindec j1 j2 gs) \<le> 1"
+    using cmd_bindec_def by simp
+qed
+
+lemma tm_bindec_tm: "G \<ge> 6 \<Longrightarrow> turing_machine (Suc k) G (tm_bindec j1 j2)"
+  unfolding tm_bindec_def using j_less(2) j_gt turing_command_bindec cmd_bindec_def by auto
+
+context
+  fixes tps :: "tape list" and zs :: "symbol list"
+  assumes j1_neq: "j1 \<noteq> j2"
+    and lentps: "Suc k = length tps"
+    and bs: "bit_symbols zs"
+begin
+
+lemma sem_cmd_bindec_gt:
+  assumes "tps ! j1 = (\<lfloor>zs\<rfloor>, i)"
+    and "i > length zs"
+  shows "sem (cmd_bindec j1 j2) (0, tps) = (1, tps)"
+proof (rule semI)
+  show "proper_command (Suc k) (cmd_bindec j1 j2)"
+    using cmd_bindec_def by simp
+  show "length tps = Suc k"
+    using lentps by simp
+  show "length tps = Suc k"
+    using lentps by simp
+  have "read tps ! j1 = \<box>"
+    using assms by (metis contents_outofbounds fst_conv j_less(1) lentps less_Suc_eq snd_conv tapes_at_read')
+  moreover from this show "fst (cmd_bindec j1 j2 (read tps)) = 1"
+    by (simp add: cmd_bindec_def)
+  ultimately show "\<And>j. j < Suc k \<Longrightarrow> act (cmd_bindec j1 j2 (read tps) [!] j) (tps ! j) = tps ! j"
+    using assms cmd_bindec_def act_Stay lentps read_length by simp
+qed
+
+lemma sem_cmd_bindec_1:
+  assumes "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps ! j1 = (\<lfloor>zs\<rfloor>, i)"
+    and "i > 0"
+    and "i \<le> length zs"
+    and "tps' = tps [j1 := tps ! j1 |+| 1, k := \<lceil>todigit (tps :.: j1) + 2\<rceil>]"
+  shows "sem (cmd_bindec j1 j2) (0, tps) = (0, tps')"
+proof (rule semI)
+  show "proper_command (Suc k) (cmd_bindec j1 j2)"
+    using cmd_bindec_def by simp
+  show "length tps = Suc k"
+    using lentps by simp
+  show "length tps' = Suc k"
+    using lentps assms(5) by simp
+  have read: "read tps ! j1 \<noteq> \<box>"
+    using assms(2,3,4) bs j_less(1) tapes_at_read'[of j1 tps] contents_inbounds[OF assms(3,4)] lentps
+       proper_symbols_ne0[OF proper_bit_symbols[OF bs]]
+    by (metis One_nat_def Suc_less_eq Suc_pred fst_conv le_imp_less_Suc less_SucI snd_eqD)
+  then show "fst (cmd_bindec j1 j2 (read tps)) = 0"
+    using cmd_bindec_def by simp
+  show "act (cmd_bindec j1 j2 (read tps) [!] j) (tps ! j) = tps' ! j"
+    if "j < Suc k" for j
+  proof -
+    let ?rs = "read tps"
+    have "last ?rs = 1"
+      using assms(1) lentps onesie_read read_length tapes_at_read'
+      by (metis (mono_tags, lifting) last_length lessI)
+    then have *: "snd (cmd_bindec j1 j2 ?rs) = map (\<lambda>i.
+        if i = j1 then (?rs ! i, Right)
+        else if i = j2 then (?rs ! i, Stay)
+        else if i = length ?rs - 1 then (if ?rs ! j1 = \<one> then \<one> else \<zero>, Stay)
+        else (?rs ! i, Stay)) [0..<length ?rs]"
+      using read cmd_bindec_def by simp
+    have "length ?rs = Suc k"
+      by (simp add: lentps read_length)
+    then have len: "j < length ?rs"
+      using that by simp
+    have k: "k = length ?rs - 1"
+      by (simp add: \<open>length ?rs = Suc k\<close>)
+    consider "j = j1" | "j \<noteq> j1 \<and> j = j2" | "j \<noteq> j1 \<and> j \<noteq> j2 \<and> j = k" | "j \<noteq> j1 \<and> j \<noteq> j2 \<and> j \<noteq> k"
+      by auto
+    then show ?thesis
+    proof (cases)
+      case 1
+      then have "cmd_bindec j1 j2 ?rs [!] j = (?rs ! j1, Right)"
+        using * len by simp
+      then show ?thesis
+        using act_Right 1 assms(5) j_less(1) lentps by simp
+    next
+      case 2
+      then have "cmd_bindec j1 j2 ?rs [!] j = (?rs ! j2, Stay)"
+        using * len by simp
+      then show ?thesis
+        using 2 act_Stay assms(5) j_less(2) lentps by simp
+    next
+      case 3
+      then have "cmd_bindec j1 j2 ?rs [!] j = (todigit (?rs ! j1) + 2, Stay)"
+        using k * len by simp
+      then show ?thesis
+        using 3 assms(1,5) act_onesie j_less(1) lentps tapes_at_read'
+        by (metis length_list_update less_Suc_eq nth_list_update)
+    next
+      case 4
+      then have "cmd_bindec j1 j2 ?rs [!] j = (?rs ! j, Stay)"
+        using k * len that by simp
+      then show ?thesis
+        using 4 act_Stay assms(5) lentps that by simp
+    qed
+  qed
+qed
+
+lemma sem_cmd_bindec_23:
+  assumes "tps ! k = \<lceil>s\<rceil>"
+    and "s = \<zero> \<or> s = \<one>"
+    and "tps ! j1 = (\<lfloor>zs\<rfloor>, i)"
+    and "i > 0"
+    and "i \<le> length zs"
+    and "tps' = tps
+      [j1 := tps ! j1 |+| 1,
+       j2 := tps ! j2 |:=| decsym s (tps :.: j1) |+| 1,
+       k := \<lceil>\<triangleright>\<rceil>]"
+  shows "sem (cmd_bindec j1 j2) (0, tps) = (0, tps')"
+proof (rule semI)
+  show "proper_command (Suc k) (cmd_bindec j1 j2)"
+    using cmd_bindec_def by simp
+  show "length tps = Suc k"
+    using lentps by simp
+  show "length tps' = Suc k"
+    using lentps assms(6) by simp
+  have read: "read tps ! j1 \<noteq> \<box>"
+    using assms(3-5) bs tapes_at_read'[of j1 tps] contents_inbounds[OF assms(4,5)] lentps
+    by (metis One_nat_def Suc_less_eq Suc_pred fst_conv j_less(1) le_imp_less_Suc
+      less_imp_le_nat not_one_less_zero proper_bit_symbols snd_conv)
+  show "fst (cmd_bindec j1 j2 (read tps)) = 0"
+    using read cmd_bindec_def by simp
+  show "act (cmd_bindec j1 j2 (read tps) [!] j) (tps ! j) = tps' ! j"
+    if "j < Suc k" for j
+  proof -
+    let ?rs = "read tps"
+    have "last ?rs \<noteq> 1"
+      using assms(1,2) lentps onesie_read read_length tapes_at_read'
+      by (metis Suc_1 diff_Suc_1 last_conv_nth lessI list.size(3) n_not_Suc_n numeral_One
+        numeral_eq_iff old.nat.distinct(1) semiring_norm(86))
+    then have *: "snd (cmd_bindec j1 j2 ?rs) = map (\<lambda>i.
+        if i = j1 then (?rs ! i, Right)
+        else if i = j2 then (2 * todigit (last ?rs) + todigit (?rs ! j1) + 2, Right)
+        else if i = length ?rs - 1 then (1, Stay)
+        else (?rs ! i, Stay)) [0..<length ?rs]"
+      using read cmd_bindec_def by simp
+    have lenrs: "length ?rs = Suc k"
+      by (simp add: lentps read_length)
+    then have len: "j < length ?rs"
+      using that by simp
+    have k: "k = length ?rs - 1"
+      by (simp add: lenrs)
+    consider "j = j1" | "j \<noteq> j1 \<and> j = j2" | "j \<noteq> j1 \<and> j \<noteq> j2 \<and> j = k" | "j \<noteq> j1 \<and> j \<noteq> j2 \<and> j \<noteq> k"
+      by auto
+    then show ?thesis
+    proof (cases)
+      case 1
+      then show ?thesis
+        using * len act_Right assms(6) j_less(1) j1_neq lentps by simp
+    next
+      case 2
+      then have "cmd_bindec j1 j2 ?rs [!] j = (2 * todigit (last ?rs) + todigit (?rs ! j1) + 2, Right)"
+        using * len by simp
+      moreover have "last ?rs = s"
+        using assms(1,2) lenrs k onesie_read tapes_at_read'
+        by (metis last_conv_nth length_0_conv lentps lessI old.nat.distinct(1))
+      moreover have "?rs ! j1 = tps :.: j1"
+        using j_less(1) lentps tapes_at_read' by simp
+      ultimately show ?thesis
+        using 2 assms(6) act_Right' j_less lentps by simp
+    next
+      case 3
+      then show ?thesis
+        using * len k act_onesie assms(1,6) lentps by simp
+    next
+      case 4
+      then have "cmd_bindec j1 j2 ?rs [!] j = (?rs ! j, Stay)"
+        using k * len by simp
+      then show ?thesis
+        using 4 act_Stay assms(6) lentps that by simp
+    qed
+  qed
+qed
+
+end  (* tps zs *)
+
+lemma transits_tm_bindec:
+  fixes tps :: "tape list" and zs :: "symbol list"
+  assumes j1_neq: "j1 \<noteq> j2"
+    and j1j2: "0 < j2" "j1 < k" "j2 < k"
+    and lentps: "Suc k = length tps"
+    and bs: "bit_symbols zs"
+  assumes "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps ! j1 = (\<lfloor>zs\<rfloor>, 2 * i + 1)"
+    and "tps ! j2 = (\<lfloor>bindecode (take (2 * i) zs)\<rfloor>, Suc i)"
+    and "i < length zs div 2"
+    and "tps' = tps
+      [j1 := (\<lfloor>zs\<rfloor>, 2 * (Suc i) + 1),
+       j2 := (\<lfloor>bindecode (take (2 * Suc i) zs)\<rfloor>, Suc (Suc i))]"
+  shows "transits (tm_bindec j1 j2) (0, tps) 2 (0, tps')"
+proof -
+  define tps1 where "tps1 = tps
+      [j1 := (\<lfloor>zs\<rfloor>, 2 * i + 2),
+       k := \<lceil>todigit (tps :.: j1) + 2\<rceil>]"
+  let ?i = "2 * i + 1"
+  let ?M = "tm_bindec j1 j2"
+  have ilen: "?i < length zs"
+    using assms(10) by simp
+  have "exe ?M (0, tps) = sem (cmd_bindec j1 j2) (0, tps)"
+    using tm_bindec_def exe_lt_length by simp
+  also have "... =
+      (if ?i \<le> length zs then 0 else 1,
+       tps[j1 := tps ! j1 |+| 1, k := \<lceil>todigit (tps :.: j1) + 2\<rceil>])"
+      using ilen bs assms(7,8) sem_cmd_bindec_1 j1_neq lentps by simp
+  also have "... = (0, tps[j1 := tps ! j1 |+| 1, k := \<lceil>todigit (tps :.: j1) + 2\<rceil>])"
+    using ilen by simp
+  also have "... = (0, tps1)"
+    using tps1_def assms by simp
+  finally have step1: "exe ?M (0, tps) = (0, tps1)" .
+
+  let ?s = "tps1 :.: k"
+  have "tps :.: j1 = zs ! (2 * i)"
+    using assms(8) ilen by simp
+  then have "?s = todigit (zs ! (2 * i)) + 2"
+    using tps1_def lentps by simp
+  then have "?s = zs ! (2 * i)"
+    using ilen bs by (smt (z3) One_nat_def Suc_1 add_2_eq_Suc' add_lessD1 numeral_3_eq_3)
+  moreover have "tps1 :.: j1 = zs ! ?i"
+    using tps1_def ilen lentps j1j2 by simp
+  ultimately have *: "decsym ?s (tps1 :.: j1) = decsym (zs ! (2*i)) (zs ! (Suc (2*i)))"
+    by simp
+
+  have "exe ?M (0, tps1) = sem (cmd_bindec j1 j2) (0, tps1)"
+    using tm_bindec_def exe_lt_length by simp
+  also have "... =
+    (if Suc ?i \<le> length zs then 0 else 1,
+     tps1[j1 := tps1 ! j1 |+| 1, j2 := tps1 ! j2 |:=| 2 * todigit ?s + todigit (tps1 :.: j1) + 2 |+| 1, k := \<lceil>\<triangleright>\<rceil>])"
+  proof -
+    have 1: "tps1 ! k = \<lceil>?s\<rceil>"
+      using tps1_def lentps by simp
+    have 2: "?s = 2 \<or> ?s = 3"
+      using tps1_def lentps by simp
+    have 3: "tps1 ! j1 = (\<lfloor>zs\<rfloor>, Suc ?i)"
+      using tps1_def lentps Suc_1 add_Suc_right j_less(1) less_Suc_eq nat_neq_iff nth_list_update_eq nth_list_update_neq
+      by simp
+    have 4: "Suc ?i > 0"
+      by simp
+    have 5: "Suc k = length tps1"
+      by (simp add: lentps tps1_def)
+    show ?thesis
+      using ilen sem_cmd_bindec_23[of tps1 zs ?s "Suc ?i", OF j1_neq 5 bs 1 2 3 4] by simp
+  qed
+  also have "... =
+    (0, tps1[j1 := tps1 ! j1 |+| 1, j2 := tps1 ! j2 |:=| decsym ?s (tps1 :.: j1) |+| 1, k := \<lceil>\<triangleright>\<rceil>])"
+    using assms(10) length_binencode by simp
+  also have "... =
+    (0, tps1[j1 := tps1 ! j1 |+| 1, j2 := tps1 ! j2 |:=| decsym (zs ! (2*i)) (zs ! (Suc (2*i))) |+| 1, k := \<lceil>\<triangleright>\<rceil>])"
+      (is "_ = (0, ?tps)")
+    using * by simp
+  also have "... = (0, tps')"
+  proof -
+    have len': "length tps' = Suc k"
+      using assms lentps by simp
+    have len1: "length tps1 = Suc k"
+      using assms lentps tps1_def by simp
+    have 1: "?tps ! k = tps' ! k"
+      using assms(7,11) by (simp add: j_less(1) j_less(2) len1 nat_neq_iff)
+    have 2: "?tps ! j1 = tps' ! j1"
+      using assms(11) j1_neq j_less(1) lentps tps1_def by simp
+    have "?tps ! j2 = tps1 ! j2 |:=| decsym (zs ! (2*i)) (zs ! (Suc (2*i))) |+| 1"
+      by (simp add: j_less(2) len1 less_Suc_eq nat_neq_iff)
+    also have "... = tps ! j2 |:=| decsym (zs ! (2*i)) (zs ! (Suc (2*i))) |+| 1"
+      using tps1_def j1_neq j_less(2) len1 by force
+    also have "... = (\<lfloor>bindecode (take (2 * i) zs)\<rfloor>, Suc i) |:=| decsym (zs ! (2*i)) (zs ! (Suc (2*i))) |+| 1"
+      using assms(9) j1_neq j_less(2) len1 tps1_def by simp
+    also have "... = (\<lfloor>bindecode (take (2 * i) zs)\<rfloor>(Suc i := decsym (zs ! (2*i)) (zs ! (Suc (2*i)))), Suc (Suc i))"
+      by simp
+    also have "... = (\<lfloor>bindecode (take (2 * i) zs) @ [decsym (zs ! (2*i)) (zs ! (Suc (2*i)))]\<rfloor>, Suc (Suc i))"
+      using contents_snoc[of "bindecode (take (2 * i) zs)"] ilen length_bindecode
+    proof -
+      have "length (bindecode (take (2 * i) zs)) = i"
+        using ilen length_bindecode by simp
+      then show ?thesis
+        using contents_snoc[of "bindecode (take (2 * i) zs)"] by simp
+    qed
+    also have "... = (\<lfloor>bindecode (take (2 * Suc i) zs)\<rfloor>, Suc (Suc i))"
+      using bindecode_take_snoc ilen by simp
+    also have "... = tps' ! j2"
+      by (metis assms(11) j_less(2) length_list_update lentps less_Suc_eq nth_list_update_eq)
+    finally have "?tps ! j2 = tps' ! j2" .
+    then show ?thesis
+      using 1 2 assms(11) tps1_def by (smt (z3) list_update_id list_update_overwrite list_update_swap)
+  qed
+  finally have "exe ?M (0, tps1) = (0, tps')" .
+  then have "execute ?M (0, tps) 2 = (0, tps')"
+    using step1 by (simp add: numeral_2_eq_2)
+  then show "transits (tm_bindec j1 j2) (0, tps) 2 (0, tps')"
+    using execute_imp_transits by blast
+qed
+
+context
+  fixes tps :: "tape list" and zs :: "symbol list"
+  assumes j1_neq: "j1 \<noteq> j2"
+    and j1j2: "0 < j2" "j1 < k" "j2 < k"
+    and lentps: "Suc k = length tps"
+    and bs: "bit_symbols zs"
+begin
+
+lemma transits_tm_bindec':
+  assumes "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+    and "i \<le> length zs div 2"
+    and "tps' = tps
+      [j1 := (\<lfloor>zs\<rfloor>, 2 * i + 1),
+       j2 := (\<lfloor>bindecode (take (2 * i) zs)\<rfloor>, Suc i)]"
+  shows "transits (tm_bindec j1 j2) (0, tps) (2 * i) (0, tps')"
+  using assms(4,5)
+proof (induction i arbitrary: tps')
+  case 0
+  then show ?case
+    using assms(2,3) by (metis One_nat_def add.commute div_mult_self1_is_m execute.simps(1)
+      le_numeral_extra(3) length_bindecode length_greater_0_conv list.size(3) list_update_id
+       mult_0_right plus_1_eq_Suc take0 transits_def zero_less_numeral)
+next
+  case (Suc i)
+  define tpsi where "tpsi = tps
+      [j1 := (\<lfloor>zs\<rfloor>, 2 * i + 1),
+       j2 := (\<lfloor>bindecode (take (2*i) zs)\<rfloor>, Suc i)]"
+  then have "transits (tm_bindec j1 j2) (0, tps) (2 * i) (0, tpsi)"
+    using Suc by simp
+  moreover have "transits (tm_bindec j1 j2) (0, tpsi) 2 (0, tps')"
+  proof -
+    have 1: "tpsi ! k = \<lceil>\<triangleright>\<rceil>"
+      using tpsi_def by (simp add: assms(1) j_less(1) j_less(2) less_not_refl3)
+    have 2: "tpsi ! j1 = (\<lfloor>zs\<rfloor>, 2 * i + 1)"
+      using tpsi_def by (metis j1_neq j_less(1) lentps less_Suc_eq nth_list_update_eq nth_list_update_neq)
+    have 3: "tpsi ! j2 = (\<lfloor>bindecode (take (2 * i) zs)\<rfloor>, Suc i)"
+      using tpsi_def by (metis j_less(2) length_list_update lentps less_Suc_eq nth_list_update_eq)
+    have 4: "i < length zs div 2"
+      using Suc by simp
+    have 5: "tps' = tpsi
+      [j1 := (\<lfloor>zs\<rfloor>, 2 * (Suc i) + 1),
+       j2 := (\<lfloor>bindecode (take (2 * Suc i) zs)\<rfloor>, Suc (Suc i))]"
+      using Suc tpsi_def by (metis (no_types, opaque_lifting) list_update_overwrite list_update_swap)
+    have 6: "Suc k = length tpsi"
+      using tpsi_def lentps by simp
+    show ?thesis
+      using transits_tm_bindec[OF j1_neq j1j2 6 bs 1 2 3 4 5] .
+  qed
+  ultimately show "transits (tm_bindec j1 j2) (0, tps) (2 * (Suc i)) (0, tps')"
+    using transits_additive by fastforce
+qed
+
+corollary transits_tm_bindec'':
+  assumes "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+    and "l = length zs div 2"
+    and "tps' = tps
+      [j1 := (\<lfloor>zs\<rfloor>, 2 * l + 1),
+       j2 := (\<lfloor>bindecode (take (2 * l) zs)\<rfloor>, Suc l)]"
+  shows "transits (tm_bindec j1 j2) (0, tps) (2 * l) (0, tps')"
+  using assms transits_tm_bindec' by simp
+
+text \<open>In case the input is of odd length, that is, malformed:\<close>
+
+lemma transforms_tm_bindec_odd:
+  assumes "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+    and "tps' = tps
+      [j1 := (\<lfloor>zs\<rfloor>, 2 * l + 2),
+       j2 := (\<lfloor>bindecode zs\<rfloor>, Suc l),
+       k := \<lceil>todigit (last zs) + 2\<rceil>]"
+    and "l = length zs div 2"
+    and "Suc (2 * l) = length zs"
+  shows "transforms (tm_bindec j1 j2) tps (2 * l + 2) tps'"
+proof -
+  let ?ys = "bindecode (take (2 * l) zs)"
+  let ?i = "2 * l + 1"
+  let ?M = "tm_bindec j1 j2"
+  have ys: "?ys = bindecode zs"
+    using bindecode_odd assms(6) by (metis Suc_eq_plus1)
+  have "zs \<noteq> []"
+    using assms(6) by auto
+  define tps1 where "tps1 = tps
+      [j1 := (\<lfloor>zs\<rfloor>, 2 * l + 1),
+       j2 := (\<lfloor>?ys\<rfloor>, Suc l)]"
+  define tps2 where "tps2 = tps
+    [j1 := (\<lfloor>zs\<rfloor>, 2 * l + 2),
+     j2 := (\<lfloor>bindecode zs\<rfloor>, Suc l),
+     k := \<lceil>todigit (tps1 :.: j1) + 2\<rceil>]"
+  have "transits ?M (0, tps) (2 * l) (0, tps1)"
+    using tps1_def assms transits_tm_bindec'' by simp
+  moreover have "execute ?M (0, tps1) 1 = (0, tps2)"
+  proof -
+    have "execute ?M (0, tps1) 1 = exe ?M (0, tps1)"
+      by simp
+    also have "... = sem (cmd_bindec j1 j2) (0, tps1)"
+      using exe_lt_length tm_bindec_def by simp
+    also have "... = (0, tps1[j1 := tps1 ! j1 |+| 1, k := \<lceil>todigit (tps1 :.: j1) + 2\<rceil>])"
+      (is "_ = (0, ?tps)")
+    proof -
+      have "tps1 ! j1 = (\<lfloor>zs\<rfloor>, ?i)"
+        using lentps tps1_def j1_neq j_less by simp
+      moreover have "?i > 0"
+        by simp
+      moreover have "tps1 ! k = tps ! k"
+        using tps1_def by (simp add: j_less(1) j_less(2) nat_neq_iff)
+      moreover have "?i \<le> length zs"
+        by (simp add: assms(6))
+      ultimately have "sem (cmd_bindec j1 j2) (0, tps1) = (0, ?tps)"
+        using sem_cmd_bindec_1 assms(1,4) bit_symbols_binencode bs j1_neq lentps tps1_def
+        by (metis length_list_update)
+      then show ?thesis
+        by simp
+    qed
+    also have "... = (0, tps2)"
+    proof -
+      have "tps2 ! j1 = ?tps ! j1"
+        using tps1_def tps2_def j1_neq j_less(1) lentps by simp
+      moreover have "tps2 ! j2 = ?tps ! j2"
+        using tps1_def tps2_def j1_neq j_less(2) lentps ys by simp
+      ultimately have "tps2 = ?tps"
+        using tps2_def tps1_def j_less(1) lentps
+        by (smt (z3) list_update_id list_update_overwrite list_update_swap)
+      then show ?thesis
+        by simp
+    qed
+    finally show ?thesis .
+  qed
+  ultimately have "transits ?M (0, tps) (2 * l + 1) (0, tps2)"
+    using execute_imp_transits transits_additive by blast
+  moreover have "execute ?M (0, tps2) 1 = (1, tps')"
+  proof -
+    have "execute ?M (0, tps2) 1 = exe ?M (0, tps2)"
+      by simp
+    also have "... = sem (cmd_bindec j1 j2) (0, tps2)"
+      using exe_lt_length tm_bindec_def by simp
+    also have "... = (1, tps2)"
+    proof -
+      have "2 * l + 2 > length zs"
+        using assms(5,6) by simp
+      moreover have "tps2 ! j1 = (\<lfloor>zs\<rfloor>, 2 * l + 2)"
+        using tps2_def j1_neq j_less(1) lentps by simp
+      ultimately show ?thesis
+        using sem_cmd_bindec_gt[of tps2 zs "2 * l + 2"]
+        by (metis bs j1_neq length_list_update lentps tps2_def)
+    qed
+    moreover have "tps2 = tps'"
+    proof -
+      have "tps1 :.: j1 = last zs"
+        using tps1_def assms \<open>zs \<noteq> []\<close> contents_inbounds
+        by (metis Suc_leI add.commute fst_conv j1_neq j_less(1) last_conv_nth lentps less_Suc_eq
+          nth_list_update_eq nth_list_update_neq plus_1_eq_Suc snd_conv zero_less_Suc)
+      then show ?thesis
+        using tps2_def assms(4) by simp
+    qed
+    ultimately show ?thesis
+      by simp
+  qed
+  ultimately have "transits ?M (0, tps) (2 * l + 2) (1, tps')"
+    using execute_imp_transits transits_additive by (smt (z3) ab_semigroup_add_class.add_ac(1) nat_1_add_1)
+  then show "transforms (tm_bindec j1 j2) tps (2 * l + 2) tps'"
+    using transforms_def tm_bindec_def by simp
+qed
+
+text \<open>
+In case the input is of even length, that is, properly encoded:
+\<close>
+
+lemma transforms_tm_bindec_even:
+  assumes "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+    and "tps' = tps
+      [j1 := (\<lfloor>zs\<rfloor>, 2 * l + 1),
+       j2 := (\<lfloor>bindecode zs\<rfloor>, Suc l)]"
+    and "l = length zs div 2"
+    and "2 * l = length zs"
+  shows "transforms (tm_bindec j1 j2) tps (2 * l + 1) tps'"
+proof -
+  let ?ys = "bindecode (take (2 * l) zs)"
+  let ?i = "2 * l + 1"
+  let ?M = "tm_bindec j1 j2"
+  have ys: "?ys = bindecode zs"
+    using assms(6) by simp
+  have "transits ?M (0, tps) (2 * l) (0, tps')"
+    using assms transits_tm_bindec'' by simp
+  moreover have "execute ?M (0, tps') 1 = (1, tps')"
+  proof -
+    have "execute ?M (0, tps') 1 = exe ?M (0, tps')"
+      using assms(4) by simp
+    also have "... = sem (cmd_bindec j1 j2) (0, tps')"
+      using exe_lt_length tm_bindec_def by simp
+    also have "... = (1, tps')"
+    proof -
+      have "tps' ! j1 = (\<lfloor>zs\<rfloor>, ?i)"
+        using lentps assms(4) j1_neq j_less by simp
+      moreover have "?i > length zs"
+        using assms(6) by simp
+      moreover have "tps' ! k = tps ! k"
+        using assms(4) by (simp add: j_less(1) j_less(2) nat_neq_iff)
+      ultimately have "sem (cmd_bindec j1 j2) (0, tps') = (1, tps')"
+        using sem_cmd_bindec_gt assms(1,4) bit_symbols_binencode bs j1_neq lentps assms(4)
+        by simp
+      then show ?thesis
+        by simp
+    qed
+    finally show ?thesis .
+  qed
+  ultimately have "transits ?M (0, tps) (2 * l + 1) (1, tps')"
+    using execute_imp_transits transits_additive by blast
+  then show "transforms (tm_bindec j1 j2) tps (2 * l + 1) tps'"
+    using tm_bindec_def transforms_def by simp
+qed
+
+lemma transforms_tm_bindec:
+  assumes "tps ! k = \<lceil>\<triangleright>\<rceil>"
+    and "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+    and "tps' = tps
+      [j1 := (\<lfloor>zs\<rfloor>, Suc (length zs)),
+       j2 := (\<lfloor>bindecode zs\<rfloor>, Suc (length zs div 2)),
+       k := \<lceil>if even (length zs) then 1 else (todigit (last zs) + 2)\<rceil>]"
+  shows "transforms (tm_bindec j1 j2) tps (Suc (length zs)) tps'"
+proof (cases "even (length zs)")
+  case True
+  then show ?thesis
+    using transforms_tm_bindec_even[OF assms(1-3)] assms(1,4) j_less(1) j_less(2)
+    by (smt (z3) Suc_eq_plus1 dvd_mult_div_cancel list_update_id list_update_swap nat_neq_iff)
+next
+  case False
+  then show ?thesis
+    using assms(4) transforms_tm_bindec_odd[OF assms(1-3)] by simp
+qed
+
+end  (* context tps zs *)
+
+end  (* context j1 j2 k *)
+
+text \<open>
+Next we eliminate the memorization tape from @{const tm_bindec}.
+\<close>
+
+lemma transforms_cartesian_bindec:
+  assumes "G \<ge> (6 :: nat)"
+  assumes "j1 \<noteq> j2"
+    and j1j2: "0 < j2" "j1 < k" "j2 < k"
+    and "k = length tps"
+    and "bit_symbols zs"
+  assumes "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    and "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "t = Suc (length zs)"
+    and "tps' = tps
+      [j1 := (\<lfloor>zs\<rfloor>, Suc (length zs)),
+       j2 := (\<lfloor>bindecode zs\<rfloor>, Suc (length zs div 2))]"
+  shows "transforms (cartesian (tm_bindec j1 j2) 4) tps t tps'"
+proof (rule cartesian_transforms_onesie)
+  show "turing_machine (Suc k) G (tm_bindec j1 j2)"
+    using tm_bindec_tm assms(1) j1j2 by simp
+  show "immobile (tm_bindec j1 j2) k (Suc k)"
+  proof (standard+)
+    fix q :: nat and rs :: "symbol list"
+    assume "q < length (tm_bindec j1 j2)" "length rs = Suc k"
+    then have *: "tm_bindec j1 j2 ! q = cmd_bindec j1 j2"
+      using tm_bindec_def by simp
+    moreover have "cmd_bindec j1 j2 rs [~] k = Stay"
+      using cmd_bindec_def `length rs = Suc k` j1j2
+      by (smt (verit, best) add_diff_inverse_nat diff_zero length_upt lessI less_nat_zero_code
+        nat_neq_iff nth_map nth_upt prod.sel(2))
+    ultimately show "(tm_bindec j1 j2 ! q) rs [~] k = Stay"
+      using * by simp
+  qed
+  show "2 \<le> k"
+    using j1j2 by linarith
+  show "(1::nat) < 4"
+    by simp
+  show "length tps = k"
+    using assms(3,6) by simp
+  show "bounded_write (tm_bindec j1 j2) k 4"
+  proof -
+    { fix q :: nat and rs :: "symbol list"
+      assume q: "q < length (tm_bindec j1 j2)" and rs: "length rs = Suc k"
+      then have "tm_bindec j1 j2 ! q = cmd_bindec j1 j2"
+        using tm_bindec_def by simp
+      have "cmd_bindec j1 j2 rs [.] (length rs - 1) < 4 \<or> fst (cmd_bindec j1 j2 rs) = 1"
+      proof (cases "rs ! j1 = 0")
+        case True
+        then show ?thesis
+          using cmd_bindec_def by simp
+      next
+        case else: False
+        show ?thesis
+        proof (cases "last rs = 1")
+          case True
+          then have "snd (cmd_bindec j1 j2 rs) = map (\<lambda>i.
+                  if i = j1 then (rs ! i, Right)
+                  else if i = j2 then (rs ! i, Stay)
+                  else if i = length rs - 1 then (todigit (rs ! j1) + 2, Stay)
+                  else (rs ! i, Stay)) [0..<length rs]"
+            using else cmd_bindec_def by simp
+          then have "snd (cmd_bindec j1 j2 rs) ! k = (todigit (rs ! j1) + 2, Stay)"
+            using rs j1j2
+            by (smt (z3) add.left_neutral diff_Suc_1 diff_zero length_upt lessI nat_neq_iff nth_map nth_upt)
+          then show ?thesis
+            using rs by simp
+        next
+          case False
+          then have "snd (cmd_bindec j1 j2 rs) = map (\<lambda>i.
+                if i = j1 then (rs ! i, Right)
+                else if i = j2 then (2 * todigit (last rs) + todigit (rs ! j1) + 2, Right)
+                else if i = length rs - 1 then (1, Stay)
+                else (rs ! i, Stay)) [0..<length rs]"
+            using else cmd_bindec_def by simp
+          then have "snd (cmd_bindec j1 j2 rs) ! k = (1, Stay)"
+            using rs j1j2
+            by (smt (z3) add.left_neutral diff_Suc_1 diff_zero length_upt lessI nat_neq_iff nth_map nth_upt)
+          then show ?thesis
+            using rs by simp
+        qed
+      qed
+    }
+    then show ?thesis
+      using bounded_write_def tm_bindec_def by simp
+  qed
+  let ?c = "if even (length zs) then \<triangleright> else (todigit (last zs) + 2)"
+  show "transforms (tm_bindec j1 j2) (tps @ [\<lceil>\<triangleright>\<rceil>]) t (tps' @ [\<lceil>?c\<rceil>])"
+    (is "transforms _ ?tps t ?tps'")
+  proof -
+    have "?tps ! k = \<lceil>\<triangleright>\<rceil>"
+      by (simp add: assms(6))
+    moreover have "?tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+      by (metis assms(6) assms(8) j1j2(2) nth_append)
+    moreover have "?tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+      by (metis assms(6) assms(9) j1j2(3) nth_append)
+    moreover have "?tps' = ?tps
+      [j1 := (\<lfloor>zs\<rfloor>, Suc (length zs)),
+       j2 := (\<lfloor>bindecode zs\<rfloor>, Suc (length zs div 2)),
+       k := \<lceil>?c\<rceil>]"
+      by (metis (no_types, lifting) assms(6,11) j1j2(2,3) length_list_update list_update_append1 list_update_length)
+    ultimately show ?thesis
+      using transforms_tm_bindec[of j1 "k" j2 ?tps zs ?tps'] assms by simp
+  qed
+qed
+
+text \<open>
+The next Turing machine decodes a bit symbol sequence given on tape $j_1$ into a
+quaternary symbol sequence output to tape $j_2$. It executes the previous TM
+followed by carriage returns on the tapes $j_1$ and $j_2$.
+\<close>
+
+definition tm_bindecode :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_bindecode j1 j2 \<equiv> cartesian (tm_bindec j1 j2) 4 ;; tm_cr j1 ;; tm_cr j2"
+
+lemma tm_bindecode_tm:
+  fixes j1 j2 :: tapeidx and G k :: nat
+  assumes "G \<ge> 6" and "j1 < k" and "j2 < k" and "0 < j2" and "j1 \<noteq> j2"
+  shows "turing_machine k G (tm_bindecode j1 j2)"
+  using assms tm_bindec_tm tm_bindecode_def cartesian_tm tm_cr_tm by simp
+
+locale turing_machine_bindecode =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> cartesian (tm_bindec j1 j2) 4"
+definition "tm2 \<equiv> tm1 ;; tm_cr j1"
+definition "tm3 \<equiv> tm2 ;; tm_cr j2"
+
+lemma tm3_eq_tm_bindecode: "tm3 = tm_bindecode j1 j2"
+  using tm1_def tm2_def tm3_def tm_bindecode_def by simp
+
+context
+  fixes tps0 :: "tape list" and zs :: "symbol list" and k :: nat
+  assumes jk: "j1 < k" "j2 < k" "0 < j2" "j1 \<noteq> j2" "k = length tps0"
+  assumes zs: "bit_symbols zs"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps0 ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j1 := (\<lfloor>zs\<rfloor>, Suc (length zs)),
+   j2 := (\<lfloor>bindecode zs\<rfloor>, Suc (length zs div 2))]"
+
+lemma tm1 [transforms_intros]:
+  assumes "t = Suc (length zs)"
+  shows "transforms tm1 tps0 t tps1"
+  unfolding tm1_def
+  using transforms_cartesian_bindec assms jk tps0 zs tps1_def by blast
+
+definition "tps2 \<equiv> tps0
+  [j2 := (\<lfloor>bindecode zs\<rfloor>, Suc (length zs div 2))]"
+
+lemma tm2 [transforms_intros]:
+  assumes "t = 2 * length zs + 4"
+  shows "transforms tm2 tps0 t tps2"
+  unfolding tm2_def
+proof (tform tps: assms)
+  show "j1 < length tps1"
+    using jk tps1_def by simp
+  show "clean_tape (tps1 ! j1)"
+    using jk zs clean_contents_proper tps1_def by fastforce
+  show "tps2 = tps1[j1 := tps1 ! j1 |#=| 1]"
+    using tps0 jk tps2_def tps1_def
+    by (metis (no_types, lifting) fst_conv list_update_id list_update_overwrite list_update_swap nth_list_update_eq nth_list_update_neq)
+  show "t = Suc (length zs) + (tps1 :#: j1 + 2)"
+    using assms(1) jk tps1_def by simp
+qed
+
+definition "tps3 \<equiv> tps0
+  [j2 := (\<lfloor>bindecode zs\<rfloor>, 1)]"
+
+lemma tm3:
+  assumes "t = 2 * length zs + 7 + length zs div 2"
+  shows "transforms tm3 tps0 t tps3"
+  unfolding tm3_def
+proof (tform tps: jk tps2_def tps3_def assms)
+  show "clean_tape (tps2 ! j2)"
+    using jk bindecode_at tps2_def by simp
+qed
+
+lemma tm3':
+  assumes "t = 7 + 3 * length zs"
+  shows "transforms tm3 tps0 t tps3"
+proof -
+  have "7 + 3 * length zs \<ge> 2 * length zs + 7 + length zs div 2"
+    by simp
+  then show ?thesis
+    using transforms_monotone tm3 assms tps3_def by simp
+qed
+
+end  (* context tps zs *)
+
+end  (* locale turing_machine_bindecode *)
+
+lemma transforms_tm_bindecodeI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps :: "tape list" and zs :: "symbol list" and k ttt :: nat
+  assumes "j1 < k" and "j2 < k" and "0 < j2" and "j1 \<noteq> j2" and "k = length tps"
+    and "bit_symbols zs"
+  assumes
+    "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 7 + 3 * length zs"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>bindecode zs\<rfloor>, 1)]"
+  shows "transforms (tm_bindecode j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_bindecode j1 j2 .
+  show ?thesis
+    using loc.tm3_eq_tm_bindecode loc.tm3' loc.tps3_def assms by simp
+qed
+
+end
diff --git a/thys/Cook_Levin/Wellformed.thy b/thys/Cook_Levin/Wellformed.thy
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/Wellformed.thy
@@ -0,0 +1,1651 @@
+section \<open>Well-formedness of lists\label{s:tm-wellformed}\<close>
+
+theory Wellformed
+  imports Symbol_Ops Lists_Lists
+begin
+
+text \<open>
+In the representations introduced in Section~\ref{s:tm-numlist} and
+Section~\ref{s:tm-numlistlist}, not every symbol sequence over @{text "\<zero>\<one>\<bar>"}
+represents a list of numbers, and not every symbol sequence over @{text
+"\<zero>\<one>\<bar>\<sharp>"} represents a list of lists of numbers. In this section we prove
+criteria for symbol sequences to represent such lists and devise Turing machines
+to check these criteria efficiently.
+\<close>
+
+
+subsection \<open>A criterion for well-formed lists\<close>
+
+text \<open>
+From the definition of @{const numlist} it is easy to see that a symbol sequence
+representing a list of numbers is either empty or not, and that in the latter
+case it ends with a @{text "\<bar>"} symbol. Moreover it can only contain the symbols
+@{text "\<zero>\<one>\<bar>"} and cannot contain the symbol sequence @{text "\<zero>\<bar>"} because
+canonical number representations cannot end in @{text \<zero>}. That these properties
+are not only necessary but also sufficient for the symbol sequence to represent
+a list of numbers is shown in this section.
+
+A symbol sequence is well-formed if it represents a list of numbers.
+\<close>
+
+definition numlist_wf :: "symbol list \<Rightarrow> bool" where
+  "numlist_wf zs \<equiv> \<exists>ns. numlist ns = zs"
+
+lemma numlist_wf_append:
+  assumes "numlist_wf xs" and "numlist_wf ys"
+  shows "numlist_wf (xs @ ys)"
+proof -
+  obtain ms ns where "numlist ms = xs" and "numlist ns = ys"
+    using assms numlist_wf_def by auto
+  then have "numlist (ms @ ns) = xs @ ys"
+    using numlist_append by simp
+  then show ?thesis
+    using numlist_wf_def by auto
+qed
+
+lemma numlist_wf_canonical:
+  assumes "canonical xs"
+  shows "numlist_wf (xs @ [\<bar>])"
+proof -
+  obtain n where "canrepr n = xs"
+    using assms canreprI by blast
+  then have "numlist [n] = xs @ [\<bar>]"
+    using numlist_def by simp
+  then show ?thesis
+    using numlist_wf_def by auto
+qed
+
+text \<open>
+Well-formed symbol sequences can be unambiguously decoded to lists of numbers.
+\<close>
+
+definition zs_numlist :: "symbol list \<Rightarrow> nat list" where
+  "zs_numlist zs \<equiv> THE ns. numlist ns = zs"
+
+lemma zs_numlist_ex1:
+  assumes "numlist_wf zs"
+  shows "\<exists>!ns. numlist ns = zs"
+  using assms numlist_wf_def numlist_inj by blast
+
+lemma numlist_zs_numlist:
+  assumes "numlist_wf zs"
+  shows "numlist (zs_numlist zs) = zs"
+  using assms zs_numlist_def zs_numlist_ex1 by (smt (verit, del_insts) the_equality)
+
+text \<open>
+Count the number of occurrences of an element in a list:
+\<close>
+
+fun count :: "nat list \<Rightarrow> nat \<Rightarrow> nat" where
+  "count [] z = 0" |
+  "count (x # xs) z = (if x = z then 1 else 0) + count xs z"
+
+lemma count_append: "count (xs @ ys) z = count xs z + count ys z"
+  by (induction xs) simp_all
+
+lemma count_0: "count xs z = 0 \<longleftrightarrow> (\<forall>x\<in>set xs. x \<noteq> z)"
+proof
+  show "count xs z = 0 \<Longrightarrow> \<forall>x\<in>set xs. x \<noteq> z"
+    by (induction xs) auto
+  show "\<forall>x\<in>set xs. x \<noteq> z \<Longrightarrow> count xs z = 0"
+    by (induction xs) auto
+qed
+
+lemma count_gr_0_take:
+  assumes "count xs z > 0"
+  shows "\<exists>j.
+    j < length xs \<and>
+    xs ! j = z \<and>
+    (\<forall>i<j. xs ! i \<noteq> z) \<and>
+    count (take (Suc j) xs) z = 1 \<and>
+    count (drop (Suc j) xs) z = count xs z - 1"
+proof -
+  let ?P = "\<lambda>i. i < length xs \<and> xs ! i = z"
+  have ex: "\<exists>i. ?P i"
+    using assms(1) count_0 by (metis bot_nat_0.not_eq_extremum in_set_conv_nth)
+  define j where "j = Least ?P"
+  have 1: "j < length xs"
+    using j_def ex by (metis (mono_tags, lifting) LeastI)
+  moreover have 2: "xs ! j = z"
+    using j_def ex by (metis (mono_tags, lifting) LeastI)
+  moreover have 3: "\<forall>i<j. xs ! i \<noteq> z"
+    using j_def ex 1 not_less_Least order_less_trans by blast
+  moreover have 4: "count (take (Suc j) xs) z = 1"
+  proof -
+    have "\<forall>x\<in>set (take j xs). x \<noteq> z"
+      using 3 1 by (metis in_set_conv_nth length_take less_imp_le_nat min_absorb2 nth_take)
+    then have "count (take j xs) z = 0"
+      using count_0 by simp
+    moreover have "count [xs ! j] z = 1"
+      using 2 by simp
+    moreover have "take (Suc j) xs = take j xs @ [xs ! j]"
+      using 1 take_Suc_conv_app_nth by auto
+    ultimately show "count (take (Suc j) xs) z = 1"
+      using count_append by simp
+  qed
+  moreover have "count (drop (Suc j) xs) z = count xs z - 1"
+  proof -
+    have "xs = take (Suc j) xs @ drop (Suc j) xs"
+      using 1 by simp
+    then show ?thesis
+      using count_append 4 by (metis add_diff_cancel_left')
+  qed
+  ultimately show ?thesis
+    by auto
+qed
+
+definition has2 :: "symbol list \<Rightarrow> symbol \<Rightarrow> symbol \<Rightarrow> bool" where
+  "has2 xs y z \<equiv> \<exists>i<length xs - 1. xs ! i = y \<and> xs ! (Suc i) = z"
+
+lemma not_has2_take:
+  assumes "\<not> has2 xs y z"
+  shows "\<not> has2 (take m xs) y z"
+proof (rule ccontr)
+  let ?ys = "take m xs"
+  assume "\<not> \<not> has2 ?ys y z"
+  then have "has2 ?ys y z"
+    by simp
+  then have "has2 xs y z"
+    using has2_def by fastforce
+  then show False
+    using assms by simp
+qed
+
+lemma not_has2_drop:
+  assumes "\<not> has2 xs y z"
+  shows "\<not> has2 (drop m xs) y z"
+proof (rule ccontr)
+  let ?ys = "drop m xs"
+  assume "\<not> \<not> has2 ?ys y z"
+  then have "has2 ?ys y z"
+    by simp
+  then have "has2 xs y z"
+    using has2_def by fastforce
+  then show False
+    using assms by simp
+qed
+
+lemma numlist_wf_has2:
+  assumes "proper_symbols xs" "symbols_lt 5 xs" "\<not> has2 xs \<zero> \<bar>" "xs \<noteq> [] \<longrightarrow> last xs = \<bar>"
+  shows "numlist_wf xs"
+  using assms
+proof (induction "count xs \<bar>" arbitrary: xs)
+  case 0
+  then have "xs = []"
+    using count_0 by simp
+  then show ?case
+    using numlist_wf_def numlist_Nil by blast
+next
+  case (Suc n)
+  then obtain j :: nat where j:
+    "j < length xs"
+    "xs ! j = \<bar>"
+    "\<forall>i<j. xs ! i \<noteq> \<bar>"
+    "count (take (Suc j) xs) \<bar> = 1"
+    "count (drop (Suc j) xs) \<bar> = count xs \<bar> - 1"
+    by (metis count_gr_0_take zero_less_Suc)
+  then have "xs \<noteq> []"
+    by auto
+  then have "last xs = \<bar>"
+    using Suc.prems by simp
+
+  let ?ys = "drop (Suc j) xs"
+  have "count ?ys \<bar> = n"
+    using j(5) Suc by simp
+  moreover have "proper_symbols ?ys"
+    using Suc.prems by simp
+  moreover have "symbols_lt 5 ?ys"
+    using Suc.prems by simp
+  moreover have "\<not> has2 ?ys \<zero> \<bar>"
+    using not_has2_drop Suc.prems(3) by simp
+  moreover have "?ys \<noteq> [] \<longrightarrow> last ?ys = \<bar>"
+    using j by (simp add: \<open>last xs = \<bar>\<close>)
+  ultimately have wf_ys: "numlist_wf ?ys"
+    using Suc by simp
+
+  let ?zs = "take j xs"
+  have "canonical ?zs"
+  proof -
+    have "?zs ! i \<ge> \<zero>" if "i < length ?zs" for i
+      using that Suc.prems(1) j by (metis One_nat_def Suc_1 Suc_leI length_take min_less_iff_conj nth_take)
+    moreover have "?zs ! i \<le> \<one>" if "i < length ?zs" for i
+    proof -
+      have "?zs ! i < \<bar>"
+        using that Suc.prems(1,2) j
+        by (metis eval_nat_numeral(3) length_take less_Suc_eq_le min_less_iff_conj nat_less_le nth_take)
+      then show ?thesis
+        by simp
+    qed
+    ultimately have "bit_symbols ?zs"
+      by fastforce
+    moreover have "?zs = [] \<or> last ?zs = \<one>"
+    proof (cases "?zs = []")
+      case True
+      then show ?thesis
+        by simp
+    next
+      case False
+      then have "last ?zs = ?zs ! (j - 1)"
+        by (metis add_diff_inverse_nat j(1) last_length length_take less_imp_le_nat less_one
+          min_absorb2 plus_1_eq_Suc take_eq_Nil)
+      then have last: "last ?zs = xs ! (j - 1)"
+        using False by simp
+      have "xs ! (j - 1) \<noteq> \<bar>"
+        using j(3) False by simp
+      moreover have "xs ! (j - 1) < \<sharp>"
+        using Suc.prems(2) j(1) by simp
+      moreover have "xs ! (j - 1) \<ge> \<zero>"
+        using Suc.prems(1) j(1) by (metis One_nat_def Suc_1 Suc_leI less_imp_diff_less)
+      moreover have "xs ! (j - 1) \<noteq> \<zero>"
+      proof (rule ccontr)
+        assume "\<not> xs ! (j - 1) \<noteq> \<zero>"
+        then have "xs ! (j - 1) = \<zero>"
+          by simp
+        moreover have "xs ! j = \<bar>"
+          using j by simp
+        ultimately have "has2 xs \<zero> \<bar>"
+          using has2_def j False
+          by (metis (no_types, lifting) Nat.lessE add_diff_cancel_left' less_Suc_eq_0_disj not_less_eq plus_1_eq_Suc take_eq_Nil)
+        then show False
+          using Suc.prems(3) by simp
+      qed
+      ultimately have "xs ! (j - 1) = \<one>"
+        by simp
+      then have "last ?zs = \<one>"
+        using last by simp
+      then show ?thesis
+        by simp
+    qed
+    ultimately show "canonical ?zs"
+      using canonical_def by simp
+  qed
+
+  let ?ts = "take (Suc j) xs"
+  have "?ts = ?zs @ [\<bar>]"
+    using j by (metis take_Suc_conv_app_nth)
+  then have "numlist_wf ?ts"
+    using numlist_wf_canonical `canonical ?zs` by simp
+  moreover have "xs = ?ts @ ?ys"
+    by simp
+  ultimately show "numlist_wf xs"
+    using wf_ys numlist_wf_append by fastforce
+qed
+
+lemma last_numlist_4: "numlist ns \<noteq> [] \<Longrightarrow> last (numlist ns) = \<bar>"
+proof (induction ns)
+  case Nil
+  then show ?case
+    using numlist_def by simp
+next
+  case (Cons n ns)
+  then show ?case
+    using numlist_def by (cases "numlist ns = []") simp_all
+qed
+
+lemma numlist_not_has2:
+  assumes "i < length (numlist ns) - 1" and "numlist ns ! i = \<zero>"
+  shows "numlist ns ! (Suc i) \<noteq> \<bar>"
+  using assms
+proof (induction ns arbitrary: i)
+  case Nil
+  then show ?case
+    by (simp add: numlist_Nil)
+next
+  case (Cons n ns)
+  show "numlist (n # ns) ! (Suc i) \<noteq> \<bar>"
+  proof (cases "i < length (numlist [n])")
+    case True
+    have "numlist (n # ns) ! i = (numlist [n] @ numlist ns) ! i"
+      using numlist_def by simp
+    then have "numlist (n # ns) ! i = numlist [n] ! i"
+      using True by (simp add: nth_append)
+    then have "numlist (n # ns) ! i = (canrepr n @ [\<bar>]) ! i"
+      using numlist_def by simp
+    moreover have "numlist (n # ns) ! i = \<zero>"
+      using Cons by simp
+    ultimately have "(canrepr n @ [\<bar>]) ! i = \<zero>"
+      by simp
+    moreover have "(canrepr n @ [\<bar>]) ! (length (canrepr n @ [\<bar>]) - 1) = \<bar>"
+      by simp
+    ultimately have "i \<noteq> length (canrepr n @ [\<bar>]) - 1"
+      by auto
+    then have *: "i \<noteq> length (numlist [n]) - 1"
+      using numlist_def by simp
+
+    have 3: "canrepr n ! j = numlist (n # ns) ! j" if "j < nlength n" for j
+    proof -
+      have j: "j < length (numlist [n])"
+        using that numlist_def by simp
+      have "numlist (n # ns) ! j = (numlist [n] @ numlist ns) ! j"
+        using numlist_def by simp
+      then have "numlist (n # ns) ! j = numlist [n] ! j"
+        using j by (simp add: nth_append)
+      then have "numlist (n # ns) ! j = (canrepr n @ [\<bar>]) ! j"
+        using numlist_def by simp
+      then show ?thesis
+        by (simp add: nth_append that)
+    qed
+
+    have neq0: "n \<noteq> 0"
+    proof -
+      have "length (numlist [0]) = 1"
+        using numlist_def by simp
+      then show ?thesis
+        using * True by (metis diff_self_eq_0 less_one)
+    qed
+    then have "i < length (numlist [n]) - 1"
+      using * True by simp
+    then have "i < length (canrepr n @ [\<bar>]) - 1"
+      using numlist_def by simp
+    then have "i < length (canrepr n)"
+      by simp
+    then have "canrepr n ! i = \<zero>"
+      by (metis \<open>(canrepr n @ [\<bar>]) ! i = \<zero>\<close> nth_append)
+    moreover have "last (canrepr n) \<noteq> \<zero>"
+      using canonical_canrepr canonical_def
+      by (metis neq0 length_0_conv n_not_Suc_n nlength_0 numeral_2_eq_2 numeral_3_eq_3)
+    ultimately have "i \<noteq> nlength n - 1"
+      by (metis \<open>i < nlength n\<close> last_conv_nth less_zeroE list.size(3))
+    then have "i < nlength n - 1"
+      using \<open>i < nlength n\<close> by linarith
+    then have "Suc i < nlength n"
+      by simp
+    then have "canrepr n ! Suc i \<le> \<one>"
+      using bit_symbols_canrepr by fastforce
+    moreover have "canrepr n ! Suc i = numlist (n # ns) ! Suc i"
+      using 3 \<open>Suc i < nlength n\<close> by blast
+    ultimately show ?thesis
+      by simp
+  next
+    case False
+    let ?i = "i - length (numlist [n])"
+    have "numlist (n # ns) ! i = (numlist [n] @ numlist ns) ! i"
+      using numlist_def by simp
+    then have "numlist (n # ns) ! i = numlist ns ! ?i"
+      using False by (simp add: nth_append)
+    then have "numlist ns ! ?i = \<zero>"
+      using Cons by simp
+    moreover have "?i < length (numlist ns) - 1"
+    proof -
+      have "length (numlist (n # ns)) = length (numlist [n]) + length (numlist ns)"
+        using numlist_def by simp
+      then show ?thesis
+        using False Cons by simp
+    qed
+    ultimately have "numlist ns ! Suc ?i \<noteq> \<bar>"
+      using Cons by simp
+    moreover have "numlist (n # ns) ! Suc i = numlist ns ! Suc ?i"
+      using False numlist_append
+      by (smt (verit, del_insts) Suc_diff_Suc Suc_lessD append_Cons append_Nil diff_Suc_Suc not_less_eq nth_append)
+    ultimately show ?thesis
+      by simp
+  qed
+qed
+
+lemma numlist_wf_has2':
+  assumes "numlist_wf xs"
+  shows "proper_symbols_lt 5 xs \<and> \<not> has2 xs \<zero> \<bar> \<and> (xs \<noteq> [] \<longrightarrow> last xs = \<bar>)"
+proof -
+  obtain ns where ns: "numlist ns = xs"
+    using numlist_wf_def assms by auto
+  have "proper_symbols xs"
+    using proper_symbols_numlist ns by auto
+  moreover have "symbols_lt 5 xs"
+    using ns numlist_234
+    by (smt (verit, best) One_nat_def Suc_1 eval_nat_numeral(3) in_mono insertE less_Suc_eq_le
+      linorder_le_less_linear nle_le not_less0 nth_mem numeral_less_iff semiring_norm(76)
+      semiring_norm(89) semiring_norm(90) singletonD)
+  moreover have "\<not> has2 xs \<zero> \<bar>"
+    using numlist_not_has2 ns has2_def by auto
+  moreover have "xs \<noteq> [] \<longrightarrow> last xs = \<bar>"
+    using last_numlist_4 ns by auto
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma numlist_wf_iff:
+  "numlist_wf xs \<longleftrightarrow> proper_symbols_lt 5 xs \<and> \<not> has2 xs \<zero> \<bar> \<and> (xs \<noteq> [] \<longrightarrow> last xs = \<bar>)"
+  using numlist_wf_has2 numlist_wf_has2' by auto
+
+
+subsection \<open>A criterion for well-formed lists of lists\<close>
+
+text \<open>
+The criterion for lists of lists of numbers is similar to the one for lists of
+numbers. A non-empty symbol sequence must end in @{text \<sharp>}. All symbols must be
+from @{text "\<zero>\<one>\<bar>\<sharp>"} and the sequences @{text "\<zero>\<bar>"}, @{text "\<zero>\<sharp>"}, and @{text
+"\<one>\<sharp>"} are forbidden.
+
+A symbol sequence is well-formed if it represents a list of lists of numbers.
+\<close>
+
+definition numlistlist_wf :: "symbol list \<Rightarrow> bool" where
+  "numlistlist_wf zs \<equiv> \<exists>nss. numlistlist nss = zs"
+
+lemma numlistlist_wf_append:
+  assumes "numlistlist_wf xs" and "numlistlist_wf ys"
+  shows "numlistlist_wf (xs @ ys)"
+proof -
+  obtain ms ns where "numlistlist ms = xs" and "numlistlist ns = ys"
+    using assms numlistlist_wf_def by auto
+  then have "numlistlist (ms @ ns) = xs @ ys"
+    using numlistlist_append by simp
+  then show ?thesis
+    using numlistlist_wf_def by auto
+qed
+
+lemma numlistlist_wf_numlist_wf:
+  assumes "numlist_wf xs"
+  shows "numlistlist_wf (xs @ [\<sharp>])"
+proof -
+  obtain ns where "numlist ns = xs"
+    using assms numlist_wf_def by auto
+  then have "numlistlist [ns] = xs @ [\<sharp>]"
+    using numlistlist_def by simp
+  then show ?thesis
+    using numlistlist_wf_def by auto
+qed
+
+lemma numlistlist_wf_has2:
+  assumes "proper_symbols xs" "symbols_lt 6 xs" "xs \<noteq> [] \<longrightarrow> last xs = \<sharp>"
+    and "\<not> has2 xs \<zero> \<bar>"
+    and "\<not> has2 xs \<zero> \<sharp>"
+    and "\<not> has2 xs \<one> \<sharp>"
+  shows "numlistlist_wf xs"
+  using assms
+proof (induction "count xs \<sharp>" arbitrary: xs)
+  case 0
+  then have "xs = []"
+    using count_0 by simp
+  then show ?case
+    using numlistlist_wf_def numlistlist_Nil by auto
+next
+  case (Suc n)
+  then obtain j :: nat where j:
+    "j < length xs"
+    "xs ! j = \<sharp>"
+    "\<forall>i<j. xs ! i \<noteq> \<sharp>"
+    "count (take (Suc j) xs) \<sharp> = 1"
+    "count (drop (Suc j) xs) \<sharp> = count xs \<sharp> - 1"
+    by (metis count_gr_0_take zero_less_Suc)
+  then have "xs \<noteq> []"
+    by auto
+  then have "last xs = \<sharp>"
+    using Suc.prems by simp
+  let ?ys = "drop (Suc j) xs"
+  have "count ?ys \<sharp> = n"
+    using j(5) Suc by simp
+  moreover have "proper_symbols ?ys"
+    using Suc.prems(1) by simp
+  moreover have "symbols_lt 6 ?ys"
+    using Suc.prems(2) by simp
+  moreover have "?ys \<noteq> [] \<longrightarrow> last ?ys = \<sharp>"
+    using j by (simp add: \<open>last xs = \<sharp>\<close>)
+  moreover have "\<not> has2 ?ys \<zero> \<bar>"
+    using not_has2_drop Suc.prems(4) by simp
+  moreover have "\<not> has2 ?ys \<zero> \<sharp>"
+    using not_has2_drop Suc.prems(5) by simp
+  moreover have "\<not> has2 ?ys \<one> \<sharp>"
+    using not_has2_drop Suc.prems(6) by simp
+  ultimately have wf_ys: "numlistlist_wf ?ys"
+    using Suc by simp
+
+  let ?zs = "take j xs"
+  have len: "length ?zs = j"
+    using j(1) by simp
+  have "numlist_wf ?zs"
+  proof -
+    have "proper_symbols ?zs"
+      using Suc.prems(1) by simp
+    moreover have "symbols_lt 5 ?zs"
+    proof standard+
+      fix i :: nat
+      assume "i < length ?zs"
+      then have "i < j"
+        using j by simp
+      then have "?zs ! i < 6"
+        using Suc.prems(2) j by simp
+      moreover have "?zs ! i \<noteq> \<sharp>"
+        using `i < j` j by simp
+      ultimately show "?zs ! i < \<sharp>"
+        by simp
+    qed
+    moreover have "\<not> has2 ?zs \<zero> \<bar>"
+      using not_has2_take Suc.prems(4) by simp
+    moreover have "?zs \<noteq> [] \<longrightarrow> last ?zs = \<bar>"
+    proof
+      assume neq_Nil: "?zs \<noteq> []"
+      then have "j > 0"
+        by simp
+      moreover have "xs ! j = \<sharp>"
+        using j by simp
+      ultimately have "xs ! Suc (j - 1) = \<sharp>"
+        by simp
+      moreover have "j - 1 < length xs - 1"
+        by (simp add: Suc_leI \<open>0 < j\<close> diff_less_mono j(1))
+      ultimately have "xs ! (j - 1) \<noteq> \<zero>" "xs ! (j - 1) \<noteq> \<one>"
+        using Suc.prems has2_def by auto
+      then have "?zs ! (j - 1) \<noteq> \<zero>" "?zs ! (j - 1) \<noteq> \<one>"
+        by (simp_all add: \<open>0 < j\<close>)
+      moreover have "?zs ! (j - 1) < \<sharp>"
+        using `symbols_lt 5 ?zs` `0 < j ` j(1) len
+        by simp
+      moreover have "?zs ! (j - 1) \<ge> \<zero>"
+        using `proper_symbols ?zs` len \<open>0 < j\<close> by (metis One_nat_def Suc_1 Suc_leI diff_less zero_less_one)
+      ultimately have "?zs ! (j - 1) = \<bar>"
+        by simp
+      then show "last ?zs = \<bar>"
+        using len by (metis last_conv_nth neq_Nil)
+    qed
+    ultimately show "numlist_wf ?zs"
+      using numlist_wf_iff by simp
+  qed
+
+  let ?ts = "take (Suc j) xs"
+  have "?ts = ?zs @ [\<sharp>]"
+    using j by (metis take_Suc_conv_app_nth)
+  then have "numlistlist_wf ?ts"
+    using numlistlist_wf_numlist_wf `numlist_wf ?zs` by simp
+  moreover have "xs = ?ts @ ?ys"
+    by simp
+  ultimately show "numlistlist_wf xs"
+    using wf_ys numlistlist_wf_append by fastforce
+qed
+
+lemma numlistlist_not_has2:
+  assumes "i < length (numlistlist nss) - 1" and "numlistlist nss ! i = \<zero>"
+  shows "numlistlist nss ! (Suc i) \<noteq> \<bar>"
+  using assms
+proof (induction nss arbitrary: i)
+  case Nil
+  then show ?case
+    by (simp add: numlistlist_Nil)
+next
+  case (Cons ns nss)
+  show "numlistlist (ns # nss) ! (Suc i) \<noteq> \<bar>"
+  proof (cases "i < length (numlistlist [ns])")
+    case True
+    have "numlistlist (ns # nss) ! i = (numlistlist [ns] @ numlistlist nss) ! i"
+      using numlistlist_def by simp
+    then have "numlistlist (ns # nss) ! i = numlistlist [ns] ! i"
+      using True by (simp add: nth_append)
+    then have "numlistlist (ns # nss) ! i = (numlist ns @ [\<sharp>]) ! i"
+      using numlistlist_def by simp
+    moreover have "numlistlist (ns # nss) ! i = \<zero>"
+      using Cons by simp
+    ultimately have "(numlist ns @ [\<sharp>]) ! i = \<zero>"
+      by simp
+    moreover have "(numlist ns @ [\<sharp>]) ! (length (numlist ns @ [\<sharp>]) - 1) = \<sharp>"
+      by simp
+    ultimately have "i \<noteq> length (numlist ns @ [\<sharp>]) - 1"
+      by auto
+    then have *: "i \<noteq> length (numlistlist [ns]) - 1"
+      using numlistlist_def by simp
+    then have **: "i < length (numlistlist [ns]) - 1"
+      using True by simp
+    then have ***: "i < length (numlist ns)"
+      using numlistlist_def by simp
+    then have "ns \<noteq> []"
+      using numlist_Nil by auto
+    then have "last (numlist ns) = \<bar>"
+      by (metis last_numlist_4 numlist_Nil numlist_inj)
+
+    have 3: "numlist ns ! j = numlistlist (ns # nss) ! j" if "j < length (numlist ns)" for j
+    proof -
+      have j: "j < length (numlistlist [ns])"
+        using that numlistlist_def by simp
+      have "numlistlist (ns # nss) ! j = (numlistlist [ns] @ numlistlist nss) ! j"
+        using numlistlist_def by simp
+      then have "numlistlist (ns # nss) ! j = numlistlist [ns] ! j"
+        using j by (simp add: nth_append)
+      then have "numlistlist (ns # nss) ! j = (numlist ns @ [\<sharp>]) ! j"
+        using numlistlist_def by simp
+      then show ?thesis
+        by (simp add: nth_append that)
+    qed
+    have 4: "numlistlist (ns # nss) ! (length (numlist ns)) = \<sharp>"
+      by (simp add: numlistlist_def)
+
+    show ?thesis
+    proof (cases "i = length (numlist ns) - 1")
+      case True
+      then show ?thesis
+        using 3 4 *** by (metis Suc_le_D Suc_le_eq diff_Suc_1 eval_nat_numeral(3) n_not_Suc_n)
+    next
+      case False
+      then have "i < length (numlist ns) - 1"
+        using *** by simp
+      then show ?thesis
+        using numlist_not_has2 *** 3 \<open>ns \<noteq> []\<close>
+        by (metis Cons.prems(2) Suc_diff_1 length_greater_0_conv not_less_eq numlist_Nil numlist_inj)
+    qed
+  next
+    case False
+    then have "i \<ge> length (numlistlist [ns])"
+      by simp
+    let ?i = "i - length (numlistlist [ns])"
+    have "numlistlist (ns # nss) ! i = (numlistlist [ns] @ numlistlist nss) ! i"
+      using numlistlist_def by simp
+    then have "numlistlist (ns # nss) ! i = numlistlist nss ! ?i"
+      using False by (simp add: nth_append)
+    then have "numlistlist nss ! ?i = \<zero>"
+      using Cons by simp
+    moreover have "?i < length (numlistlist nss) - 1"
+    proof -
+      have "length (numlistlist (ns # nss)) = length (numlistlist [ns]) + length (numlistlist nss)"
+        using numlistlist_def by simp
+      then show ?thesis
+        using False Cons by simp
+    qed
+    ultimately have "numlistlist nss ! Suc ?i \<noteq> \<bar>"
+      using Cons by simp
+    moreover have "numlistlist (ns # nss) ! Suc i = numlistlist nss ! Suc ?i"
+      using False numlistlist_append
+      by (smt (verit, del_insts) Suc_diff_Suc Suc_lessD append_Cons append_Nil diff_Suc_Suc not_less_eq nth_append)
+    ultimately show ?thesis
+      by simp
+  qed
+qed
+
+lemma numlistlist_not_has2':
+  assumes "i < length (numlistlist nss) - 1" and "numlistlist nss ! i = \<zero> \<or> numlistlist nss ! i = \<one>"
+  shows "numlistlist nss ! (Suc i) \<noteq> \<sharp>"
+  using assms
+proof (induction nss arbitrary: i)
+  case Nil
+  then show ?case
+    by (simp add: numlistlist_Nil)
+next
+  case (Cons ns nss)
+  show "numlistlist (ns # nss) ! (Suc i) \<noteq> \<sharp>"
+  proof (cases "i < length (numlistlist [ns])")
+    case True
+    have "numlistlist (ns # nss) ! i = (numlistlist [ns] @ numlistlist nss) ! i"
+      using numlistlist_def by simp
+    then have "numlistlist (ns # nss) ! i = numlistlist [ns] ! i"
+      using True by (simp add: nth_append)
+    then have "numlistlist (ns # nss) ! i = (numlist ns @ [\<sharp>]) ! i"
+      using numlistlist_def by simp
+    moreover have "numlistlist (ns # nss) ! i = \<zero> \<or> numlistlist (ns # nss) ! i = \<one>"
+      using Cons by simp
+    ultimately have "(numlist ns @ [\<sharp>]) ! i = \<zero> \<or> (numlist ns @ [\<sharp>]) ! i = \<one>"
+      by simp
+    moreover have "(numlist ns @ [\<sharp>]) ! (length (numlist ns @ [\<sharp>]) - 1) = \<sharp>"
+      by simp
+    ultimately have "i \<noteq> length (numlist ns @ [\<sharp>]) - 1"
+      by auto
+    then have "i \<noteq> length (numlistlist [ns]) - 1"
+      using numlistlist_def by simp
+    then have "i < length (numlistlist [ns]) - 1"
+      using True by simp
+    then have *: "i < length (numlist ns)"
+      using numlistlist_def by simp
+    then have "ns \<noteq> []"
+      using numlist_Nil by auto
+    then have "last (numlist ns) = \<bar>"
+      by (metis last_numlist_4 numlist_Nil numlist_inj)
+
+    have **: "numlist ns ! j = numlistlist (ns # nss) ! j" if "j < length (numlist ns)" for j
+    proof -
+      have j: "j < length (numlistlist [ns])"
+        using that numlistlist_def by simp
+      have "numlistlist (ns # nss) ! j = (numlistlist [ns] @ numlistlist nss) ! j"
+        using numlistlist_def by simp
+      then have "numlistlist (ns # nss) ! j = numlistlist [ns] ! j"
+        using j by (simp add: nth_append)
+      then have "numlistlist (ns # nss) ! j = (numlist ns @ [\<sharp>]) ! j"
+        using numlistlist_def by simp
+      then show ?thesis
+        by (simp add: nth_append that)
+    qed
+
+    show ?thesis
+    proof (cases "i = length (numlist ns) - 1")
+      case True
+      then show ?thesis
+        using \<open>last (numlist ns) = \<bar>\<close> \<open>ns \<noteq> []\<close> Cons.prems(2) * ** numlist_Nil numlist_inj
+        by (metis last_conv_nth num.simps(8) numeral_eq_iff semiring_norm(83) verit_eq_simplify(8))
+    next
+      case False
+      then have "i < length (numlist ns) - 1"
+        using * by simp
+      then show ?thesis
+        using * ** symbols_lt_numlist numlist_not_has2 by (metis Suc_lessI diff_Suc_1 less_irrefl_nat)
+    qed
+  next
+    case False
+    then have "i \<ge> length (numlistlist [ns])"
+      by simp
+    let ?i = "i - length (numlistlist [ns])"
+    have "numlistlist (ns # nss) ! i = (numlistlist [ns] @ numlistlist nss) ! i"
+      using numlistlist_def by simp
+    then have "numlistlist (ns # nss) ! i = numlistlist nss ! ?i"
+      using False by (simp add: nth_append)
+    then have "numlistlist nss ! ?i = \<zero> \<or> numlistlist nss ! ?i = \<one>"
+      using Cons by simp
+    moreover have "?i < length (numlistlist nss) - 1"
+    proof -
+      have "length (numlistlist (ns # nss)) = length (numlistlist [ns]) + length (numlistlist nss)"
+        using numlistlist_def by simp
+      then show ?thesis
+        using False Cons by simp
+    qed
+    ultimately have "numlistlist nss ! Suc ?i \<noteq> \<sharp>"
+      using Cons by simp
+    moreover have "numlistlist (ns # nss) ! Suc i = numlistlist nss ! Suc ?i"
+      using False numlistlist_append
+      by (smt (verit, del_insts) Suc_diff_Suc Suc_lessD append_Cons append_Nil diff_Suc_Suc not_less_eq nth_append)
+    ultimately show ?thesis
+      by simp
+  qed
+qed
+
+lemma last_numlistlist_5: "numlistlist nss \<noteq> [] \<Longrightarrow> last (numlistlist nss) = \<sharp>"
+  using numlistlist_def by (induction nss) simp_all
+
+lemma numlistlist_wf_has2':
+  assumes "numlistlist_wf xs"
+  shows "proper_symbols_lt 6 xs \<and> (xs \<noteq> [] \<longrightarrow> last xs = \<sharp>) \<and> \<not> has2 xs \<zero> \<bar> \<and> \<not> has2 xs \<zero> \<sharp> \<and> \<not> has2 xs \<one> \<sharp>"
+proof -
+  obtain nss where nss: "numlistlist nss = xs"
+    using numlistlist_wf_def assms by auto
+  have "proper_symbols xs"
+    using nss proper_symbols_numlistlist by auto
+  moreover have "symbols_lt 6 xs"
+    using nss symbols_lt_numlistlist by auto
+  moreover have "xs \<noteq> [] \<longrightarrow> last xs = \<sharp>"
+    using nss last_numlistlist_5 by auto
+  moreover have "\<not> has2 xs \<zero> \<bar>" and "\<not> has2 xs \<zero> \<sharp>" and "\<not> has2 xs \<one> \<sharp>"
+    using numlistlist_not_has2 numlistlist_not_has2' has2_def nss by auto
+  ultimately show ?thesis
+    by simp
+qed
+
+lemma numlistlist_wf_iff:
+  "numlistlist_wf xs \<longleftrightarrow>
+   proper_symbols_lt 6 xs \<and> (xs \<noteq> [] \<longrightarrow> last xs = \<sharp>) \<and> \<not> has2 xs \<zero> \<bar> \<and> \<not> has2 xs \<zero> \<sharp> \<and> \<not> has2 xs \<one> \<sharp>"
+  using numlistlist_wf_has2 numlistlist_wf_has2' by blast
+
+
+subsection \<open>A Turing machine to check for subsequences of length two\<close>
+
+text \<open>
+In order to implement the well-formedness criteria we need to be able to check a
+symbol sequence for subsequences of length two. The next Turing machine has
+symbol parameters $y$ and $z$ and checks whether the sequence @{term "[y, z]"}
+exists on tape $j_1$. It writes to tape $j_2$ the number~0 or~1 if the sequence
+is present or not, respectively.
+\<close>
+
+definition tm_not_has2 :: "symbol \<Rightarrow> symbol \<Rightarrow> tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_not_has2 y z j1 j2 \<equiv>
+    tm_set j2 [\<zero>, \<zero>] ;;
+    WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO
+      IF \<lambda>rs. rs ! j2 = \<one> \<and> rs ! j1 = z THEN
+        tm_right j2 ;;
+        tm_write j2 \<one> ;;
+        tm_left j2
+      ELSE
+        []
+      ENDIF ;;
+      tm_trans2 j1 j2 (\<lambda>h. if h = y then \<one> else \<zero>) ;;
+      tm_right j1
+    DONE ;;
+    tm_right j2 ;;
+    IF \<lambda>rs. rs ! j2 = \<one> THEN
+      tm_set j2 (canrepr 1)
+    ELSE
+      tm_set j2 (canrepr 0)
+    ENDIF ;;
+    tm_cr j1 ;;
+    tm_not j2"
+
+lemma tm_not_has2_tm:
+  assumes "k \<ge> 2" and "G \<ge> 4" and "0 < j2" and "j1 < k" and "j2 < k"
+  shows "turing_machine k G (tm_not_has2 y z j1 j2)"
+proof -
+  have "symbols_lt G [\<zero>, \<zero>]"
+    using assms(2) by (simp add: nth_Cons')
+  moreover have "symbols_lt G (canrepr 0)"
+    using assms(2) by simp
+  moreover have "symbols_lt G (canrepr 1)"
+    using assms(2) canrepr_1 by simp
+  ultimately show ?thesis
+  unfolding tm_not_has2_def
+  using assms tm_right_tm tm_write_tm tm_left_tm tm_cr_tm Nil_tm tm_trans2_tm tm_set_tm
+    turing_machine_loop_turing_machine turing_machine_branch_turing_machine tm_not_tm
+  by simp
+qed
+
+locale turing_machine_has2 =
+  fixes y z :: symbol and j1 j2 :: tapeidx
+begin
+
+context
+  fixes tps0 :: "tape list" and xs :: "symbol list" and k :: nat
+  assumes xs: "proper_symbols xs"
+  assumes yz: "y > 1" "z > 1"
+  assumes jk: "j1 < k" "j2 < k" "j1 \<noteq> j2" "0 < j2" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    "tps0 ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tm1 \<equiv> tm_set j2 [\<zero>, \<zero>]"
+
+definition "tmT1 \<equiv> tm_right j2"
+definition "tmT2 \<equiv> tmT1 ;; tm_write j2 \<one>"
+definition "tmT3 \<equiv> tmT2 ;; tm_left j2"
+
+definition "tmL1 \<equiv> IF \<lambda>rs. rs ! j2 = \<one> \<and> rs ! j1 = z THEN tmT3 ELSE [] ENDIF"
+definition "tmL2 \<equiv> tmL1 ;; tm_trans2 j1 j2 (\<lambda>h. if h = y then \<one> else \<zero>)"
+definition "tmL3 \<equiv> tmL2 ;; tm_right j1"
+definition "tmL \<equiv> WHILE [] ; \<lambda>rs. rs ! j1 \<noteq> \<box> DO tmL3 DONE"
+
+definition "tm2 \<equiv> tm1 ;; tmL"
+definition "tm3 \<equiv> tm2 ;; tm_right j2"
+definition "tm34 \<equiv> IF \<lambda>rs. rs ! j2 = \<one> THEN tm_set j2 (canrepr 1) ELSE tm_set j2 (canrepr 0) ENDIF"
+definition "tm4 \<equiv> tm3 ;; tm34"
+definition "tm5 \<equiv> tm4 ;; tm_cr j1"
+definition "tm6 \<equiv> tm5 ;; tm_not j2"
+
+lemma tm6_eq_tm_not_has2: "tm6 = tm_not_has2 y z j1 j2"
+  unfolding tm6_def tm5_def tm4_def tm34_def tm3_def tm2_def tmL_def tmL3_def tmL2_def tmL1_def
+    tmT3_def tmT2_def tmT1_def tm1_def tm_not_has2_def
+  by simp
+
+definition tps1 :: "tape list" where
+  "tps1 \<equiv> tps0
+    [j1 := (\<lfloor>xs\<rfloor>, 1),
+     j2 := (\<lfloor>[\<zero>, \<zero>]\<rfloor>, 1)]"
+
+lemma tm1: "transforms tm1 tps0 14 tps1"
+  unfolding tm1_def
+proof (tform tps: tps0 tps1_def jk)
+  show "\<forall>i<length [\<zero>, \<zero>]. Suc 0 < [\<zero>, \<zero>] ! i"
+    by (simp add: nth_Cons')
+  show "tps1 = tps0[j2 := (\<lfloor>[\<zero>, \<zero>]\<rfloor>, 1)]"
+    using tps1_def tps0 jk by (metis list_update_id)
+qed
+
+abbreviation has_at :: "nat \<Rightarrow> bool" where
+  "has_at i \<equiv> xs ! i = y \<and> xs ! Suc i = z"
+
+definition tpsL :: "nat \<Rightarrow> tape list" where
+  "tpsL t \<equiv> tps0
+    [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+     j2 := (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, if \<exists>i<t - 1. has_at i then \<one> else \<zero>]\<rfloor>, 1)]"
+
+lemma tpsL_eq_tps1: "tpsL 0 = tps1"
+  unfolding tps1_def tpsL_def using yz jk by simp
+
+lemma tm1' [transforms_intros]: "transforms tm1 tps0 14 (tpsL 0)"
+  using tm1 tpsL_eq_tps1 by simp
+
+definition tpsT1 :: "nat \<Rightarrow> tape list" where
+  "tpsT1 t \<equiv> tps0
+    [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+     j2 := (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, if \<exists>i<t - 1. has_at i then \<one> else \<zero>]\<rfloor>, 2)]"
+
+definition tpsT2 :: "nat \<Rightarrow> tape list" where
+  "tpsT2 t \<equiv> tps0
+    [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+     j2 := (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, if \<exists>i<t. has_at i then \<one> else \<zero>]\<rfloor>, 2)]"
+
+definition tpsT3 :: "nat \<Rightarrow> tape list" where
+  "tpsT3 t \<equiv> tps0
+    [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+     j2 := (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, if \<exists>i<t. has_at i then \<one> else \<zero>]\<rfloor>, 1)]"
+
+lemma contents_1_update: "(\<lfloor>[a, b]\<rfloor>, 1) |:=| v = (\<lfloor>[v, b]\<rfloor>, 1)" for a b v :: symbol
+  using contents_def by auto
+
+lemma contents_2_update: "(\<lfloor>[a, b]\<rfloor>, 2) |:=| v = (\<lfloor>[a, v]\<rfloor>, 2)" for a b v :: symbol
+  using contents_def by auto
+
+context
+  fixes t :: nat
+  assumes then_branch: "\<lfloor>xs\<rfloor> t = y" "xs ! t = z"
+begin
+
+lemma tmT1 [transforms_intros]: "transforms tmT1 (tpsL t) 1 (tpsT1 t)"
+  unfolding tmT1_def
+proof (tform tps: tpsL_def tpsT1_def jk)
+  have "tpsL t ! j2 |+| 1 = (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, if \<exists>i<t - 1. has_at i then \<one> else \<zero>]\<rfloor>, 2)"
+    using jk tpsL_def by simp
+  moreover have "tpsT1 t = (tpsL t)[j2 := (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, if \<exists>i<t - 1. has_at i then \<one> else \<zero>]\<rfloor>, 2)]"
+    unfolding tpsT1_def tpsL_def by simp
+  ultimately show "tpsT1 t = (tpsL t)[j2 := tpsL t ! j2 |+| 1]"
+    by presburger
+qed
+
+lemma tmT2 [transforms_intros]: "transforms tmT2 (tpsL t) 2 (tpsT2 t)"
+  unfolding tmT2_def
+proof (tform tps: tpsT1_def tpsT2_def jk)
+  have 1: "tpsT1 t ! j2 = (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, if \<exists>i<t - 1. has_at i then \<one> else \<zero>]\<rfloor>, 2)"
+    using tpsT1_def jk by simp
+  have 2: "tpsT1 t ! j2 |:=| \<one> = (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, \<one>]\<rfloor>, 2)"
+    using tpsT1_def jk contents_2_update by simp
+  have 3: "tpsT2 t ! j2 = (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, if \<exists>i<t. has_at i then \<one> else \<zero>]\<rfloor>, 2)"
+    using tpsT2_def jk by simp
+
+  have "\<exists>i<t. has_at i"
+  proof -
+    have "t > 0"
+      using then_branch(1) yz(1) by (metis contents_at_0 gr0I less_numeral_extra(4))
+    then have "y = xs ! (t - 1)"
+      using then_branch(1) by (metis contents_def nat_neq_iff not_one_less_zero yz(1))
+    moreover have "z = xs ! t"
+      using then_branch(2) by simp
+    ultimately have "has_at (t - 1)"
+      using `0 < t` by simp
+    then show "\<exists>i<t. has_at i"
+      using `0 < t` by (metis Suc_pred' lessI)
+  qed
+  then have "(if \<exists>i<t. has_at i then \<one> else \<zero>) = \<one>"
+    by simp
+  then have "tpsT1 t ! j2 |:=| \<one> = (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, if \<exists>i<t. has_at i then \<one> else \<zero>]\<rfloor>, 2)"
+    using 2 3 by (smt (verit, ccfv_threshold))
+  then show "tpsT2 t = (tpsT1 t)[j2 := tpsT1 t ! j2 |:=| \<one>]"
+    unfolding tpsT2_def tpsT1_def using jk by simp
+qed
+
+lemma tmT3 [transforms_intros]: "transforms tmT3 (tpsL t) 3 (tpsT3 t)"
+  unfolding tmT3_def by (tform tps: tpsT2_def tpsT3_def jk)
+
+end
+
+lemma tmL1 [transforms_intros]:
+  assumes "ttt = 5" and "t < length xs"
+  shows "transforms tmL1 (tpsL t) ttt (tpsT3 t)"
+  unfolding tmL1_def
+proof (tform tps: assms(1) tpsL_def tpsT3_def jk)
+  have "read (tpsL t) ! j1 = tpsL t :.: j1"
+    using jk tpsL_def tapes_at_read'[of j1 "tpsL t"] by simp
+  then have 1: "read (tpsL t) ! j1 = xs ! t"
+    using jk tpsL_def assms(2) by simp
+  then show "read (tpsL t) ! j2 = \<one> \<and> read (tpsL t) ! j1 = z \<Longrightarrow> xs ! t = z"
+    by simp
+  have "read (tpsL t) ! j2 = tpsL t :.: j2"
+    using jk tpsL_def tapes_at_read'[of j2 "tpsL t"] by simp
+  then have 2: "read (tpsL t) ! j2 = (if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>)"
+    using jk tpsL_def by simp
+  then show "read (tpsL t) ! j2 = \<one> \<and> read (tpsL t) ! j1 = z \<Longrightarrow> \<lfloor>xs\<rfloor> t = y"
+    by presburger
+  show "tpsT3 t = tpsL t" if "\<not> (read (tpsL t) ! j2 = \<one> \<and> read (tpsL t) ! j1 = z)"
+  proof -
+    have "(\<exists>i<t. has_at i) = (\<exists>i<t - 1. has_at i)"
+    proof (cases "t = 0")
+      case True
+      then show ?thesis
+        by simp
+    next
+      case False
+      have "\<not> ((if \<lfloor>xs\<rfloor> t = y then 0::symbol else 1) = 0 \<and> xs ! t = z)"
+        using 1 2 that by simp
+      then have "\<not> (\<lfloor>xs\<rfloor> t = y \<and> xs ! t = z)"
+        by auto
+      then have "\<not> (has_at (t - 1))"
+        using False Suc_pred' assms(2) contents_inbounds less_imp_le_nat by simp
+      moreover have "(\<exists>i<t. has_at i) = (\<exists>i<t - Suc 0. has_at i) \<or> has_at (t - 1)"
+        using False by (metis One_nat_def add_diff_inverse_nat less_Suc_eq less_one plus_1_eq_Suc)
+      ultimately show ?thesis
+        by auto
+    qed
+    then have eq: "(if \<exists>i<t - 1. has_at i then \<one> else \<zero>) = (if \<exists>i<t. has_at i then \<one> else \<zero>)"
+      by simp
+    show ?thesis
+      unfolding tpsT3_def tpsL_def by (simp only: eq)
+  qed
+qed
+
+definition tpsL2 :: "nat \<Rightarrow> tape list" where
+  "tpsL2 t \<equiv> tps0
+    [j1 := (\<lfloor>xs\<rfloor>, Suc t),
+     j2 := (\<lfloor>[if \<lfloor>xs\<rfloor> (Suc t) = y then \<one> else \<zero>, if \<exists>i<t. has_at i then \<one> else \<zero>]\<rfloor>, 1)]"
+
+lemma tmL2 [transforms_intros]:
+  assumes "ttt = 6" and "t < length xs"
+  shows "transforms tmL2 (tpsL t) ttt (tpsL2 t)"
+  unfolding tmL2_def
+proof (tform tps: assms tpsL_def tpsT3_def jk)
+  have "tpsT3 t ! j2 = (\<lfloor>[if \<lfloor>xs\<rfloor> t = y then \<one> else \<zero>, if \<exists>i<t. has_at i then \<one> else \<zero>]\<rfloor>, 1)"
+    using jk tpsT3_def by simp
+  then have "tpsT3 t ! j2 |:=| (if tpsT3 t :.: j1 = y then \<one> else \<zero>) =
+      (\<lfloor>[if tpsT3 t :.: j1 = y then \<one> else \<zero>, if \<exists>i<t. has_at i then \<one> else \<zero>]\<rfloor>, 1)"
+    using contents_1_update by simp
+  moreover have "tpsT3 t :.: j1 = \<lfloor>xs\<rfloor> (Suc t)"
+    using assms(2) tpsT3_def jk by simp
+  ultimately have "tpsT3 t ! j2 |:=| (if tpsT3 t :.: j1 = y then \<one> else \<zero>) =
+      (\<lfloor>[if \<lfloor>xs\<rfloor> (Suc t) = y then \<one> else \<zero>, if \<exists>i<t. has_at i then \<one> else \<zero>]\<rfloor>, 1)"
+    by auto
+  moreover have "tpsL2 t = (tpsT3 t)[j2 := (\<lfloor>[if \<lfloor>xs\<rfloor> (Suc t) = y then \<one> else \<zero>, if \<exists>i<t. has_at i then \<one> else \<zero>]\<rfloor>, 1)]"
+    using tpsL2_def tpsT3_def by simp
+  ultimately show "tpsL2 t = (tpsT3 t)[j2 := tpsT3 t ! j2 |:=| (if tpsT3 t :.: j1 = y then \<one> else \<zero>)]"
+    by presburger
+qed
+
+lemma tmL3 [transforms_intros]:
+  assumes "ttt = 7" and "t < length xs"
+  shows "transforms tmL3 (tpsL t) ttt (tpsL (Suc t))"
+  unfolding tmL3_def
+proof (tform tps: assms tpsL_def tpsL2_def jk)
+  have "tpsL2 t ! j1 = (\<lfloor>xs\<rfloor>, Suc t)"
+    using tpsL2_def jk by simp
+  then show "tpsL (Suc t) = (tpsL2 t)[j1 := tpsL2 t ! j1 |+| 1]"
+    using tpsL2_def tpsL_def jk by (simp add: list_update_swap)
+qed
+
+lemma tmL [transforms_intros]:
+  assumes "ttt = 9 * length xs + 1"
+  shows "transforms tmL (tpsL 0) ttt (tpsL (length xs))"
+  unfolding tmL_def
+proof (tform time: assms)
+  have "read (tpsL t) ! j1 = tpsL t :.: j1" for t
+    using tpsL_def tapes_at_read' jk
+    by (metis (no_types, lifting) length_list_update)
+  then have "read (tpsL t) ! j1 = \<lfloor>xs\<rfloor> (Suc t)" for t
+    using tpsL_def jk by simp
+  then show "\<And>t. t < length xs \<Longrightarrow> read (tpsL t) ! j1 \<noteq> \<box>" and "\<not> read (tpsL (length xs)) ! j1 \<noteq> \<box>"
+    using xs by auto
+qed
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 9 * length xs + 15"
+  shows "transforms tm2 tps0 ttt (tpsL (length xs))"
+  unfolding tm2_def by (tform tps: assms tpsL_def jk)
+
+definition tps3 :: "tape list" where
+  "tps3 \<equiv> tps0
+    [j1 := (\<lfloor>xs\<rfloor>, Suc (length xs)),
+     j2 := (\<lfloor>[if \<lfloor>xs\<rfloor> (length xs) = y then \<one> else \<zero>, if \<exists>i<length xs - 1. has_at i then \<one> else \<zero>]\<rfloor>, 2)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 9 * length xs + 16"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def
+proof (tform tps: assms tpsL_def jk)
+  show "tps3 = (tpsL (length xs))[j2 := tpsL (length xs) ! j2 |+| 1]"
+    unfolding tps3_def tpsL_def
+    using jk
+    by (metis (no_types, lifting) One_nat_def Suc_1 add.right_neutral add_Suc_right fst_conv length_list_update
+      list_update_overwrite nth_list_update_eq snd_conv)
+qed
+
+definition tps4 :: "tape list" where
+  "tps4 \<equiv> tps0
+    [j1 := (\<lfloor>xs\<rfloor>, Suc (length xs)),
+     j2 := (\<lfloor>\<exists>i<length xs - Suc 0. has_at i\<rfloor>\<^sub>B, 1)]"
+
+lemma tm34 [transforms_intros]:
+  assumes "ttt = 19"
+  shows "transforms tm34 tps3 ttt tps4"
+  unfolding tm34_def
+proof (tform tps: assms tps4_def tps3_def jk)
+  let ?pair = "[if \<lfloor>xs\<rfloor> (length xs) = y then \<one> else \<zero>, if \<exists>i<length xs - Suc 0. has_at i then \<one> else \<zero>]"
+  show 1: "proper_symbols ?pair" and "proper_symbols ?pair"
+    by (simp_all add: nth_Cons')
+  show "proper_symbols (canrepr 1)"
+    using proper_symbols_canrepr by simp
+
+  have "read tps3 ! j2 = (if \<exists>i<length xs - Suc 0. has_at i then \<one> else \<zero>)"
+    using jk tps3_def tapes_at_read'[of j2 tps3] by simp
+  then have *: "read tps3 ! j2 = \<one> \<longleftrightarrow> (\<exists>i<length xs - Suc 0. has_at i)"
+    by simp
+
+  show "clean_tape (tps3 ! j2)" "clean_tape (tps3 ! j2)"
+    using jk tps3_def clean_contents_proper[OF 1] by simp_all
+  show "tps4 = tps3[j2 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]" if "read tps3 ! j2 = \<one>"
+  proof -
+    have "\<exists>i<length xs - Suc 0. has_at i"
+      using that * by simp
+    then have "(\<lfloor>\<exists>i<length xs - Suc 0. has_at i\<rfloor>\<^sub>B, 1) = (\<lfloor>1\<rfloor>\<^sub>N, 1)"
+      by simp
+    then have "tps4 = tps0
+        [j1 := (\<lfloor>xs\<rfloor>, Suc (length xs)),
+         j2 := (\<lfloor>1\<rfloor>\<^sub>N, 1)]"
+      using tps4_def by simp
+    then show ?thesis
+      using tps3_def by simp
+  qed
+  show "tps4 = tps3[j2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]" if "read tps3 ! j2 \<noteq> \<one>"
+  proof -
+    have "\<not> (\<exists>i<length xs - Suc 0. has_at i)"
+      using that * by simp
+    then have "(\<lfloor>\<exists>i<length xs - Suc 0. has_at i\<rfloor>\<^sub>B, 1) = (\<lfloor>0\<rfloor>\<^sub>N, 1)"
+      by auto
+    then have "tps4 = tps0
+        [j1 := (\<lfloor>xs\<rfloor>, Suc (length xs)),
+         j2 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+      using tps4_def by simp
+    then show ?thesis
+      using tps3_def by simp
+  qed
+
+  have "tps3 :#: j2 = 2"
+    using jk tps3_def by simp
+  then show "8 + tps3 :#: j2 + 2 * length ?pair + Suc (2 * nlength 1) + 2 \<le> ttt"
+    and "8 + tps3 :#: j2 + 2 * length ?pair + Suc (2 * nlength 0) + 1 \<le> ttt"
+    using assms nlength_1_simp by simp_all
+qed
+
+lemma tm4:
+  assumes "ttt = 9 * length xs + 35"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def by (tform tps: assms)
+
+definition tps4' :: "tape list" where
+  "tps4' \<equiv> tps0
+    [j1 := (\<lfloor>xs\<rfloor>, Suc (length xs)),
+     j2 := (\<lfloor>has2 xs y z\<rfloor>\<^sub>B, 1)]"
+
+lemma tps4': "tps4 = tps4'"
+  using has2_def tps4_def tps4'_def by simp
+
+lemma tm4' [transforms_intros]:
+  assumes "ttt = 9 * length xs + 35"
+  shows "transforms tm4 tps0 ttt tps4'"
+  using assms tm4 tps4' by simp
+
+definition tps5 :: "tape list" where
+  "tps5 \<equiv> tps0
+    [j1 := (\<lfloor>xs\<rfloor>, 1),
+     j2 := (\<lfloor>has2 xs y z \<rfloor>\<^sub>B, 1)]"
+
+lemma tm5:
+  assumes "ttt = 10 * length xs + 38"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def
+proof (tform tps: assms tps4'_def jk)
+  show "clean_tape (tps4' ! j1)"
+    using tps4'_def jk xs by simp
+  have "tps4' ! j1 |#=| 1 = (\<lfloor>xs\<rfloor>, 1)"
+    using tps4'_def jk by simp
+  then show "tps5 = tps4'[j1 := tps4' ! j1 |#=| 1]"
+    using tps5_def tps4'_def jk by (simp add: list_update_swap)
+qed
+
+definition tps5' :: "tape list" where
+  "tps5' \<equiv> tps0
+    [j2 := (\<lfloor>has2 xs y z\<rfloor>\<^sub>B, 1)]"
+
+lemma tm5' [transforms_intros]:
+  assumes "ttt = 10 * length xs + 38"
+  shows "transforms tm5 tps0 ttt tps5'"
+proof -
+  have "tps5 = tps5'"
+    using tps5_def tps5'_def jk tps0(1) by (metis list_update_id)
+  then show ?thesis
+    using assms tm5 by simp
+qed
+
+definition tps6 :: "tape list" where
+  "tps6 \<equiv> tps0
+    [j2 := (\<lfloor>\<not> has2 xs y z\<rfloor>\<^sub>B, 1)]"
+
+lemma tm6:
+  assumes "ttt = 10 * length xs + 41"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def
+proof (tform tps: assms tps5'_def jk)
+  have "tps5'[j2 := (\<lfloor>(if has2 xs y z then 1::nat else 0) \<noteq> 1\<rfloor>\<^sub>B, 1)] =
+      tps5'[j2 := (\<lfloor>\<not> has2 xs y z\<rfloor>\<^sub>B, 1)]"
+    by simp
+  also have "... = tps0[j2 := (\<lfloor>\<not> has2 xs y z\<rfloor>\<^sub>B, 1)]"
+    using tps5'_def by simp
+  also have "... = tps6"
+    using tps6_def by simp
+  finally show "tps6 = tps5'
+      [j2 := (\<lfloor>(if has2 xs y z then 1::nat else 0) \<noteq> 1\<rfloor>\<^sub>B, 1)]"
+    by simp
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_not_has2I [transforms_intros]:
+  fixes y z :: symbol and j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and xs :: "symbol list" and ttt k :: nat
+  assumes "j1 < k" "j2 < k" "j1 \<noteq> j2" "0 < j2" "length tps = k" "y > 1" "z > 1"
+    and "proper_symbols xs"
+  assumes
+    "tps ! j1 = (\<lfloor>xs\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 10 * length xs + 41"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>\<not> has2 xs y z\<rfloor>\<^sub>B, 1)]"
+  shows "transforms (tm_not_has2 y z j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_has2 y z j1 j2 .
+  show ?thesis
+    using loc.tps6_def loc.tm6 loc.tm6_eq_tm_not_has2 assms by metis
+qed
+
+
+subsection \<open>Checking well-formedness for lists\<close>
+
+text \<open>
+The next Turing machine checks all conditions from the criterion in lemma @{thm
+[source] numlist_wf_iff} one after another for the symbols on tape $j_1$ and
+writes to tape $j_2$ either the number~1 or~0 depending on whether all
+conditions were met. It assumes tape $j_2$ is initialized with~0.
+\<close>
+
+definition tm_numlist_wf :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_numlist_wf j1 j2 \<equiv>
+     tm_proper_symbols_lt j1 j2 5 ;;
+     tm_not_has2 \<zero> \<bar> j1 (j2 + 1) ;;
+     tm_and j2 (j2 + 1) ;;
+     tm_setn (j2 + 1) 0 ;;
+     tm_empty_or_endswith j1 (j2 + 1) \<bar> ;;
+     tm_and j2 (j2 + 1) ;;
+     tm_setn (j2 + 1) 0"
+
+lemma tm_numlist_wf_tm:
+  assumes "k \<ge> 2" and "G \<ge> 5" and "0 < j2" "0 < j1" and "j1 < k" "j2 + 1 < k"
+  shows "turing_machine k G (tm_numlist_wf j1 j2)"
+  using tm_numlist_wf_def tm_proper_symbols_lt_tm tm_not_has2_tm tm_and_tm tm_setn_tm tm_empty_or_endswith_tm assms
+  by simp
+
+locale turing_machine_numlist_wf =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_proper_symbols_lt j1 j2 5"
+definition "tm2 \<equiv> tm1 ;; tm_not_has2 \<zero> \<bar> j1 (j2 + 1)"
+definition "tm3 \<equiv> tm2 ;; tm_and j2 (j2 + 1)"
+definition "tm4 \<equiv> tm3 ;; tm_setn (j2 + 1) 0"
+definition "tm5 \<equiv> tm4 ;; tm_empty_or_endswith j1 (j2 + 1) \<bar>"
+definition "tm6 \<equiv> tm5 ;; tm_and j2 (j2 + 1)"
+definition "tm7 \<equiv> tm6 ;; tm_setn (j2 + 1) 0"
+
+lemma tm7_eq_tm_numlist_wf: "tm7 = tm_numlist_wf j1 j2"
+  unfolding tm7_def tm6_def tm5_def tm4_def tm3_def tm2_def tm1_def tm_numlist_wf_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and zs :: "symbol list" and k :: nat
+  assumes zs: "proper_symbols zs"
+  assumes jk: "0 < j1" "j1 < k" "j2 + 1 < k" "j1 \<noteq> j2" "0 < j2" "j1 \<noteq> j2 + 1" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps0 ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j2 + 1) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 5 zs\<rfloor>\<^sub>B, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 5 + 7 * length zs"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def
+  by (tform tps: zs tps0 assms tps1_def jk)
+
+definition "tps2 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 5 zs\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>if has2 zs \<zero> \<bar> then 0 else 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 46 + 17 * length zs"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def
+  by (tform tps: zs tps0 assms tps1_def tps2_def jk)
+
+definition "tps3 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 5 zs \<and> \<not> has2 zs \<zero> \<bar>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>if has2 zs \<zero> \<bar> then 0 else 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 46 + 17 * length zs + 3"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def by (tform tps: assms tps2_def tps3_def jk)
+
+definition "tps4 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 5 zs \<and> \<not> has2 zs \<zero> \<bar>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4:
+  assumes "ttt = 46 + 17 * length zs + 13 + 2 * nlength (if has2 zs \<zero> \<bar> then 0 else 1)"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def by (tform tps: assms tps3_def tps4_def jk)
+
+lemma tm4' [transforms_intros]:
+  assumes "ttt = 46 + 17 * length zs + 15"
+  shows "transforms tm4 tps0 ttt tps4"
+  using assms nlength_0 nlength_1_simp tm4 transforms_monotone by simp
+
+definition "tps5 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 5 zs \<and> \<not> has2 zs \<zero> \<bar>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>zs = [] \<or> last zs = \<bar>\<rfloor>\<^sub>B, 1)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 79 + 19 * length zs"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def by (tform tps: tps4_def tps5_def jk zs tps0 assms)
+
+definition "tps6 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 5 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<bar>)\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>zs = [] \<or> last zs = \<bar>\<rfloor>\<^sub>B, 1)]"
+
+lemma tm6 [transforms_intros]:
+  assumes "ttt = 82 + 19 * length zs"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def by (tform tps: tps5_def tps6_def jk time: assms)
+
+definition "tps7 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 5 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<bar>)\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm7:
+  assumes "ttt = 92 + 19 * length zs + 2 * nlength (if zs = [] \<or> last zs = \<bar> then 1 else 0)"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def by (tform tps: assms tps6_def tps7_def jk)
+
+definition "tps7' \<equiv> tps0
+  [j2 := (\<lfloor>numlist_wf zs\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm7':
+  assumes "ttt = 94 + 19 * length zs"
+  shows "transforms tm7 tps0 ttt tps7'"
+proof -
+  have "ttt \<ge> 92 + 19 * length zs + 2 * nlength (if zs = [] \<or> last zs = \<bar> then 1 else 0)"
+    using assms nlength_1_simp by auto
+  moreover have "tps7' = tps7"
+    using tps7'_def tps7_def numlist_wf_iff by auto
+  ultimately show ?thesis
+   using transforms_monotone tm7 by simp
+qed
+
+definition "tps7'' \<equiv> tps0
+  [j2 := (\<lfloor>numlist_wf zs\<rfloor>\<^sub>B, 1)]"
+
+lemma tm7'' [transforms_intros]:
+  assumes "ttt = 94 + 19 * length zs"
+  shows "transforms tm7 tps0 ttt tps7''"
+proof -
+  have "tps7'' = tps7'"
+    unfolding tps7''_def tps7'_def using tps0 jk canrepr_0
+    by (metis add_gr_0 less_add_same_cancel1 list_update_id list_update_swap_less zero_less_two)
+  then show ?thesis
+    using tm7' assms by simp
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_numlist_wfI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and zs :: "symbol list" and ttt k :: nat
+  assumes "0 < j1" "j1 < k" "j2 + 1 < k" "j1 \<noteq> j2" "0 < j2" "j1 \<noteq> j2 + 1" "length tps = k"
+    and "proper_symbols zs"
+  assumes
+    "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j2 + 1) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 94 + 19 * length zs"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>numlist_wf zs\<rfloor>\<^sub>B, 1)]"
+  shows "transforms (tm_numlist_wf j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_numlist_wf j1 j2 .
+  show ?thesis
+    using assms loc.tps7''_def loc.tm7'' loc.tm7_eq_tm_numlist_wf by simp
+qed
+
+
+subsection \<open>Checking well-formedness for lists of lists\<close>
+
+text \<open>
+The next Turing machine checks all conditions from the criterion in lemma @{thm
+[source] numlistlist_wf_iff} one after another for the symbols on tape $j_1$ and
+writes to tape $j_2$ either the number~1 or~0 depending on whether all
+conditions were met. It assumes tape $j_2$ is initialized with~0.
+\<close>
+
+definition tm_numlistlist_wf :: "tapeidx \<Rightarrow> tapeidx \<Rightarrow> machine" where
+  "tm_numlistlist_wf j1 j2 \<equiv>
+     tm_proper_symbols_lt j1 j2 6 ;;
+     tm_not_has2 \<zero> \<bar> j1 (j2 + 1) ;;
+     tm_and j2 (j2 + 1) ;;
+     tm_setn (j2 + 1) 0 ;;
+     tm_empty_or_endswith j1 (j2 + 1) \<sharp> ;;
+     tm_and j2 (j2 + 1) ;;
+     tm_setn (j2 + 1) 0 ;;
+     tm_not_has2 \<zero> \<sharp> j1 (j2 + 1) ;;
+     tm_and j2 (j2 + 1) ;;
+     tm_setn (j2 + 1) 0 ;;
+     tm_not_has2 \<one> \<sharp> j1 (j2 + 1) ;;
+     tm_and j2 (j2 + 1) ;;
+     tm_setn (j2 + 1) 0"
+
+lemma tm_numlistlist_wf_tm:
+  assumes "k \<ge> 2" and "G \<ge> 6" and "0 < j2" "0 < j1" and "j1 < k" "j2 + 1 < k"
+  shows "turing_machine k G (tm_numlistlist_wf j1 j2)"
+  using tm_numlistlist_wf_def tm_proper_symbols_lt_tm tm_not_has2_tm tm_and_tm tm_setn_tm tm_empty_or_endswith_tm assms
+  by simp
+
+locale turing_machine_numlistlist_wf =
+  fixes j1 j2 :: tapeidx
+begin
+
+definition "tm1 \<equiv> tm_proper_symbols_lt j1 j2 6"
+definition "tm2 \<equiv> tm1 ;; tm_not_has2 \<zero> \<bar> j1 (j2 + 1)"
+definition "tm3 \<equiv> tm2 ;; tm_and j2 (j2 + 1)"
+definition "tm4 \<equiv> tm3 ;; tm_setn (j2 + 1) 0"
+definition "tm5 \<equiv> tm4 ;; tm_empty_or_endswith j1 (j2 + 1) \<sharp>"
+definition "tm6 \<equiv> tm5 ;; tm_and j2 (j2 + 1)"
+definition "tm7 \<equiv> tm6 ;; tm_setn (j2 + 1) 0"
+definition "tm8 \<equiv> tm7 ;; tm_not_has2 \<zero> \<sharp> j1 (j2 + 1)"
+definition "tm9 \<equiv> tm8 ;; tm_and j2 (j2 + 1)"
+definition "tm10 \<equiv> tm9 ;; tm_setn (j2 + 1) 0"
+definition "tm11 \<equiv> tm10 ;; tm_not_has2 \<one> \<sharp> j1 (j2 + 1)"
+definition "tm12 \<equiv> tm11 ;; tm_and j2 (j2 + 1)"
+definition "tm13 \<equiv> tm12 ;; tm_setn (j2 + 1) 0"
+
+lemma tm13_eq_tm_numlistlist_wf: "tm13 = tm_numlistlist_wf j1 j2"
+  unfolding tm13_def tm12_def tm11_def tm10_def tm9_def tm8_def tm7_def tm6_def tm5_def
+    tm4_def tm3_def tm2_def tm1_def tm_numlistlist_wf_def
+  by simp
+
+context
+  fixes tps0 :: "tape list" and zs :: "symbol list" and k :: nat
+  assumes zs: "proper_symbols zs"
+  assumes jk: "0 < j1" "j1 < k" "j2 + 1 < k" "j1 \<noteq> j2" "0 < j2" "j1 \<noteq> j2 + 1" "length tps0 = k"
+  assumes tps0:
+    "tps0 ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps0 ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+    "tps0 ! (j2 + 1) = (\<lfloor>[]\<rfloor>, 1)"
+begin
+
+definition "tps1 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs\<rfloor>\<^sub>B, 1)]"
+
+lemma tm1 [transforms_intros]:
+  assumes "ttt = 5 + 7 * length zs"
+  shows "transforms tm1 tps0 ttt tps1"
+  unfolding tm1_def by (tform tps: tps0 tps1_def zs jk time: assms)
+
+definition "tps2 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>if has2 zs \<zero> \<bar> then 0 else 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm2 [transforms_intros]:
+  assumes "ttt = 46 + 17 * length zs"
+  shows "transforms tm2 tps0 ttt tps2"
+  unfolding tm2_def by (tform tps: zs tps0 assms tps1_def tps2_def jk)
+
+definition "tps3 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>if has2 zs \<zero> \<bar> then 0 else 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm3 [transforms_intros]:
+  assumes "ttt = 46 + 17 * length zs + 3"
+  shows "transforms tm3 tps0 ttt tps3"
+  unfolding tm3_def by (tform tps: tps2_def tps3_def jk time: assms)
+
+definition "tps4 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm4:
+  assumes "ttt = 46 + 17 * length zs + 13 + 2 * nlength (if has2 zs \<zero> \<bar> then 0 else 1)"
+  shows "transforms tm4 tps0 ttt tps4"
+  unfolding tm4_def by (tform tps: tps3_def assms tps4_def jk)
+
+lemma tm4' [transforms_intros]:
+  assumes "ttt = 46 + 17 * length zs + 15"
+  shows "transforms tm4 tps0 ttt tps4"
+  using assms nlength_0 nlength_1_simp tm4 transforms_monotone by simp
+
+definition "tps5 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>zs = [] \<or> last zs = \<sharp>\<rfloor>\<^sub>B, 1)]"
+
+lemma tm5 [transforms_intros]:
+  assumes "ttt = 79 + 19 * length zs"
+  shows "transforms tm5 tps0 ttt tps5"
+  unfolding tm5_def by (tform tps: tps0 tps4_def tps5_def jk zs time: assms)
+
+definition "tps6 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<sharp>)\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>zs = [] \<or> last zs = \<sharp>\<rfloor>\<^sub>B, 1)]"
+
+lemma tm6 [transforms_intros]:
+  assumes "ttt = 82 + 19 * length zs"
+  shows "transforms tm6 tps0 ttt tps6"
+  unfolding tm6_def by (tform tps: tps5_def tps6_def jk time: assms)
+
+definition "tps7 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<sharp>)\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm7:
+  assumes "ttt = 92 + 19 * length zs + 2 * nlength (if zs = [] \<or> last zs = \<sharp> then 1 else 0)"
+  shows "transforms tm7 tps0 ttt tps7"
+  unfolding tm7_def by (tform tps: assms tps6_def tps7_def jk)
+
+lemma tm7' [transforms_intros]:
+  assumes "ttt = 94 + 19 * length zs"
+  shows "transforms tm7 tps0 ttt tps7"
+  using transforms_monotone tm7 nlength_1_simp assms by simp
+
+definition "tps8 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<sharp>)\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>if has2 zs \<zero> \<sharp> then 0 else 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm8 [transforms_intros]:
+  assumes "ttt = 135 + 29 * length zs"
+  shows "transforms tm8 tps0 ttt tps8"
+  unfolding tm8_def by (tform tps: canrepr_0 zs tps0 assms tps7_def tps8_def jk)
+
+definition "tps9 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<sharp>) \<and> \<not> has2 zs \<zero> \<sharp>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>if has2 zs \<zero> \<sharp> then 0 else 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm9 [transforms_intros]:
+  assumes "ttt = 138 + 29 * length zs"
+  shows "transforms tm9 tps0 ttt tps9"
+  unfolding tm9_def by (tform tps: tps8_def tps9_def jk time: assms)
+
+definition "tps10 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<sharp>) \<and> \<not> has2 zs \<zero> \<sharp>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm10:
+  assumes "ttt = 148 + 29 * length zs + 2 * nlength (if has2 zs \<zero> \<sharp> then 0 else 1)"
+  shows "transforms tm10 tps0 ttt tps10"
+  unfolding tm10_def by (tform tps: assms tps9_def tps10_def jk)
+
+lemma tm10' [transforms_intros]:
+  assumes "ttt = 150 + 29 * length zs"
+  shows "transforms tm10 tps0 ttt tps10"
+  using transforms_monotone tm10 nlength_1_simp assms by simp
+
+definition "tps11 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<sharp>) \<and> \<not> has2 zs \<zero> \<sharp>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>if has2 zs \<one> \<sharp> then 0 else 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm11 [transforms_intros]:
+  assumes "ttt = 191 + 39 * length zs"
+  shows "transforms tm11 tps0 ttt tps11"
+  unfolding tm11_def by (tform tps: canrepr_0 zs tps0 assms tps10_def tps11_def jk)
+
+definition "tps12 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<sharp>) \<and> \<not> has2 zs \<zero> \<sharp> \<and> \<not> has2 zs \<one> \<sharp>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>if has2 zs \<one> \<sharp> then 0 else 1\<rfloor>\<^sub>N, 1)]"
+
+lemma tm12 [transforms_intros]:
+  assumes "ttt = 194 + 39 * length zs"
+  shows "transforms tm12 tps0 ttt tps12"
+  unfolding tm12_def by (tform tps: assms tps11_def tps12_def jk)
+
+definition "tps13 \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<sharp>) \<and> \<not> has2 zs \<zero> \<sharp> \<and> \<not> has2 zs \<one> \<sharp>\<rfloor>\<^sub>B, 1),
+   j2 + 1 := (\<lfloor>0\<rfloor>\<^sub>N, 1)]"
+
+lemma tm13:
+  assumes "ttt = 204 + 39 * length zs + 2 * nlength (if has2 zs \<one> \<sharp> then 0 else 1)"
+  shows "transforms tm13 tps0 ttt tps13"
+  unfolding tm13_def by (tform tps: assms tps12_def tps13_def jk)
+
+lemma tm13':
+  assumes "ttt = 206 + 39 * length zs"
+  shows "transforms tm13 tps0 ttt tps13"
+  using transforms_monotone tm13 nlength_1_simp assms by simp
+
+definition "tps13' \<equiv> tps0
+  [j2 := (\<lfloor>proper_symbols_lt 6 zs \<and> \<not> has2 zs \<zero> \<bar> \<and> (zs = [] \<or> last zs = \<sharp>) \<and> \<not> has2 zs \<zero> \<sharp> \<and> \<not> has2 zs \<one> \<sharp>\<rfloor>\<^sub>B, 1)]"
+
+lemma tm13'':
+  assumes "ttt = 206 + 39 * length zs"
+  shows "transforms tm13 tps0 ttt tps13'"
+proof -
+  have "tps13' = tps13"
+    unfolding tps13'_def tps13_def
+    using tps0(3) jk canrepr_0 list_update_id[of tps0 "Suc j2"]
+    by (simp add: list_update_swap)
+  then show ?thesis
+    using tm13' assms by simp
+qed
+
+definition "tps13'' \<equiv> tps0
+  [j2 := (\<lfloor>numlistlist_wf zs\<rfloor>\<^sub>B, 1)]"
+
+lemma tm13''':
+  assumes "ttt = 206 + 39 * length zs"
+  shows "transforms tm13 tps0 ttt tps13''"
+proof -
+  have "tps13'' = tps13'"
+    using numlistlist_wf_iff tps13''_def tps13'_def by auto
+  then show ?thesis
+    using assms tm13'' numlistlist_wf_iff by simp
+qed
+
+end  (* context *)
+
+end  (* locale *)
+
+lemma transforms_tm_numlistlist_wfI [transforms_intros]:
+  fixes j1 j2 :: tapeidx
+  fixes tps tps' :: "tape list" and zs :: "symbol list" and ttt k :: nat
+  assumes "0 < j1" "j1 < k" "j2 + 1 < k" "j1 \<noteq> j2" "0 < j2" "j1 \<noteq> j2 + 1" "length tps = k"
+    and "proper_symbols zs"
+  assumes
+    "tps ! j1 = (\<lfloor>zs\<rfloor>, 1)"
+    "tps ! j2 = (\<lfloor>[]\<rfloor>, 1)"
+    "tps ! (j2 + 1) = (\<lfloor>[]\<rfloor>, 1)"
+  assumes "ttt = 206 + 39 * length zs"
+  assumes "tps' = tps
+    [j2 := (\<lfloor>numlistlist_wf zs\<rfloor>\<^sub>B, 1)]"
+  shows "transforms (tm_numlistlist_wf j1 j2) tps ttt tps'"
+proof -
+  interpret loc: turing_machine_numlistlist_wf j1 j2 .
+  show ?thesis
+    using assms loc.tps13''_def loc.tm13''' loc.tm13_eq_tm_numlistlist_wf by simp
+qed
+
+end
diff --git a/thys/Cook_Levin/document/root.bib b/thys/Cook_Levin/document/root.bib
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/document/root.bib
@@ -0,0 +1,131 @@
+@book{ccama,
+  author = {Sanjeev Arora and Boaz Barak},
+  isbn = {978-0-521-42426-4},
+  publisher = {Cambridge University Press},
+  title = {Computational Complexity: A Modern Approach},
+  url = {https://theory.cs.princeton.edu/complexity/book.pdf},
+  year = 2006
+}
+
+@article{Cook,
+    author={Stephen A. Cook},
+    title={The complexity of theorem-proving procedures},
+    journal={Proceedings of the third annual ACM symposium on Theory of computing},
+    year={1971}
+}
+
+@article{Levin,
+    author = {Levin, L. A.},
+    journal = {Problems of Information Transmission},
+    number = 3,
+    pages = {265--266},
+    title = {Universal sequential search problems},
+    volume = 9,
+    year = 1973
+}
+
+@inproceedings{Gher2021MechanisingCT,
+    title={Mechanising Complexity Theory: The {C}ook-{L}evin Theorem in {C}oq},
+    author={Lennard G{\"a}her and Fabian Kunze},
+    booktitle={ITP},
+    year={2021}
+}
+
+@inproceedings{Forster2017WeakCL,
+    title={Weak Call-by-Value Lambda Calculus as a Model of Computation in {C}oq},
+    author={Yannick Forster and Gert Smolka},
+    booktitle={ITP},
+    year={2017}
+}
+
+@inproceedings{Gamboa2004AMP,
+    title={A Mechanical Proof of the {C}ook-{L}evin Theorem},
+    author={Ruben Gamboa and John R. Cowles},
+    booktitle={TPHOLs},
+    year={2004}
+}
+
+@article{Universal_Turing_Machine-AFP,
+  author  = {Jian Xu and Xingyuan Zhang and Christian Urban and Sebastiaan J. C. Joosten},
+  title   = {Universal Turing Machine},
+  journal = {Archive of Formal Proofs},
+  month   = feb,
+  year    = 2019,
+  note    = {\url{http://isa-afp.org/entries/Universal_Turing_Machine.html},
+            Formal proof development},
+  ISSN    = {2150-914x},
+}
+
+@article{Multiset_Ordering_NPC-AFP,
+    author  = {René Thiemann and Lukas Schmidinger},
+    title   = {The Generalized Multiset Ordering is {NP}-Complete},
+    journal = {Archive of Formal Proofs},
+    month   = apr,
+    year    = 2022,
+    note    = {\url{https://isa-afp.org/entries/Multiset_Ordering_NPC.html},
+                Formal proof development},
+    ISSN    = {2150-914x},
+}
+
+@book{lv-aikc,
+  author = {Li, Ming and Vitányi, Paul M. B.},
+  title = {An Introduction to Kolmogorov Complexity and Its Applications},
+  edition = {4th},
+  publisher = {Springer},
+  series = {Texts in Computer Science},
+  year = 2019,
+  isbn = {978-3-030-11297-4}
+}
+
+@misc{cz-dtime,
+    author = "Scott Aaronson",
+    title = "Complexity Zoo",
+    url = "https://complexityzoo.net/Complexity_Zoo",
+    note = {\url{https://complexityzoo.net/Complexity_Zoo}}
+}
+
+@article{Multitape_To_Singletape_TM-AFP,
+  author  = {Christian Dalvit and René Thiemann},
+  title   = {A Verified Translation of Multitape Turing Machines into Singletape Turing Machines},
+  journal = {Archive of Formal Proofs},
+  month   = {November},
+  year    = {2022},
+  note    = {\url{https://isa-afp.org/entries/Multitape_To_Singletape_TM.html},
+            Formal proof development},
+  ISSN    = {2150-914x},
+}
+
+@book{sipser2006,
+  author={Michael Sipser},
+  title={Introduction to the Theory of Computation},
+  edition={2nd},
+  isbn={9780619217648},
+  year={2006},
+  publisher={Thomson Course Technology}
+}
+
+@misc{acl2,
+  author       = {Robert S. Boyer and J Strother Moore and Matt Kaufmann},
+  title        = {{ACL2}},
+  note         = {\url{https://www.cs.utexas.edu/users/moore/acl2/}}
+}
+
+@misc{coq,
+  author       = {The Coq Development Team},
+  title        = {The {C}oq Proof Assistant},
+  month        = jan,
+  year         = 2022,
+  publisher    = {Zenodo},
+  version      = {8.15},
+  doi          = {10.5281/zenodo.5846982},
+  url          = {https://doi.org/10.5281/zenodo.5846982}
+}
+
+@article{hs65,
+  title={On the Computational Complexity of Algorithms},
+  author={Juris Hartmanis and Richard Edwin Stearns},
+  journal={Transactions of the American Mathematical Society},
+  year={1965},
+  volume={117},
+  pages={285-306}
+}
\ No newline at end of file
diff --git a/thys/Cook_Levin/document/root.tex b/thys/Cook_Levin/document/root.tex
new file mode 100644
--- /dev/null
+++ b/thys/Cook_Levin/document/root.tex
@@ -0,0 +1,65 @@
+\documentclass[10pt,a4paper]{report}
+\usepackage{isabelle,isabellesym}
+
+\usepackage{geometry}
+\geometry{a4paper, portrait}
+\geometry{left=2.5cm, right=2.5cm, top=2.5cm, bottom=2.5cm}
+
+% further packages required for unusual symbols (see also
+% isabellesym.sty), use only when needed
+
+\usepackage{amssymb}  % for \mathbb
+\usepackage{amsmath}  % for \tag
+
+% this should be the last package used
+\usepackage{pdfsetup}
+
+% urls in roman style, theory text in math-similar italics
+\urlstyle{rm}
+\isabellestyle{it}
+
+% for uniform font size
+%\renewcommand{\isastyle}{\isastyleminor}
+
+\renewcommand{\phi}{\varphi}
+\renewcommand{\rho}{\varrho}
+\newcommand{\nat}{\mathbb{N}}
+\newcommand{\NP}{\mathcal{NP}}
+\newcommand{\SAT}{\texttt{SAT}}
+\newcommand{\bbOI}{\{\isasymbbbO,\isasymbbbI\}}
+\newcommand{\prev}{\mathit{prev}}
+\newcommand{\inputpos}{\mathit{inputpos}}
+
+\begin{document}
+
+\title{The Cook-Levin theorem}
+\author{Frank J. Balbach}
+\maketitle
+
+\begin{abstract}
+The Cook-Levin theorem states that deciding the satisfiability of Boolean
+formulas in conjunctive normal form is $\NP$-complete.  This entry
+formalizes a proof of this theorem based on the textbook \emph{Computational
+Complexity:\ A Modern Approach} by Arora and Barak.  It contains definitions
+of deterministic multi-tape Turing machines, the complexity classes
+$\mathcal{P}$ and $\NP$, polynomial-time many-one reduction, and the decision
+problem \SAT.  For the $\NP$-hardness of \SAT, the proof first shows that every
+polynomial-time computation can be performed by a two-tape oblivious Turing
+machine. An $\NP$ problem can then be reduced to \SAT{} by a polynomial-time
+Turing machine that encodes computations of the problem's oblivious two-tape
+verifier Turing machine as formulas in conjunctive normal form.
+\end{abstract}
+
+\tableofcontents
+
+% sane default for proof documents
+\parindent 0pt\parskip 0.5ex
+
+% generated text of all theories
+\input{session}
+
+% optional bibliography
+\bibliographystyle{plain}
+\bibliography{root}
+
+\end{document}
diff --git a/thys/ROOTS b/thys/ROOTS
--- a/thys/ROOTS
+++ b/thys/ROOTS
@@ -1,722 +1,723 @@
 ADS_Functor
 AI_Planning_Languages_Semantics
 AODV
 AVL-Trees
 AWN
 Abortable_Linearizable_Modules
 Abs_Int_ITP2012
 Abstract-Hoare-Logics
 Abstract-Rewriting
 Abstract_Completeness
 Abstract_Soundness
 Ackermanns_not_PR
 Actuarial_Mathematics
 Adaptive_State_Counting
 Affine_Arithmetic
 Aggregation_Algebras
 Akra_Bazzi
 Algebraic_Numbers
 Algebraic_VCs
 Allen_Calculus
 Amicable_Numbers
 Amortized_Complexity
 AnselmGod
 Applicative_Lifting
 Approximation_Algorithms
 Architectural_Design_Patterns
 Aristotles_Assertoric_Syllogistic
 Arith_Prog_Rel_Primes
 ArrowImpossibilityGS
 Attack_Trees
 Auto2_HOL
 Auto2_Imperative_HOL
 AutoFocus-Stream
 Automated_Stateful_Protocol_Verification
 Automatic_Refinement
 AxiomaticCategoryTheory
 Balog_Szemeredi_Gowers
 BDD
 BD_Security_Compositional
 BNF_CC
 BNF_Operations
 BTree
 Banach_Steinhaus
 Belief_Revision
 Bell_Numbers_Spivey
 BenOr_Kozen_Reif
 Berlekamp_Zassenhaus
 Bernoulli
 Bertrands_Postulate
 Bicategory
 BinarySearchTree
 Binding_Syntax_Theory
 Binomial-Heaps
 Binomial-Queues
 BirdKMP
 Birkhoff_Finite_Distributive_Lattices
 Blue_Eyes
 Bondy
 Boolean_Expression_Checkers
 Boolos_Curious_Inference
 Boolos_Curious_Inference_Automated
 Bounded_Deducibility_Security
 Buchi_Complementation
 Budan_Fourier
 Buffons_Needle
 Buildings
 BytecodeLogicJmlTypes
 C2KA_DistributedSystems
 CAVA_Automata
 CAVA_LTL_Modelchecker
 CCS
 CISC-Kernel
+Cook_Levin
 CRYSTALS-Kyber
 CRDT
 CSP_RefTK
 CYK
 CZH_Elementary_Categories
 CZH_Foundations
 CZH_Universal_Constructions
 CakeML
 CakeML_Codegen
 Call_Arity
 Card_Equiv_Relations
 Card_Multisets
 Card_Number_Partitions
 Card_Partitions
 Cartan_FP
 Case_Labeling
 Catalan_Numbers
 Category
 Category2
 Category3
 Cauchy
 Cayley_Hamilton
 Certification_Monads
 Chandy_Lamport
 CHERI-C_Memory_Model
 Chord_Segments
 Circus
 Clean
 Clique_and_Monotone_Circuits
 ClockSynchInst
 Closest_Pair_Points
 CoCon
 CoSMeDis
 CoSMed
 CofGroups
 Coinductive
 Coinductive_Languages
 Collections
 Combinable_Wands
 Combinatorial_Enumeration_Algorithms
 Combinatorics_Words
 Combinatorics_Words_Graph_Lemma
 Combinatorics_Words_Lyndon
 Commuting_Hermitian
 Comparison_Sort_Lower_Bound
 Compiling-Exceptions-Correctly
 Complete_Non_Orders
 Completeness
 Complex_Bounded_Operators
 Complex_Geometry
 Complx
 ComponentDependencies
 ConcurrentGC
 ConcurrentIMP
 Concurrent_Ref_Alg
 Concurrent_Revisions
 Conditional_Simplification
 Conditional_Transfer_Rule
 Consensus_Refined
 Constructive_Cryptography
 Constructive_Cryptography_CM
 Constructor_Funs
 Containers
 CoreC++
 Core_DOM
 Core_SC_DOM
 Correctness_Algebras
 Cotangent_PFD_Formula
 Count_Complex_Roots
 CryptHOL
 CryptoBasedCompositionalProperties
 Cubic_Quartic_Equations
 DFS_Framework
 DOM_Components
 DPT-SAT-Solver
 DataRefinementIBP
 Datatype_Order_Generator
 Decl_Sem_Fun_PL
 Decreasing-Diagrams
 Decreasing-Diagrams-II
 Dedekind_Real
 Deep_Learning
 Delta_System_Lemma
 Density_Compiler
 Dependent_SIFUM_Refinement
 Dependent_SIFUM_Type_Systems
 Depth-First-Search
 Derangements
 Deriving
 Descartes_Sign_Rule
 Design_Theory
 Dict_Construction
 Differential_Dynamic_Logic
 Differential_Game_Logic
 Digit_Expansions
 Dijkstra_Shortest_Path
 Diophantine_Eqns_Lin_Hom
 Dirichlet_L
 Dirichlet_Series
 DiscretePricing
 Discrete_Summation
 DiskPaxos
 Dominance_CHK
 DPRM_Theorem
 DynamicArchitectures
 Dynamic_Tables
 E_Transcendental
 Echelon_Form
 EdmondsKarp_Maxflow
 Efficient-Mergesort
 Elliptic_Curves_Group_Law
 Encodability_Process_Calculi
 Epistemic_Logic
 Equivalence_Relation_Enumeration
 Ergodic_Theory
 Error_Function
 Euler_MacLaurin
 Euler_Partition
 Eval_FO
 Example-Submission
 Extended_Finite_State_Machine_Inference
 Extended_Finite_State_Machines
 FFT
 FLP
 FOL-Fitting
 FOL_Axiomatic
 FOL_Harrison
 FOL_Seq_Calc1
 FOL_Seq_Calc2
 FOL_Seq_Calc3
 FSM_Tests
 Factor_Algebraic_Polynomial
 Factored_Transition_System_Bounding
 Falling_Factorial_Sum
 Farkas
 FeatherweightJava
 Featherweight_OCL
 Fermat3_4
 FileRefinement
 FinFun
 Finger-Trees
 Finite-Map-Extras
 Finite_Automata_HF
 Finite_Fields
 Finitely_Generated_Abelian_Groups
 First_Order_Terms
 First_Welfare_Theorem
 Fishburn_Impossibility
 Fisher_Yates
 Fishers_Inequality
 Flow_Networks
 Floyd_Warshall
 Flyspeck-Tame
 FocusStreamsCaseStudies
 Forcing
 Formal_Puiseux_Series
 Formal_SSA
 Formula_Derivatives
 Foundation_of_geometry
 Fourier
 FO_Theory_Rewriting
 Free-Boolean-Algebra
 Free-Groups
 Frequency_Moments
 Fresh_Identifiers
 FunWithFunctions
 FunWithTilings
 Functional-Automata
 Functional_Ordered_Resolution_Prover
 Furstenberg_Topology
 GPU_Kernel_PL
 Gabow_SCC
 GaleStewart_Games
 Gale_Shapley
 Game_Based_Crypto
 Gauss-Jordan-Elim-Fun
 Gauss_Jordan
 Gauss_Sums
 Gaussian_Integers
 GenClock
 General-Triangle
 Generalized_Counting_Sort
 Generic_Deriving
 Generic_Join
 GewirthPGCProof
 Girth_Chromatic
 GoedelGod
 Goedel_HFSet_Semantic
 Goedel_HFSet_Semanticless
 Goedel_Incompleteness
 Goodstein_Lambda
 GraphMarkingIBP
 Graph_Saturation
 Graph_Theory
 Green
 Groebner_Bases
 Groebner_Macaulay
 Gromov_Hyperbolicity
 Grothendieck_Schemes
 Group-Ring-Module
 HOL-CSP
 HOLCF-Prelude
 HRB-Slicing
 Hahn_Jordan_Decomposition
 Hales_Jewett
 Heard_Of
 Hello_World
 HereditarilyFinite
 Hermite
 Hermite_Lindemann
 Hidden_Markov_Models
 Higher_Order_Terms
 Hoare_Time
 Hood_Melville_Queue
 HotelKeyCards
 Huffman
 Hybrid_Logic
 Hybrid_Multi_Lane_Spatial_Logic
 Hybrid_Systems_VCs
 HyperCTL
 Hyperdual
 IEEE_Floating_Point
 IFC_Tracking
 IMAP-CRDT
 IMO2019
 IMP2
 IMP2_Binary_Heap
 IMP_Compiler
 IMP_Compiler_Reuse
 IP_Addresses
 Imperative_Insertion_Sort
 Implicational_Logic
 Impossible_Geometry
 Incompleteness
 Incredible_Proof_Machine
 Independence_CH
 Inductive_Confidentiality
 Inductive_Inference
 InfPathElimination
 InformationFlowSlicing
 InformationFlowSlicing_Inter
 Integration
 Interpolation_Polynomials_HOL_Algebra
 Interpreter_Optimizations
 Interval_Arithmetic_Word32
 Intro_Dest_Elim
 Involutions2Squares
 Iptables_Semantics
 Irrational_Series_Erdos_Straus
 Irrationality_J_Hancl
 Irrationals_From_THEBOOK
 IsaGeoCoq
 Isabelle_C
 Isabelle_Marries_Dirac
 Isabelle_Meta_Model
 IsaNet
 Jacobson_Basic_Algebra
 Jinja
 JinjaDCI
 JinjaThreads
 JiveDataStoreModel
 Jordan_Hoelder
 Jordan_Normal_Form
 KAD
 KAT_and_DRA
 KBPs
 KD_Tree
 Key_Agreement_Strong_Adversaries
 Khovanskii_Theorem
 Kleene_Algebra
 Kneser_Cauchy_Davenport
 Knights_Tour
 Knot_Theory
 Knuth_Bendix_Order
 Knuth_Morris_Pratt
 Koenigsberg_Friendship
 Kruskal
 Kuratowski_Closure_Complement
 LLL_Basis_Reduction
 LLL_Factorization
 LOFT
 LTL
 LTL_Master_Theorem
 LTL_Normal_Form
 LTL_to_DRA
 LTL_to_GBA
 Lam-ml-Normalization
 LambdaAuth
 LambdaMu
 Lambda_Free_EPO
 Lambda_Free_KBOs
 Lambda_Free_RPOs
 Lambert_W
 Landau_Symbols
 Laplace_Transform
 Latin_Square
 LatticeProperties
 Launchbury
 Laws_of_Large_Numbers
 Lazy-Lists-II
 Lazy_Case
 Lehmer
 Lifting_Definition_Option
 Lifting_the_Exponent
 LightweightJava
 LinearQuantifierElim
 Linear_Inequalities
 Linear_Programming
 Linear_Recurrences
 Liouville_Numbers
 List-Index
 List-Infinite
 List_Interleaving
 List_Inversions
 List_Update
 LocalLexing
 Localization_Ring
 Locally-Nameless-Sigma
 Logging_Independent_Anonymity
 Lowe_Ontological_Argument
 Lower_Semicontinuous
 Lp
 LP_Duality
 Lucas_Theorem
 MDP-Algorithms
 MDP-Rewards
 MFMC_Countable
 MFODL_Monitor_Optimized
 MFOTL_Monitor
 MSO_Regex_Equivalence
 Markov_Models
 Marriage
 Mason_Stothers
 Matrices_for_ODEs
 Matrix
 Matrix_Tensor
 Matroids
 Maximum_Segment_Sum
 Max-Card-Matching
 Median_Method
 Median_Of_Medians_Selection
 Menger
 Mereology
 Mersenne_Primes
 Metalogic_ProofChecker
 MiniML
 MiniSail
 Minimal_SSA
 Minkowskis_Theorem
 Minsky_Machines
 Modal_Logics_for_NTS
 Modular_Assembly_Kit_Security
 Modular_arithmetic_LLL_and_HNF_algorithms
 Monad_Memo_DP
 Monad_Normalisation
 MonoBoolTranAlgebra
 MonoidalCategory
 Monomorphic_Monad
 MuchAdoAboutTwo
 Multiset_Ordering_NPC
 Multi_Party_Computation
 Multirelations
 Multitape_To_Singletape_TM
 Myhill-Nerode
 Name_Carrying_Type_Inference
 Nano_JSON
 Nash_Williams
 Nat-Interval-Logic
 Native_Word
 Nested_Multisets_Ordinals
 Network_Security_Policy_Verification
 Neumann_Morgenstern_Utility
 No_FTL_observers
 Nominal2
 Noninterference_CSP
 Noninterference_Concurrent_Composition
 Noninterference_Generic_Unwinding
 Noninterference_Inductive_Unwinding
 Noninterference_Ipurge_Unwinding
 Noninterference_Sequential_Composition
 NormByEval
 Nullstellensatz
 Number_Theoretic_Transform
 Octonions
 OpSets
 Open_Induction
 Optics
 Optimal_BST
 Orbit_Stabiliser
 Order_Lattice_Props
 Ordered_Resolution_Prover
 Ordinal
 Ordinal_Partitions
 Ordinals_and_Cardinals
 Ordinary_Differential_Equations
 PAC_Checker
 Package_logic
 PAL
 PAPP_Impossibility
 PCF
 PLM
 POPLmark-deBruijn
 PSemigroupsConvolution
 Padic_Ints
 Padic_Field
 Pairing_Heap
 Paraconsistency
 Parity_Game
 Partial_Function_MR
 Partial_Order_Reduction
 Password_Authentication_Protocol
 Pell
 Perfect-Number-Thm
 Perron_Frobenius
 Physical_Quantities
 Pi_Calculus
 Pi_Transcendental
 Planarity_Certificates
 Pluennecke_Ruzsa_Inequality
 Poincare_Bendixson
 Poincare_Disc
 Polynomial_Factorization
 Polynomial_Interpolation
 Polynomials
 Pop_Refinement
 Posix-Lexing
 Possibilistic_Noninterference
 Power_Sum_Polynomials
 Pratt_Certificate
 Prefix_Free_Code_Combinators
 Presburger-Automata
 Prim_Dijkstra_Simple
 Prime_Distribution_Elementary
 Prime_Harmonic_Series
 Prime_Number_Theorem
 Priority_Queue_Braun
 Priority_Search_Trees
 Probabilistic_Noninterference
 Probabilistic_Prime_Tests
 Probabilistic_System_Zoo
 Probabilistic_Timed_Automata
 Probabilistic_While
 Program-Conflict-Analysis
 Progress_Tracking
 Projective_Geometry
 Projective_Measurements
 Promela
 Proof_Strategy_Language
 PropResPI
 Propositional_Proof_Systems
 Prpu_Maxflow
 PseudoHoops
 Psi_Calculi
 Ptolemys_Theorem
 Public_Announcement_Logic
 QHLProver
 QR_Decomposition
 Quantales
 Quantifier_Elimination_Hybrid
 Quasi_Borel_Spaces
 Quaternions
 Query_Optimization
 Quick_Sort_Cost
 RIPEMD-160-SPARK
 ROBDD
 RSAPSS
 Ramsey-Infinite
 Random_BSTs
 Random_Graph_Subgraph_Threshold
 Randomised_BSTs
 Randomised_Social_Choice
 Rank_Nullity_Theorem
 Real_Impl
 Real_Power
 Real_Time_Deque
 Recursion-Addition
 Recursion-Theory-I
 Refine_Imperative_HOL
 Refine_Monadic
 RefinementReactive
 Regex_Equivalence
 Registers
 Regression_Test_Selection
 Regular-Sets
 Regular_Algebras
 Regular_Tree_Relations
 Relation_Algebra
 Relational-Incorrectness-Logic
 Relational_Disjoint_Set_Forests
 Relational_Forests
 Relational_Method
 Relational_Minimum_Spanning_Trees
 Relational_Paths
 Rep_Fin_Groups
 ResiduatedTransitionSystem
 Residuated_Lattices
 Resolution_FOL
 Rewrite_Properties_Reduction
 Rewriting_Z
 Ribbon_Proofs
 Risk_Free_Lending
 Robbins-Conjecture
 Robinson_Arithmetic
 Root_Balanced_Tree
 Roth_Arithmetic_Progressions
 Routing
 Roy_Floyd_Warshall
 SATSolverVerification
 SC_DOM_Components
 SDS_Impossibility
 SIFPL
 SIFUM_Type_Systems
 SPARCv8
 Safe_Distance
 Safe_OCL
 Safe_Range_RC
 Saturation_Framework
 Saturation_Framework_Extensions
 Sauer_Shelah_Lemma
 SCC_Bloemen_Sequential
 Schutz_Spacetime
 Secondary_Sylow
 Security_Protocol_Refinement
 Selection_Heap_Sort
 SenSocialChoice
 Separata
 Separation_Algebra
 Separation_Logic_Imperative_HOL
 Separation_Logic_Unbounded
 SequentInvertibility
 Shadow_DOM
 Shadow_SC_DOM
 Shivers-CFA
 ShortestPath
 Show
 Sigma_Commit_Crypto
 Signature_Groebner
 Simpl
 Simple_Firewall
 Simplex
 Simplicial_complexes_and_boolean_functions
 SimplifiedOntologicalArgument
 Skew_Heap
 Skip_Lists
 Slicing
 Sliding_Window_Algorithm
 Smith_Normal_Form
 Smooth_Manifolds
 Sophomores_Dream
 Solidity
 Sort_Encodings
 Source_Coding_Theorem
 SpecCheck
 Special_Function_Bounds
 Splay_Tree
 Sqrt_Babylonian
 Stable_Matching
 Stalnaker_Logic
 Statecharts
 Stateful_Protocol_Composition_and_Typing
 Stellar_Quorums
 Stern_Brocot
 Stewart_Apollonius
 Stirling_Formula
 Stochastic_Matrices
 Stone_Algebras
 Stone_Kleene_Relation_Algebras
 Stone_Relation_Algebras
 Store_Buffer_Reduction
 Stream-Fusion
 Stream_Fusion_Code
 Strong_Security
 Sturm_Sequences
 Sturm_Tarski
 Stuttering_Equivalence
 Subresultants
 Subset_Boolean_Algebras
 SumSquares
 Sunflowers
 SuperCalc
 Surprise_Paradox
 Symmetric_Polynomials
 Syntax_Independent_Logic
 Synthetic_Completeness
 Szemeredi_Regularity
 Szpilrajn
 TESL_Language
 TLA
 Tail_Recursive_Functions
 Tarskis_Geometry
 Taylor_Models
 Three_Circles
 Timed_Automata
 Topological_Semantics
 Topology
 TortoiseHare
 Transcendence_Series_Hancl_Rucki
 Transformer_Semantics
 Transition_Systems_and_Automata
 Transitive-Closure
 Transitive-Closure-II
 Transitive_Models
 Treaps
 Tree-Automata
 Tree_Decomposition
 Triangle
 Trie
 Turans_Graph_Theorem
 Twelvefold_Way
 Tycon
 Types_Tableaus_and_Goedels_God
 Types_To_Sets_Extension
 UPF
 UPF_Firewall
 UTP
 Undirected_Graph_Theory
 Universal_Hash_Families
 Universal_Turing_Machine
 UpDown_Scheme
 Valuation
 Van_Emde_Boas_Trees
 Van_der_Waerden
 VectorSpace
 VeriComp
 Verified-Prover
 Verified_SAT_Based_AI_Planning
 VerifyThis2018
 VerifyThis2019
 Vickrey_Clarke_Groves
 Virtual_Substitution
 VolpanoSmith
 VYDRA_MDL
 WHATandWHERE_Security
 WOOT_Strong_Eventual_Consistency
 WebAssembly
 Weight_Balanced_Trees
 Weighted_Arithmetic_Geometric_Mean
 Weighted_Path_Order
 Well_Quasi_Orders
 Wetzels_Problem
 Winding_Number_Eval
 Word_Lib
 WorkerWrapper
 X86_Semantics
 XML
 Youngs_Inequality
 ZFC_in_HOL
 Zeta_3_Irrational
 Zeta_Function
 pGCL