diff --git a/thys/Universal_Turing_Machine/Abacus.thy b/thys/Universal_Turing_Machine/Abacus.thy
--- a/thys/Universal_Turing_Machine/Abacus.thy
+++ b/thys/Universal_Turing_Machine/Abacus.thy
@@ -1,3328 +1,3348 @@
 (* Title: thys/Abacus.thy
    Author: Jian Xu, Xingyuan Zhang, and Christian Urban
    Modifications: Sebastiaan Joosten
-*)
-
-chapter \<open>Abacus Machines\<close>
+   Minor adjustments: Franz Regensburger (FABR) 02/2022
+ *)
+
+section \<open>Definition of Abacus Machines\<close>
 
 theory Abacus
-  imports Turing_Hoare Abacus_Mopup
+  imports Turing_Hoare Abacus_Mopup Turing_HaltingConditions
 begin
 
-declare replicate_Suc[simp add]
+(* Cleanup simpset: the following proofs depend on a cleaned up simpset *)
+declare adjust.simps[simp del]
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+declare fetch.simps[simp del]
 
 (* Abacus instructions *)
 
 datatype abc_inst =
   Inc nat
   | Dec nat nat
   | Goto nat
 
 type_synonym abc_prog = "abc_inst list"
 
 type_synonym abc_state = nat
 
 text \<open>
   The memory of Abacus machine is defined as a list of contents, with 
   every units addressed by index into the list.
 \<close>
 type_synonym abc_lm = "nat list"
 
 text \<open>
   Fetching contents out of memory. Units not represented by list elements are considered
   as having content \<open>0\<close>.
 \<close>
 fun abc_lm_v :: "abc_lm \<Rightarrow> nat \<Rightarrow> nat"
   where 
     "abc_lm_v lm n = (if (n < length lm) then (lm!n) else 0)"         
 
 
 text \<open>
   Set the content of memory unit \<open>n\<close> to value \<open>v\<close>.
   \<open>am\<close> is the Abacus memory before setting.
   If address \<open>n\<close> is outside to scope of \<open>am\<close>, \<open>am\<close> 
   is extended so that \<open>n\<close> becomes in scope.
 \<close>
 
 fun abc_lm_s :: "abc_lm \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> abc_lm"
   where
     "abc_lm_s am n v = (if (n < length am) then (am[n:=v]) else 
                            am@ (replicate (n - length am) 0) @ [v])"
 
 
 text \<open>
-  The configuration of Abaucs machines consists of its current state and its
+  The configuration of Abacus machines consists of its current state and its
   current memory:
 \<close>
 type_synonym abc_conf = "abc_state \<times> abc_lm"
 
 text \<open>
   Fetch instruction out of Abacus program:
 \<close>
 
 fun abc_fetch :: "nat \<Rightarrow> abc_prog \<Rightarrow> abc_inst option" 
   where
     "abc_fetch s p = (if (s < length p) then Some (p ! s) else None)"
 
 text \<open>
-  Single step execution of Abacus machine. If no instruction is feteched, 
+  Single step execution of Abacus machine. If no instruction is fetched, 
   configuration does not change.
 \<close>
 fun abc_step_l :: "abc_conf \<Rightarrow> abc_inst option \<Rightarrow> abc_conf"
   where
     "abc_step_l (s, lm) a = (case a of 
                None \<Rightarrow> (s, lm) |
                Some (Inc n)  \<Rightarrow> (let nv = abc_lm_v lm n in
                        (s + 1, abc_lm_s lm n (nv + 1))) |
                Some (Dec n e) \<Rightarrow> (let nv = abc_lm_v lm n in
                        if (nv = 0) then (e, abc_lm_s lm n 0) 
                        else (s + 1,  abc_lm_s lm n (nv - 1))) |
                Some (Goto n) \<Rightarrow> (n, lm) 
                )"
 
 text \<open>
-  Multi-step execution of Abacus machine.
+  Multi-step execution of Abacus Machines.
 \<close>
 fun abc_steps_l :: "abc_conf \<Rightarrow> abc_prog \<Rightarrow> nat \<Rightarrow> abc_conf"
   where
     "abc_steps_l (s, lm) p 0 = (s, lm)" |
-    "abc_steps_l (s, lm) p (Suc n) = 
-      abc_steps_l (abc_step_l (s, lm) (abc_fetch s p)) p n"
+    "abc_steps_l (s, lm) p (Suc n) = abc_steps_l (abc_step_l (s, lm) (abc_fetch s p)) p n"
 
 section \<open>
-  Compiling Abacus machines into Turing machines
+  Compiling Abacus Machines into Turing Machines
 \<close>
 
 subsection \<open>
-  Compiling functions
+  Functions used for compilation
 \<close>
 
 text \<open>
   \<open>findnth n\<close> returns the TM which locates the represention of
   memory cell \<open>n\<close> on the tape and changes representation of zero
   on the way.
 \<close>
 
 fun findnth :: "nat \<Rightarrow> instr list"
   where
     "findnth 0 = []" |
-    "findnth (Suc n) = (findnth n @ [(W1, 2 * n + 1), 
+    "findnth (Suc n) = (findnth n @ [(WO, 2 * n + 1), 
            (R, 2 * n + 2), (R, 2 * n + 3), (R, 2 * n + 2)])"
 
 text \<open>
   \<open>tinc_b\<close> returns the TM which increments the representation 
   of the memory cell under rw-head by one and move the representation 
   of cells afterwards to the right accordingly.
 \<close>
 
 definition tinc_b :: "instr list"
   where
-    "tinc_b \<equiv> [(W1, 1), (R, 2), (W1, 3), (R, 2), (W1, 3), (R, 4), 
-             (L, 7), (W0, 5), (R, 6), (W0, 5), (W1, 3), (R, 6),
-             (L, 8), (L, 7), (R, 9), (L, 7), (R, 10), (W0, 9)]" 
+    "tinc_b \<equiv> [(WO, 1), (R, 2), (WO, 3), (R, 2), (WO, 3), (R, 4), 
+             (L, 7), (WB, 5), (R, 6), (WB, 5), (WO, 3), (R, 6),
+             (L, 8), (L, 7), (R, 9), (L, 7), (R, 10), (WB, 9)]" 
 
 text \<open>
   \<open>tinc ss n\<close> returns the TM which simulates the execution of 
   Abacus instruction \<open>Inc n\<close>, assuming that TM is located at
   location \<open>ss\<close> in the final TM complied from the whole
   Abacus program.
 \<close>
 
 fun tinc :: "nat \<Rightarrow> nat \<Rightarrow> instr list"
   where
     "tinc ss n = shift (findnth n @ shift tinc_b (2 * n)) (ss - 1)"
 
 text \<open>
-  \<open>tinc_b\<close> returns the TM which decrements the representation 
+  \<open>tdec_b\<close> returns the TM which decrements the representation 
   of the memory cell under rw-head by one and move the representation 
   of cells afterwards to the left accordingly.
 \<close>
 
 definition tdec_b :: "instr list"
   where
-    "tdec_b \<equiv>  [(W1, 1), (R, 2), (L, 14), (R, 3), (L, 4), (R, 3),
-              (R, 5), (W0, 4), (R, 6), (W0, 5), (L, 7), (L, 8),
-              (L, 11), (W0, 7), (W1, 8), (R, 9), (L, 10), (R, 9),
-              (R, 5), (W0, 10), (L, 12), (L, 11), (R, 13), (L, 11),
-              (R, 17), (W0, 13), (L, 15), (L, 14), (R, 16), (L, 14),
-              (R, 0), (W0, 16)]"
+    "tdec_b \<equiv>  [(WO, 1), (R, 2), (L, 14), (R, 3), (L, 4), (R, 3),
+              (R, 5), (WB, 4), (R, 6), (WB, 5), (L, 7), (L, 8),
+              (L, 11), (WB, 7), (WO, 8), (R, 9), (L, 10), (R, 9),
+              (R, 5), (WB, 10), (L, 12), (L, 11), (R, 13), (L, 11),
+              (R, 17), (WB, 13), (L, 15), (L, 14), (R, 16), (L, 14),
+              (R, 0), (WB, 16)]"
 
 
 text \<open>
   \<open>tdec ss n label\<close> returns the TM which simulates the execution of 
   Abacus instruction \<open>Dec n label\<close>, assuming that TM is located at
   location \<open>ss\<close> in the final TM complied from the whole
   Abacus program.
 \<close>
 
 fun tdec :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> instr list"
   where
     "tdec ss n e = shift (findnth n) (ss - 1) @ adjust (shift (shift tdec_b (2 * n)) (ss - 1)) e"
 
 text \<open>
   \<open>tgoto f(label)\<close> returns the TM simulating the execution of Abacus instruction
   \<open>Goto label\<close>, where \<open>f(label)\<close> is the corresponding location of
   \<open>label\<close> in the final TM compiled from the overall Abacus program.
 \<close>
 
 fun tgoto :: "nat \<Rightarrow> instr list"
   where
     "tgoto n = [(Nop, n), (Nop, n)]"
 
 text \<open>
   The layout of the final TM compiled from an Abacus program is represented
   as a list of natural numbers, where the list element at index \<open>n\<close> represents the 
   starting state of the TM simulating the execution of \<open>n\<close>-th instruction
   in the Abacus program.
 \<close>
 
 type_synonym layout = "nat list"
 
 text \<open>
   \<open>length_of i\<close> is the length of the 
   TM simulating the Abacus instruction \<open>i\<close>.
 \<close>
 fun length_of :: "abc_inst \<Rightarrow> nat"
   where
     "length_of i = (case i of 
                     Inc n   \<Rightarrow> 2 * n + 9 |
                     Dec n e \<Rightarrow> 2 * n + 16 |
                     Goto n  \<Rightarrow> 1)"
 
 text \<open>
   \<open>layout_of ap\<close> returns the layout of Abacus program \<open>ap\<close>.
 \<close>
 fun layout_of :: "abc_prog \<Rightarrow> layout"
   where "layout_of ap = map length_of ap"
 
 
 text \<open>
   \<open>start_of layout n\<close> looks out the starting state of \<open>n\<close>-th
   TM in the finall TM.
 \<close>
 
 fun start_of :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "start_of ly x = (Suc (sum_list (take x ly))) "
 
 text \<open>
-  \<open>ci lo ss i\<close> complies Abacus instruction \<open>i\<close>
+  \<open>ci lo ss i\<close> compiles the Abacus instruction \<open>i\<close>
   assuming the TM of \<open>i\<close> starts from state \<open>ss\<close> 
   within the overal layout \<open>lo\<close>.
 \<close>
 
 fun ci :: "layout \<Rightarrow> nat \<Rightarrow> abc_inst \<Rightarrow> instr list"
   where
     "ci ly ss (Inc n) = tinc ss n"
   | "ci ly ss (Dec n e) = tdec ss n (start_of ly e)"
   | "ci ly ss (Goto n) = tgoto (start_of ly n)"
 
 text \<open>
   \<open>tpairs_of ap\<close> transfroms Abacus program \<open>ap\<close> pairing
   every instruction with its starting state.
 \<close>
 
 fun tpairs_of :: "abc_prog \<Rightarrow> (nat \<times> abc_inst) list"
   where "tpairs_of ap = (zip (map (start_of (layout_of ap)) 
                          [0..<(length ap)]) ap)"
 
 text \<open>
   \<open>tms_of ap\<close> returns the list of TMs, where every one of them simulates
   the corresponding Abacus intruction in \<open>ap\<close>.
 \<close>
 
 fun tms_of :: "abc_prog \<Rightarrow> (instr list) list"
   where "tms_of ap = map (\<lambda> (n, tm). ci (layout_of ap) n tm) 
                          (tpairs_of ap)"
 
 text \<open>
   \<open>tm_of ap\<close> returns the final TM machine compiled from Abacus program \<open>ap\<close>.
 \<close>
 fun tm_of :: "abc_prog \<Rightarrow> instr list"
   where "tm_of ap = concat (tms_of ap)"
 
+(* --- *)
 lemma length_findnth: 
   "length (findnth n) = 4 * n"
   by (induct n, auto)
 
 lemma ci_length : "length (ci ns n ai) div 2 = length_of ai"
-  apply(auto simp: ci.simps tinc_b_def tdec_b_def length_findnth
-      split: abc_inst.splits simp del: adjust.simps)
+  apply(auto simp: tinc_b_def tdec_b_def length_findnth
+      split: abc_inst.splits)
   done
 
-subsection \<open>Representation of Abacus memory by TM tapes\<close>
+subsection \<open>Representation of Abacus Memory by TM tapes\<close>
 
 text \<open>
-  \<open>crsp acf tcf\<close> meams the abacus configuration \<open>acf\<close>
+  \<open>crsp acf tcf\<close> means the abacus configuration \<open>acf\<close>
   is corretly represented by the TM configuration \<open>tcf\<close>.
 \<close>
 
 fun crsp :: "layout \<Rightarrow> abc_conf \<Rightarrow> config \<Rightarrow> cell list \<Rightarrow> bool"
   where 
     "crsp ly (as, lm) (s, l, r) inres = 
            (s = start_of ly as \<and> (\<exists> x. r = <lm> @ Bk\<up>x) \<and> 
             l = Bk # Bk # inres)"
 
 declare crsp.simps[simp del]
 
 text \<open>
-  The type of invarints expressing correspondence between 
+  The type of invariants expressing correspondence between 
   Abacus configuration and TM configuration.
 \<close>
 
 type_synonym inc_inv_t = "abc_conf \<Rightarrow> config \<Rightarrow> cell list \<Rightarrow> bool"
 
 declare tms_of.simps[simp del] tm_of.simps[simp del]
-  layout_of.simps[simp del] abc_fetch.simps [simp del]  
+  abc_fetch.simps [simp del]  
   tpairs_of.simps[simp del] start_of.simps[simp del]
   ci.simps [simp del] length_of.simps[simp del] 
   layout_of.simps[simp del]
 
 text \<open>
   The lemmas in this section lead to the correctness of 
   the compilation of \<open>Inc n\<close> instruction.
 \<close>
 
 declare abc_step_l.simps[simp del] abc_steps_l.simps[simp del]
 lemma start_of_nonzero[simp]: "start_of ly as > 0" "(start_of ly as = 0) = False"
    apply(auto simp: start_of.simps)
   done
 
 lemma abc_steps_l_0: "abc_steps_l ac ap 0 = ac"
   by(cases ac, simp add: abc_steps_l.simps)
 
 lemma abc_step_red: 
   "abc_steps_l (as, am) ap stp = (bs, bm) \<Longrightarrow> 
   abc_steps_l (as, am) ap (Suc stp) = abc_step_l (bs, bm) (abc_fetch bs ap) "
 proof(induct stp arbitrary: as am bs bm)
   case 0
   thus "?case"
     by(simp add: abc_steps_l.simps abc_steps_l_0)
 next
   case (Suc stp as am bs bm)
   have ind: "\<And>as am bs bm. abc_steps_l (as, am) ap stp = (bs, bm) \<Longrightarrow> 
     abc_steps_l (as, am) ap (Suc stp) = abc_step_l (bs, bm) (abc_fetch bs ap)"
     by fact
   have h:" abc_steps_l (as, am) ap (Suc stp) = (bs, bm)" by fact
   obtain as' am' where g: "abc_step_l (as, am) (abc_fetch as ap) = (as', am')"
     by(cases "abc_step_l (as, am) (abc_fetch as ap)", auto)
   then have "abc_steps_l (as', am') ap (Suc stp) = abc_step_l (bs, bm) (abc_fetch bs ap)"
     using h
     by(intro ind, simp add: abc_steps_l.simps)
   thus "?case"
     using g
     by(simp add: abc_steps_l.simps)
 qed
 
 lemma tm_shift_fetch: 
   "\<lbrakk>fetch A s b = (ac, ns); ns \<noteq> 0 \<rbrakk>
   \<Longrightarrow> fetch (shift A off) s b = (ac, ns + off)"
   apply(cases b;cases s)
      apply(auto simp: fetch.simps shift.simps)
   done
 
 lemma tm_shift_eq_step:
   assumes exec: "step (s, l, r) (A, 0) = (s', l', r')"
     and notfinal: "s' \<noteq> 0"
   shows "step (s + off, l, r) (shift A off, off) = (s' + off, l', r')"
   using assms
   apply(simp add: step.simps)
   apply(cases "fetch A s (read r)", auto)
    apply(drule_tac [!] off = off in tm_shift_fetch, simp_all)
   done
 
-declare step.simps[simp del] steps.simps[simp del] shift.simps[simp del]
-
 lemma tm_shift_eq_steps: 
   assumes exec: "steps (s, l, r) (A, 0) stp = (s', l', r')"
     and notfinal: "s' \<noteq> 0"
   shows "steps (s + off, l, r) (shift A off, off) stp = (s' + off, l', r')"
   using exec notfinal
 proof(induct stp arbitrary: s' l' r', simp add: steps.simps)
   fix stp s' l' r'
   assume ind: "\<And>s' l' r'. \<lbrakk>steps (s, l, r) (A, 0) stp = (s', l', r'); s' \<noteq> 0\<rbrakk> 
      \<Longrightarrow> steps (s + off, l, r) (shift A off, off) stp = (s' + off, l', r')"
     and h: " steps (s, l, r) (A, 0) (Suc stp) = (s', l', r')" "s' \<noteq> 0"
   obtain s1 l1 r1 where g: "steps (s, l, r) (A, 0) stp = (s1, l1, r1)" 
     apply(cases "steps (s, l, r) (A, 0) stp") by blast
   moreover then have "s1 \<noteq> 0"
     using h
-    apply(simp add: step_red)
+    apply(simp)
     apply(cases "0 < s1", auto)
     done
   ultimately have "steps (s + off, l, r) (shift A off, off) stp =
                    (s1 + off, l1, r1)"
     apply(intro ind, simp_all)
     done
   thus "steps (s + off, l, r) (shift A off, off) (Suc stp) = (s' + off, l', r')"
     using h g assms
-    apply(simp add: step_red)
+    apply(simp)
     apply(intro tm_shift_eq_step, auto)
     done
 qed
 
 lemma startof_ge1[simp]: "Suc 0 \<le> start_of ly as"
   apply(simp add: start_of.simps)
   done
 
 lemma start_of_Suc1: "\<lbrakk>ly = layout_of ap; 
        abc_fetch as ap = Some (Inc n)\<rbrakk>
        \<Longrightarrow> start_of ly (Suc as) = start_of ly as + 2 * n + 9"
   apply(auto simp: start_of.simps layout_of.simps  
       length_of.simps abc_fetch.simps 
       take_Suc_conv_app_nth split: if_splits)
   done
 
 lemma start_of_Suc2:
   "\<lbrakk>ly = layout_of ap;
   abc_fetch as ap = Some (Dec n e)\<rbrakk> \<Longrightarrow> 
         start_of ly (Suc as) = 
             start_of ly as + 2 * n + 16"
   apply(auto simp: start_of.simps layout_of.simps  
       length_of.simps abc_fetch.simps 
       take_Suc_conv_app_nth split: if_splits)
   done
 
 lemma start_of_Suc3:
   "\<lbrakk>ly = layout_of ap;
   abc_fetch as ap = Some (Goto n)\<rbrakk> \<Longrightarrow> 
   start_of ly (Suc as) = start_of ly as + 1"
   apply(auto simp: start_of.simps layout_of.simps  
       length_of.simps abc_fetch.simps 
       take_Suc_conv_app_nth split: if_splits)
   done
 
 lemma length_ci_inc: 
   "length (ci ly ss (Inc n)) = 4*n + 18"
   apply(auto simp: ci.simps length_findnth tinc_b_def)
   done
 
 lemma length_ci_dec: 
   "length (ci ly ss (Dec n e)) = 4*n + 32"
   apply(auto simp: ci.simps length_findnth tdec_b_def)
   done
 
 lemma length_ci_goto: 
   "length (ci ly ss (Goto n )) = 2"
   apply(auto simp: ci.simps length_findnth tdec_b_def)
   done
 
 lemma take_Suc_last[elim]: "Suc as \<le> length xs \<Longrightarrow> 
             take (Suc as) xs = take as xs @ [xs ! as]"
 proof(induct xs arbitrary: as)
   case (Cons a xs)
   then show ?case by ( simp, cases as;simp)
 qed simp
 
 lemma concat_suc: "Suc as \<le> length xs \<Longrightarrow> 
        concat (take (Suc as) xs) = concat (take as xs) @ xs! as"
   apply(subgoal_tac "take (Suc as) xs = take as xs @ [xs ! as]", simp)
   by auto
 
 lemma concat_drop_suc_iff: 
   "Suc n < length tps \<Longrightarrow> concat (drop (Suc n) tps) = 
            tps ! Suc n @ concat (drop (Suc (Suc n)) tps)"
 proof(induct tps arbitrary: n)
   case (Cons a tps)
   then show ?case 
     apply(cases tps, simp, simp)
     apply(cases n, simp, simp)
     done
 qed simp
 
 declare append_assoc[simp del]
 
 lemma  tm_append:
   "\<lbrakk>n < length tps; tp = tps ! n\<rbrakk> \<Longrightarrow> 
   \<exists> tp1 tp2. concat tps = tp1 @ tp @ tp2 \<and> tp1 = 
   concat (take n tps) \<and> tp2 = concat (drop (Suc n) tps)"
   apply(rule_tac x = "concat (take n tps)" in exI)
   apply(rule_tac x = "concat (drop (Suc n) tps)" in exI)
   apply(auto)
 proof(induct n)
   case 0
   then show ?case by(cases tps; simp)
 next
   case (Suc n)
   then show ?case 
     apply(subgoal_tac "concat (take n tps) @ (tps ! n) = 
                concat (take (Suc n) tps)")
      apply(simp only: append_assoc[THEN sym], simp only: append_assoc)
      apply(subgoal_tac " concat (drop (Suc n) tps) = tps ! Suc n @ 
                   concat (drop (Suc (Suc n)) tps)")
       apply (metis append_take_drop_id concat_append)
      apply(rule concat_drop_suc_iff,force)
     by (simp add: concat_suc)
 qed
 
 declare append_assoc[simp]
 
 lemma length_tms_of[simp]: "length (tms_of aprog) = length aprog"
   apply(auto simp: tms_of.simps tpairs_of.simps)
   done
 
 lemma ci_nth: 
   "\<lbrakk>ly = layout_of aprog; 
   abc_fetch as aprog = Some ins\<rbrakk>
   \<Longrightarrow> ci ly (start_of ly as) ins = tms_of aprog ! as"
   apply(simp add: tms_of.simps tpairs_of.simps 
       abc_fetch.simps del: map_append split: if_splits)
   done
 
 lemma t_split:"\<lbrakk>
         ly = layout_of aprog;
         abc_fetch as aprog = Some ins\<rbrakk>
       \<Longrightarrow> \<exists> tp1 tp2. concat (tms_of aprog) = 
             tp1 @ (ci ly (start_of ly as) ins) @ tp2
             \<and> tp1 = concat (take as (tms_of aprog)) \<and> 
               tp2 = concat (drop (Suc as) (tms_of aprog))"
   apply(insert tm_append[of "as" "tms_of aprog" 
         "ci ly (start_of ly as) ins"], simp)
   apply(subgoal_tac "ci ly (start_of ly as) ins = (tms_of aprog) ! as")
    apply(subgoal_tac "length (tms_of aprog) = length aprog")
     apply(simp add: abc_fetch.simps split: if_splits, simp)
   apply(intro ci_nth, auto)
   done
 
 lemma div_apart: "\<lbrakk>x mod (2::nat) = 0; y mod 2 = 0\<rbrakk> 
           \<Longrightarrow> (x + y) div 2 = x div 2 + y div 2"
   by(auto)
 
 lemma length_layout_of[simp]: "length (layout_of aprog) = length aprog"
   by(auto simp: layout_of.simps)
 
 lemma length_tms_of_elem_even[intro]:  "n < length ap \<Longrightarrow> length (tms_of ap ! n) mod 2 = 0"
   apply(cases "ap ! n")
   by (auto simp: tms_of.simps tpairs_of.simps ci.simps length_findnth tinc_b_def tdec_b_def)
 
 lemma compile_mod2: "length (concat (take n (tms_of ap))) mod 2 = 0"
 proof(induct n)
   case 0
   then show ?case by (auto simp add: take_Suc_conv_app_nth)
 next
   case (Suc n)
   hence "n < length (tms_of ap) \<Longrightarrow> is_even (length (concat (take (Suc n) (tms_of ap))))"
     unfolding take_Suc_conv_app_nth by fastforce
   with Suc show ?case by(cases "n < length (tms_of ap)", auto)
 qed
 
 lemma tpa_states:
   "\<lbrakk>tp = concat (take as (tms_of ap));
   as \<le> length ap\<rbrakk> \<Longrightarrow> 
   start_of (layout_of ap) as = Suc (length tp div 2)"
 proof(induct as arbitrary: tp)
   case 0
   thus "?case"
     by(simp add: start_of.simps)
 next
   case (Suc as tp)
   have ind: "\<And>tp. \<lbrakk>tp = concat (take as (tms_of ap)); as \<le> length ap\<rbrakk> \<Longrightarrow>
     start_of (layout_of ap) as = Suc (length tp div 2)" by fact
   have tp: "tp = concat (take (Suc as) (tms_of ap))" by fact
   have le: "Suc as \<le> length ap" by fact
   have a: "start_of (layout_of ap) as = Suc (length (concat (take as (tms_of ap))) div 2)"
     using le
     by(intro ind, simp_all)
   from a tp le show "?case"
     apply(simp add: start_of.simps take_Suc_conv_app_nth)
     apply(subgoal_tac "length (concat (take as (tms_of ap))) mod 2= 0")
      apply(subgoal_tac " length (tms_of ap ! as) mod 2 = 0")
       apply(simp add: Abacus.div_apart) 
       apply(simp add: layout_of.simps ci_length  tms_of.simps tpairs_of.simps)
      apply(auto  intro: compile_mod2)
     done
 qed
 
 declare fetch.simps[simp]
 lemma append_append_fetch: 
   "\<lbrakk>length tp1 mod 2 = 0; length tp mod 2 = 0;
       length tp1 div 2 < a \<and> a \<le> length tp1 div 2 + length tp div 2\<rbrakk>
     \<Longrightarrow>fetch (tp1 @ tp @ tp2) a b = fetch tp (a - length tp1 div 2) b "
   apply(subgoal_tac "\<exists> x. a = length tp1 div 2 + x", erule exE)
    apply(rename_tac x)
    apply(case_tac x, simp)
    apply(subgoal_tac "length tp1 div 2 + Suc nat = 
              Suc (length tp1 div 2 + nat)")
     apply(simp only: fetch.simps nth_of.simps, auto)
    apply(cases b, simp)
     apply(subgoal_tac "2 * (length tp1 div 2) = length tp1", simp)
      apply(subgoal_tac "2 * nat < length tp", simp add: nth_append, simp)
     apply(subgoal_tac "2 * (length tp1 div 2) = length tp1", simp)
     apply(subgoal_tac "2 * nat < length tp", simp add: nth_append, auto)
    apply(auto simp: nth_append)
   apply(rule_tac x = "a - length tp1 div 2" in exI, simp)
   done
 
 lemma step_eq_fetch':
   assumes layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and fetch: "abc_fetch as ap = Some ins"
     and range1: "s \<ge> start_of ly as"
     and range2: "s < start_of ly (Suc as)"
   shows "fetch tp s b = fetch (ci ly (start_of ly as) ins)
        (Suc s - start_of ly as) b "
 proof -
   have "\<exists>tp1 tp2. concat (tms_of ap) = tp1 @ ci ly (start_of ly as) ins @ tp2 \<and>
     tp1 = concat (take as (tms_of ap)) \<and> tp2 = concat (drop (Suc as) (tms_of ap))"
     using assms
     by(intro t_split, simp_all)
   then obtain tp1 tp2 where a: "concat (tms_of ap) = tp1 @ ci ly (start_of ly as) ins @ tp2 \<and>
     tp1 = concat (take as (tms_of ap)) \<and> tp2 = concat (drop (Suc as) (tms_of ap))" by blast
   then have b: "start_of (layout_of ap) as = Suc (length tp1 div 2)"
     using fetch
     by(intro tpa_states, simp, simp add: abc_fetch.simps split: if_splits)
   have "fetch (tp1 @ (ci ly (start_of ly as) ins) @ tp2)  s b = 
         fetch (ci ly (start_of ly as) ins) (s - length tp1 div 2) b"
   proof(intro append_append_fetch)
     show "length tp1 mod 2 = 0"
       using a
       by(auto, rule_tac compile_mod2)
   next
     show "length (ci ly (start_of ly as) ins) mod 2 = 0"
       by(cases ins, auto simp: ci.simps length_findnth tinc_b_def tdec_b_def)
   next
     show "length tp1 div 2 < s \<and> s \<le> 
       length tp1 div 2 + length (ci ly (start_of ly as) ins) div 2"
     proof -
       have "length (ci ly (start_of ly as) ins) div 2 = length_of ins"
         using ci_length by simp
       moreover have "start_of ly (Suc as) = start_of ly as + length_of ins"
         using fetch layout
         apply(simp add: start_of.simps abc_fetch.simps List.take_Suc_conv_app_nth 
             split: if_splits)
         apply(simp add: layout_of.simps)
         done
       ultimately show "?thesis"
         using b layout range1 range2
         apply(simp)
         done
     qed
   qed
   thus "?thesis"
     using b layout a compile  
     apply(simp add: tm_of.simps)
     done
 qed
 
 lemma step_eq_fetch: 
   assumes layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and abc_fetch: "abc_fetch as ap = Some ins" 
     and fetch: "fetch (ci ly (start_of ly as) ins)
        (Suc s - start_of ly as) b = (ac, ns)"
     and notfinal: "ns \<noteq> 0"
   shows "fetch tp s b = (ac, ns)"
 proof -
   have "s \<ge> start_of ly as"
   proof(cases "s \<ge> start_of ly as")
     case True thus "?thesis" by simp
   next
     case False 
     have "\<not> start_of ly as \<le> s" by fact
     then have "Suc s - start_of ly as = 0"
       by arith
     then have "fetch (ci ly (start_of ly as) ins)
        (Suc s - start_of ly as) b = (Nop, 0)"
-      by(simp add: fetch.simps)
+      by simp
     with notfinal fetch show "?thesis"
       by(simp)
   qed
   moreover have "s < start_of ly (Suc as)"
   proof(cases "s < start_of ly (Suc as)")
     case True thus "?thesis" by simp
   next
     case False
     have h: "\<not> s < start_of ly (Suc as)"
       by fact
     then have "s > start_of ly as"
       using abc_fetch layout
       apply(simp add: start_of.simps abc_fetch.simps split: if_splits)
       apply(simp add: List.take_Suc_conv_app_nth, auto)
       apply(subgoal_tac "layout_of ap ! as > 0") 
        apply arith
       apply(simp add: layout_of.simps)
       apply(cases "ap!as", auto simp: length_of.simps)
       done
     from this and h have "fetch (ci ly (start_of ly as) ins) (Suc s - start_of ly as) b = (Nop, 0)"
       using abc_fetch layout
       apply(cases b;cases ins)
            apply(simp_all add:Suc_diff_le start_of_Suc2 start_of_Suc1 start_of_Suc3)
       by (simp_all only: length_ci_inc length_ci_dec length_ci_goto, auto)
     from fetch and notfinal this show "?thesis"by simp
   qed
   ultimately show "?thesis"
     using assms
     by(drule_tac b= b and ins = ins in step_eq_fetch', auto)
 qed
 
 
 lemma step_eq_in:
   assumes layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and fetch: "abc_fetch as ap = Some ins"    
     and exec: "step (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) 
   = (s', l', r')"
     and notfinal: "s' \<noteq> 0"
   shows "step (s, l, r) (tp, 0) = (s', l', r')"
   using assms
   apply(simp add: step.simps)
   apply(cases "fetch (ci (layout_of ap) (start_of (layout_of ap) as) ins)
     (Suc s - start_of (layout_of ap) as) (read r)", simp)
   using layout
   apply(drule_tac s = s and b = "read r" and ac = a in step_eq_fetch, auto)
   done
 
 lemma steps_eq_in:
   assumes layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
     and fetch: "abc_fetch as ap = Some ins"    
     and exec: "steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp 
   = (s', l', r')"
     and notfinal: "s' \<noteq> 0"
   shows "steps (s, l, r) (tp, 0) stp = (s', l', r')"
   using exec notfinal
 proof(induct stp arbitrary: s' l' r', simp add: steps.simps)
   fix stp s' l' r'
   assume ind: 
     "\<And>s' l' r'. \<lbrakk>steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp = (s', l', r'); s' \<noteq> 0\<rbrakk>
               \<Longrightarrow> steps (s, l, r) (tp, 0) stp = (s', l', r')"
     and h: "steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) (Suc stp) = (s', l', r')" "s' \<noteq> 0"
   obtain s1 l1 r1 where g: "steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp = 
                         (s1, l1, r1)"
     apply(cases "steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp") by blast
   moreover hence "s1 \<noteq> 0"
     using h
-    apply(simp add: step_red)
-    apply(cases "0 < s1", simp_all)
+    apply simp
+    apply (cases "0 < s1", simp_all)
     done
   ultimately have "steps (s, l, r) (tp, 0) stp = (s1, l1, r1)"
     apply(rule_tac ind, auto)
     done
   thus "steps (s, l, r) (tp, 0) (Suc stp) = (s', l', r')"
     using h g assms
-    apply(simp add: step_red)
+    apply simp
     apply(rule_tac step_eq_in, auto)
     done
 qed
 
 lemma tm_append_fetch_first: 
   "\<lbrakk>fetch A s b = (ac, ns); ns \<noteq> 0\<rbrakk> \<Longrightarrow> 
     fetch (A @ B) s b = (ac, ns)"
-  by(cases b;cases s;force simp: fetch.simps nth_append split: if_splits)
+  by(cases b;cases s;force simp: nth_append split: if_splits)
 
 lemma tm_append_first_step_eq: 
   assumes "step (s, l, r) (A, off) = (s', l', r')"
     and "s' \<noteq> 0"
   shows "step (s, l, r) (A @ B, off) = (s', l', r')"
   using assms
   apply(simp add: step.simps)
   apply(cases "fetch A (s - off) (read r)")
   apply(frule_tac  B = B and b = "read r" in tm_append_fetch_first, auto)
   done
 
 lemma tm_append_first_steps_eq: 
   assumes "steps (s, l, r) (A, off) stp = (s', l', r')"
     and "s' \<noteq> 0"
   shows "steps (s, l, r) (A @ B, off) stp = (s', l', r')"
   using assms
 proof(induct stp arbitrary: s' l' r', simp add: steps.simps)
   fix stp s' l' r'
   assume ind: "\<And>s' l' r'. \<lbrakk>steps (s, l, r) (A, off) stp = (s', l', r'); s' \<noteq> 0\<rbrakk>
     \<Longrightarrow> steps (s, l, r) (A @ B, off) stp = (s', l', r')"
     and h: "steps (s, l, r) (A, off) (Suc stp) = (s', l', r')" "s' \<noteq> 0"
   obtain sa la ra where a: "steps (s, l, r) (A, off) stp = (sa, la, ra)"
     apply(cases "steps (s, l, r) (A, off) stp") by blast
   hence "steps (s, l, r) (A @ B, off) stp = (sa, la, ra) \<and> sa \<noteq> 0"
     using h ind[of sa la ra]
     apply(cases sa, simp_all)
     done
   thus "steps (s, l, r) (A @ B, off) (Suc stp) = (s', l', r')"
     using h a
-    apply(simp add: step_red)
-    apply(intro tm_append_first_step_eq, simp_all)
+    apply simp
+    apply (intro tm_append_first_step_eq, simp_all)
     done
 qed
 
 lemma tm_append_second_fetch_eq:
   assumes
     even: "length A mod 2 = 0"
     and off: "off = length A div 2"
     and fetch: "fetch B s b = (ac, ns)"
     and notfinal: "ns \<noteq> 0"
   shows "fetch (A @ shift B off) (s + off) b = (ac, ns + off)"
   using assms
   by(cases b;cases s,auto simp: nth_append shift.simps split: if_splits)
 
 lemma tm_append_second_step_eq: 
   assumes 
     exec: "step0 (s, l, r) B = (s', l', r')"
     and notfinal: "s' \<noteq> 0"
     and off: "off = length A div 2"
     and even: "length A mod 2 = 0"
   shows "step0 (s + off, l, r) (A @ shift B off) = (s' + off, l', r')"
   using assms
   apply(simp add: step.simps)
   apply(cases "fetch B s (read r)")
   apply(frule_tac tm_append_second_fetch_eq, simp_all, auto)
   done
 
 
 lemma tm_append_second_steps_eq: 
   assumes 
     exec: "steps (s, l, r) (B, 0) stp = (s', l', r')"
     and notfinal: "s' \<noteq> 0"
     and off: "off = length A div 2"
     and even: "length A mod 2 = 0"
   shows "steps (s + off, l, r) (A @ shift B off, 0) stp = (s' + off, l', r')"
   using exec notfinal
 proof(induct stp arbitrary: s' l' r')
   case 0
   thus "steps0 (s + off, l, r) (A @ shift B off) 0 = (s' + off, l', r')"
     by(simp add: steps.simps)
 next
   case (Suc stp s' l' r')
   have ind: "\<And>s' l' r'. \<lbrakk>steps0 (s, l, r) B stp = (s', l', r'); s' \<noteq> 0\<rbrakk> \<Longrightarrow> 
     steps0 (s + off, l, r) (A @ shift B off) stp = (s' + off, l', r')"
     by fact
   have h: "steps0 (s, l, r) B (Suc stp) = (s', l', r')" by fact
   have k: "s' \<noteq> 0" by fact
   obtain s'' l'' r'' where a: "steps0 (s, l, r) B stp = (s'', l'', r'')"
     by (metis prod_cases3)
   then have b: "s'' \<noteq> 0"
     using h k
     by(intro notI, auto)
   from a b have c: "steps0 (s + off, l, r) (A @ shift B off) stp = (s'' + off, l'', r'')"
     by(erule_tac ind, simp)
   from c b h a k assms show "?case"
     by(auto intro:tm_append_second_step_eq)
 qed
 
 lemma tm_append_second_fetch0_eq:
   assumes
     even: "length A mod 2 = 0"
     and off: "off = length A div 2"
     and fetch: "fetch B s b = (ac, 0)"
     and notfinal: "s \<noteq> 0"
   shows "fetch (A @ shift B off) (s + off) b = (ac, 0)"
   using assms
   apply(cases b;cases s)
-     apply(auto simp: fetch.simps nth_append shift.simps split: if_splits)
+     apply(auto simp: nth_append shift.simps split: if_splits)
   done
 
 lemma tm_append_second_halt_eq:
   assumes 
     exec: "steps (Suc 0, l, r) (B, 0) stp = (0, l', r')"
-    and wf_B: "tm_wf (B, 0)"
+    and "composable_tm (B, 0)"
     and off: "off = length A div 2"
     and even: "length A mod 2 = 0"
   shows "steps (Suc off, l, r) (A @ shift B off, 0) stp = (0, l', r')"
 proof -
   have "\<exists>n. \<not> is_final (steps0 (1, l, r) B n) \<and> steps0 (1, l, r) B (Suc n) = (0, l', r')"
     using exec by(rule_tac before_final, simp)
   then obtain n where a: 
     "\<not> is_final (steps0 (1, l, r) B n) \<and> steps0 (1, l, r) B (Suc n) = (0, l', r')" ..
   obtain s'' l'' r'' where b: "steps0 (1, l, r) B n = (s'', l'', r'') \<and> s'' >0"
     using a
     by(cases "steps0 (1, l, r) B n", auto)
   have c: "steps (Suc 0 + off, l, r) (A @ shift B off, 0) n = (s'' + off, l'', r'')"
     using a b assms
     by(rule_tac tm_append_second_steps_eq, simp_all)
   obtain ac where d: "fetch B s'' (read r'') = (ac, 0)"
     using  b a
-    by(cases "fetch B s'' (read r'')", auto simp: step_red step.simps)
+    by(cases "fetch B s'' (read r'')", auto simp: step.simps)
   then have "fetch (A @ shift B off) (s'' + off) (read r'') = (ac, 0)"
     using assms b
     by(rule_tac tm_append_second_fetch0_eq, simp_all)
   then have e: "steps (Suc 0 + off, l, r) (A @ shift B off, 0) (Suc n) = (0, l', r')"
     using a b assms c d
-    by(simp add: step_red step.simps)
+    by(simp add: step.simps)
   from a have "n < stp"
     using exec
   proof(cases "n < stp")
     case  True thus "?thesis" by simp
   next
     case False
     have "\<not> n < stp" by fact
     then obtain d where  "n = stp + d"
       by (metis add.comm_neutral less_imp_add_positive nat_neq_iff)
     thus "?thesis"
       using a e exec
       by(simp)
   qed
   then obtain d where "stp = Suc n + d"
     by(metis add_Suc less_iff_Suc_add)
   thus "?thesis"
     using e
     by(simp only: steps_add, simp)
 qed
 
 lemma tm_append_steps: 
   assumes 
     aexec: "steps (s, l, r) (A, 0) stpa = (Suc (length A div 2), la, ra)"
     and bexec: "steps (Suc 0, la, ra) (B, 0) stpb =  (sb, lb, rb)"
     and notfinal: "sb \<noteq> 0"
     and off: "off = length A div 2"
     and even: "length A mod 2 = 0"
   shows "steps (s, l, r) (A @ shift B off, 0) (stpa + stpb) = (sb + off, lb, rb)"
 proof -
   have "steps (s, l, r) (A@shift B off, 0) stpa = (Suc (length A div 2), la, ra)"
     apply(intro tm_append_first_steps_eq)
      apply(auto simp: assms)
     done
   moreover have "steps (1 + off, la, ra) (A @ shift B off, 0) stpb = (sb + off, lb, rb)"
     apply(intro tm_append_second_steps_eq)
-       apply(auto simp: assms bexec)
+       apply(auto simp: assms)
     done
   ultimately show "steps (s, l, r) (A @ shift B off, 0) (stpa + stpb) = (sb + off, lb, rb)"
-    apply(simp add: steps_add off)
+    apply(simp add: off)
     done
 qed
 
-subsection \<open>Crsp of Inc\<close>
+subsection \<open>Compilation of instruction Inc\<close>
 
 fun at_begin_fst_bwtn :: "inc_inv_t"
   where
     "at_begin_fst_bwtn (as, lm) (s, l, r) ires = 
       (\<exists> lm1 tn rn. lm1 = (lm @ 0\<up>tn) \<and> length lm1 = s \<and> 
           (if lm1 = [] then l = Bk # Bk # ires
            else l = [Bk]@<rev lm1>@Bk#Bk#ires) \<and> r = Bk\<up>rn)" 
 
 
 fun at_begin_fst_awtn :: "inc_inv_t"
   where
     "at_begin_fst_awtn (as, lm) (s, l, r) ires = 
       (\<exists> lm1 tn rn. lm1 = (lm @ 0\<up>tn) \<and> length lm1 = s \<and>
          (if lm1 = []  then l = Bk # Bk # ires
           else l = [Bk]@<rev lm1>@Bk#Bk#ires) \<and> r = [Oc]@Bk\<up>rn)"
 
 fun at_begin_norm :: "inc_inv_t"
   where
     "at_begin_norm (as, lm) (s, l, r) ires= 
       (\<exists> lm1 lm2 rn. lm = lm1 @ lm2 \<and> length lm1 = s \<and> 
         (if lm1 = [] then l = Bk # Bk # ires
          else l = Bk # <rev lm1> @ Bk # Bk # ires ) \<and> r = <lm2>@Bk\<up>rn)"
 
 fun in_middle :: "inc_inv_t"
   where
     "in_middle (as, lm) (s, l, r) ires = 
       (\<exists> lm1 lm2 tn m ml mr rn. lm @ 0\<up>tn = lm1 @ [m] @ lm2
        \<and> length lm1 = s \<and> m + 1 = ml + mr \<and>  
          ml \<noteq> 0 \<and> tn = s + 1 - length lm \<and> 
        (if lm1 = [] then l = Oc\<up>ml @ Bk # Bk # ires 
         else l = Oc\<up>ml@[Bk]@<rev lm1>@
                  Bk # Bk # ires) \<and> (r = Oc\<up>mr @ [Bk] @ <lm2>@ Bk\<up>rn \<or> 
       (lm2 = [] \<and> r = Oc\<up>mr))
       )"
 
 fun inv_locate_a :: "inc_inv_t"
   where "inv_locate_a (as, lm) (s, l, r) ires = 
      (at_begin_norm (as, lm) (s, l, r) ires \<or>
       at_begin_fst_bwtn (as, lm) (s, l, r) ires \<or>
       at_begin_fst_awtn (as, lm) (s, l, r) ires
       )"
 
 fun inv_locate_b :: "inc_inv_t"
   where "inv_locate_b (as, lm) (s, l, r) ires = 
         (in_middle (as, lm) (s, l, r)) ires "
 
 fun inv_after_write :: "inc_inv_t"
   where "inv_after_write (as, lm) (s, l, r) ires = 
            (\<exists> rn m lm1 lm2. lm = lm1 @ m # lm2 \<and>
              (if lm1 = [] then l = Oc\<up>m @ Bk # Bk # ires
               else Oc # l = Oc\<up>Suc m@ Bk # <rev lm1> @ 
                       Bk # Bk # ires) \<and> r = [Oc] @ <lm2> @ Bk\<up>rn)"
 
 fun inv_after_move :: "inc_inv_t"
   where "inv_after_move (as, lm) (s, l, r) ires = 
       (\<exists> rn m lm1 lm2. lm = lm1 @ m # lm2 \<and>
         (if lm1 = [] then l = Oc\<up>Suc m @ Bk # Bk # ires
          else l = Oc\<up>Suc m@ Bk # <rev lm1> @ Bk # Bk # ires) \<and> 
         r = <lm2> @ Bk\<up>rn)"
 
 fun inv_after_clear :: "inc_inv_t"
   where "inv_after_clear (as, lm) (s, l, r) ires =
        (\<exists> rn m lm1 lm2 r'. lm = lm1 @ m # lm2 \<and> 
         (if lm1 = [] then l = Oc\<up>Suc m @ Bk # Bk # ires
          else l = Oc\<up>Suc m @ Bk # <rev lm1> @ Bk # Bk # ires) \<and> 
           r = Bk # r' \<and> Oc # r' = <lm2> @ Bk\<up>rn)"
 
 fun inv_on_right_moving :: "inc_inv_t"
   where "inv_on_right_moving (as, lm) (s, l, r) ires = 
        (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and> 
             ml + mr = m \<and> 
           (if lm1 = [] then l = Oc\<up>ml @ Bk # Bk # ires
           else l = Oc\<up>ml  @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and> 
          ((r = Oc\<up>mr @ [Bk] @ <lm2> @ Bk\<up>rn) \<or> 
           (r = Oc\<up>mr \<and> lm2 = [])))"
 
 fun inv_on_left_moving_norm :: "inc_inv_t"
   where "inv_on_left_moving_norm (as, lm) (s, l, r) ires =
       (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and>  
              ml + mr = Suc m \<and> mr > 0 \<and> (if lm1 = [] then l = Oc\<up>ml @ Bk # Bk # ires
                                          else l =  Oc\<up>ml @ Bk # <rev lm1> @ Bk # Bk # ires)
         \<and> (r = Oc\<up>mr @ Bk # <lm2> @ Bk\<up>rn \<or> 
            (lm2 = [] \<and> r = Oc\<up>mr)))"
 
 fun inv_on_left_moving_in_middle_B:: "inc_inv_t"
   where "inv_on_left_moving_in_middle_B (as, lm) (s, l, r) ires =
                 (\<exists> lm1 lm2 rn. lm = lm1 @ lm2 \<and>  
                      (if lm1 = [] then l = Bk # ires
                       else l = <rev lm1> @ Bk # Bk # ires) \<and> 
                       r = Bk # <lm2> @ Bk\<up>rn)"
 
 fun inv_on_left_moving :: "inc_inv_t"
   where "inv_on_left_moving (as, lm) (s, l, r) ires = 
        (inv_on_left_moving_norm  (as, lm) (s, l, r) ires \<or>
         inv_on_left_moving_in_middle_B (as, lm) (s, l, r) ires)"
 
 
 fun inv_check_left_moving_on_leftmost :: "inc_inv_t"
   where "inv_check_left_moving_on_leftmost (as, lm) (s, l, r) ires = 
                 (\<exists> rn. l = ires \<and> r = [Bk, Bk] @ <lm> @  Bk\<up>rn)"
 
 fun inv_check_left_moving_in_middle :: "inc_inv_t"
   where "inv_check_left_moving_in_middle (as, lm) (s, l, r) ires = 
               (\<exists> lm1 lm2 r' rn. lm = lm1 @ lm2 \<and>
                  (Oc # l = <rev lm1> @ Bk # Bk # ires) \<and> r = Oc # Bk # r' \<and> 
                            r' = <lm2> @  Bk\<up>rn)"
 
 fun inv_check_left_moving :: "inc_inv_t"
   where "inv_check_left_moving (as, lm) (s, l, r) ires = 
              (inv_check_left_moving_on_leftmost (as, lm) (s, l, r) ires \<or>
              inv_check_left_moving_in_middle (as, lm) (s, l, r) ires)"
 
 fun inv_after_left_moving :: "inc_inv_t"
   where "inv_after_left_moving (as, lm) (s, l, r) ires= 
               (\<exists> rn. l = Bk # ires \<and> r = Bk # <lm> @  Bk\<up>rn)"
 
 fun inv_stop :: "inc_inv_t"
   where "inv_stop (as, lm) (s, l, r) ires= 
               (\<exists> rn. l = Bk # Bk # ires \<and> r = <lm> @  Bk\<up>rn)"
 
 lemma halt_lemma2': 
   "\<lbrakk>wf LE;  \<forall> n. ((\<not> P (f n) \<and> Q (f n)) \<longrightarrow> 
     (Q (f (Suc n)) \<and> (f (Suc n), (f n)) \<in> LE)); Q (f 0)\<rbrakk> 
       \<Longrightarrow> \<exists> n. P (f n)"
   apply(intro exCI, simp)
   apply(subgoal_tac "\<forall> n. Q (f n)")
    apply(drule_tac f = f in wf_inv_image)
    apply(erule wf_induct)
    apply(auto)
   apply(rename_tac n,induct_tac n; simp)
   done
 
 lemma halt_lemma2'': 
   "\<lbrakk>P (f n); \<not> P (f (0::nat))\<rbrakk> \<Longrightarrow> 
          \<exists> n. (P (f n) \<and> (\<forall> i < n. \<not> P (f i)))"
   apply(induct n rule: nat_less_induct, auto)
   done
 
 lemma halt_lemma2''':
   "\<lbrakk>\<forall>n. \<not> P (f n) \<and> Q (f n) \<longrightarrow> Q (f (Suc n)) \<and> (f (Suc n), f n) \<in> LE;
                  Q (f 0);  \<forall>i<na. \<not> P (f i)\<rbrakk> \<Longrightarrow> Q (f na)"
   apply(induct na, simp, simp)
   done
 
 lemma halt_lemma2: 
   "\<lbrakk>wf LE;  
     Q (f 0); \<not> P (f 0);
     \<forall> n. ((\<not> P (f n) \<and> Q (f n)) \<longrightarrow> (Q (f (Suc n)) \<and> (f (Suc n), (f n)) \<in> LE))\<rbrakk> 
   \<Longrightarrow> \<exists> n. P (f n) \<and> Q (f n)"
   apply(insert halt_lemma2' [of LE P f Q], simp, erule_tac exE)
   apply(subgoal_tac "\<exists> n. (P (f n) \<and> (\<forall> i < n. \<not> P (f i)))")
    apply(erule_tac exE)+
    apply(rename_tac n na)
    apply(rule_tac x = na in exI, auto)
    apply(rule halt_lemma2''', simp, simp, simp)
   apply(erule_tac halt_lemma2'', simp)
   done
 
 
 fun findnth_inv :: "layout \<Rightarrow> nat \<Rightarrow> inc_inv_t"
   where
     "findnth_inv ly n (as, lm) (s, l, r) ires =
               (if s = 0 then False
                else if s \<le> Suc (2*n) then 
                   if s mod 2 = 1 then inv_locate_a (as, lm) ((s - 1) div 2, l, r) ires
                   else inv_locate_b (as, lm) ((s - 1) div 2, l, r) ires
                else False)"
 
 
 fun findnth_state :: "config \<Rightarrow> nat \<Rightarrow> nat"
   where
     "findnth_state (s, l, r) n = (Suc (2*n) - s)"
 
 fun findnth_step :: "config \<Rightarrow> nat \<Rightarrow> nat"
   where
     "findnth_step (s, l, r) n = 
            (if s mod 2 = 1 then
                    (if (r \<noteq> [] \<and> hd r = Oc) then 0
                     else 1)
             else length r)"
 
 fun findnth_measure :: "config \<times> nat \<Rightarrow> nat \<times> nat"
   where
     "findnth_measure (c, n) = 
      (findnth_state c n, findnth_step c n)"
 
 definition lex_pair :: "((nat \<times> nat) \<times> nat \<times> nat) set"
   where
     "lex_pair \<equiv> less_than <*lex*> less_than"
 
 definition findnth_LE :: "((config \<times> nat) \<times> (config \<times> nat)) set"
   where
     "findnth_LE \<equiv> (inv_image lex_pair findnth_measure)"
 
 lemma wf_findnth_LE: "wf findnth_LE"
   by(auto simp: findnth_LE_def lex_pair_def)
 
 declare findnth_inv.simps[simp del]
 
 lemma x_is_2n_arith[simp]: 
   "\<lbrakk>x < Suc (Suc (2 * n)); Suc x mod 2 = Suc 0; \<not> x < 2 * n\<rbrakk>
  \<Longrightarrow> x = 2*n"
   by arith
 
 
 lemma between_sucs:"x < Suc n \<Longrightarrow> \<not> x < n \<Longrightarrow> x = n" by auto
 
 lemma fetch_findnth[simp]: 
   "\<lbrakk>0 < a; a < Suc (2 * n); a mod 2 = Suc 0\<rbrakk> \<Longrightarrow> fetch (findnth n) a Oc = (R, Suc a)"
   "\<lbrakk>0 < a; a < Suc (2 * n); a mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow> fetch (findnth n) a Oc = (R, a)"
   "\<lbrakk>0 < a; a < Suc (2 * n); a mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow> fetch (findnth n) a Bk = (R, Suc a)"
-  "\<lbrakk>0 < a; a < Suc (2 * n); a mod 2 = Suc 0\<rbrakk> \<Longrightarrow> fetch (findnth n) a Bk = (W1, a)"
+  "\<lbrakk>0 < a; a < Suc (2 * n); a mod 2 = Suc 0\<rbrakk> \<Longrightarrow> fetch (findnth n) a Bk = (WO, a)"
   by(cases a;induct n;force simp: length_findnth nth_append dest!:between_sucs)+
 
 declare at_begin_norm.simps[simp del] at_begin_fst_bwtn.simps[simp del] 
   at_begin_fst_awtn.simps[simp del] in_middle.simps[simp del] 
   abc_lm_s.simps[simp del] abc_lm_v.simps[simp del]  
-  ci.simps[simp del] inv_after_move.simps[simp del] 
+  inv_after_move.simps[simp del] 
   inv_on_left_moving_norm.simps[simp del] 
   inv_on_left_moving_in_middle_B.simps[simp del]
   inv_after_clear.simps[simp del] 
   inv_after_write.simps[simp del] inv_on_left_moving.simps[simp del]
   inv_on_right_moving.simps[simp del] 
   inv_check_left_moving.simps[simp del] 
   inv_check_left_moving_in_middle.simps[simp del]
   inv_check_left_moving_on_leftmost.simps[simp del] 
   inv_after_left_moving.simps[simp del]
   inv_stop.simps[simp del] inv_locate_a.simps[simp del] 
   inv_locate_b.simps[simp del]
 
 lemma replicate_once[intro]: "\<exists>rn. [Bk] = Bk \<up> rn"
   by (metis replicate.simps)
 
 lemma at_begin_norm_Bk[intro]:  "at_begin_norm (as, am) (q, aaa, []) ires
              \<Longrightarrow> at_begin_norm (as, am) (q, aaa, [Bk]) ires"
   apply(simp add: at_begin_norm.simps)
   by fastforce
 
 lemma at_begin_fst_bwtn_Bk[intro]: "at_begin_fst_bwtn (as, am) (q, aaa, []) ires 
             \<Longrightarrow> at_begin_fst_bwtn (as, am) (q, aaa, [Bk]) ires"
   apply(simp only: at_begin_fst_bwtn.simps)
   using replicate_once by blast
 
 lemma at_begin_fst_awtn_Bk[intro]: "at_begin_fst_awtn (as, am) (q, aaa, []) ires
            \<Longrightarrow> at_begin_fst_awtn (as, am) (q, aaa, [Bk]) ires"
   apply(auto simp: at_begin_fst_awtn.simps)
   done 
 
 lemma inv_locate_a_Bk[intro]: "inv_locate_a (as, am) (q, aaa, []) ires
             \<Longrightarrow> inv_locate_a (as, am) (q, aaa, [Bk]) ires"
   apply(simp only: inv_locate_a.simps)
   apply(erule disj_forward)
    defer
    apply(erule disj_forward, auto)
   done
 
 lemma locate_a_2_locate_a[simp]: "inv_locate_a (as, am) (q, aaa, Bk # xs) ires
        \<Longrightarrow> inv_locate_a (as, am) (q, aaa, Oc # xs) ires"
   apply(simp only: inv_locate_a.simps at_begin_norm.simps 
       at_begin_fst_bwtn.simps at_begin_fst_awtn.simps)
   apply(erule_tac disjE, erule exE, erule exE, erule exE, 
       rule disjI2, rule disjI2)
    defer
    apply(erule_tac disjE, erule exE, erule exE, 
       erule exE, rule disjI2, rule disjI2)
     prefer 2
     apply(simp)
 proof-
   fix lm1 tn rn
   assume k: "lm1 = am @ 0\<up>tn \<and> length lm1 = q \<and> (if lm1 = [] then aaa = Bk # Bk # 
     ires else aaa = [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and> Bk # xs = Bk\<up>rn"
   thus "\<exists>lm1 tn rn. lm1 = am @ 0 \<up> tn \<and> length lm1 = q \<and> 
     (if lm1 = [] then aaa = Bk # Bk # ires else aaa = [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and> Oc # xs = [Oc] @ Bk \<up> rn"
     (is "\<exists>lm1 tn rn. ?P lm1 tn rn")
   proof -
     from k have "?P lm1 tn (rn - 1)"
       by (auto simp: Cons_replicate_eq)
     thus ?thesis by blast
   qed
 next
   fix lm1 lm2 rn
   assume h1: "am = lm1 @ lm2 \<and> length lm1 = q \<and> (if lm1 = [] 
     then aaa = Bk # Bk # ires else aaa = Bk # <rev lm1> @ Bk # Bk # ires) \<and>
     Bk # xs = <lm2> @ Bk\<up>rn"
   from h1 have h2: "lm2 = []"
     apply(auto split: if_splits;cases lm2;simp add: tape_of_nl_cons split: if_splits)
     done
   from h1 and h2 show "\<exists>lm1 tn rn. lm1 = am @ 0\<up>tn \<and> length lm1 = q \<and> 
     (if lm1 = [] then aaa = Bk # Bk # ires else aaa = [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and>
     Oc # xs = [Oc] @ Bk\<up>rn" 
     (is "\<exists>lm1 tn rn. ?P lm1 tn rn")
   proof -
     from h1 and h2  have "?P lm1 0 (rn - 1)"
       apply(auto simp:tape_of_nat_def)
       by(cases rn, simp, simp)
     thus ?thesis by blast
   qed
 qed
 
 lemma inv_locate_a[simp]: "inv_locate_a (as, am) (q, aaa, []) ires \<Longrightarrow> 
                inv_locate_a (as, am) (q, aaa, [Oc]) ires"
   apply(insert locate_a_2_locate_a [of as am q aaa "[]"])
   apply(subgoal_tac "inv_locate_a (as, am) (q, aaa, [Bk]) ires", auto)
   done
 
 (*inv: from locate_b to locate_b*)
 lemma inv_locate_b[simp]: "inv_locate_b (as, am) (q, aaa, Oc # xs) ires
          \<Longrightarrow> inv_locate_b (as, am) (q, Oc # aaa, xs) ires"
   apply(simp only: inv_locate_b.simps in_middle.simps)
   apply(erule exE)+
   apply(rename_tac lm1 lm2 tn m ml mr rn)
   apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, 
       rule_tac x = tn in exI, rule_tac x = m in exI)
   apply(rule_tac x = "Suc ml" in exI, rule_tac x = "mr - 1" in exI,
       rule_tac x = rn in exI)
   apply(case_tac mr)
   apply simp_all
   done
 
 lemma tape_nat[simp]:  "<[x::nat]> = Oc\<up>(Suc x)"
   apply(simp add: tape_of_nat_def tape_of_list_def)
   done
 
 lemma inv_locate[simp]: "\<lbrakk>inv_locate_b (as, am) (q, aaa, Bk # xs) ires; \<exists>n. xs = Bk\<up>n\<rbrakk>
             \<Longrightarrow> inv_locate_a (as, am) (Suc q, Bk # aaa, xs) ires"
   apply(simp add: inv_locate_b.simps inv_locate_a.simps)
   apply(rule_tac disjI2, rule_tac disjI1)
   apply(simp only: in_middle.simps at_begin_fst_bwtn.simps)
   apply(erule_tac exE)+
   apply(rename_tac lm1 n lm2 tn m ml mr rn)
   apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = tn in exI, simp split: if_splits)
-   apply(case_tac mr, simp_all)
-   apply(cases "length am", simp_all)
-   apply(case_tac lm2, simp_all add: tape_of_nl_cons split: if_splits)
-     apply(cases am, simp_all)
-    apply(case_tac n, simp_all)
-   apply(case_tac n, simp_all)
+  apply(case_tac mr, simp_all)
+  apply(cases "length am", simp_all)
+  apply(case_tac lm2, simp_all add: tape_of_nl_cons split: if_splits)
+  apply(cases am, simp_all)
+  apply(case_tac n, simp_all)
+  apply(case_tac n, simp_all)
   apply(case_tac mr, simp_all)
   apply(case_tac lm2, simp_all add: tape_of_nl_cons split: if_splits, auto)
-   apply(case_tac [!] n, simp_all)
+  apply(case_tac [!] n, simp_all)
   done
 
 lemma repeat_Bk_no_Oc[simp]: "(Oc # r = Bk \<up> rn) = False"
   apply(cases rn, simp_all)
   done
 
 lemma repeat_Bk[simp]: "(\<exists>rna. Bk \<up> rn = Bk # Bk \<up> rna) \<or> rn = 0"
   apply(cases rn, auto)
   done
 
 lemma inv_locate_b_Oc_via_a[simp]: 
   assumes "inv_locate_a (as, lm) (q, l, Oc # r) ires"
   shows "inv_locate_b (as, lm) (q, Oc # l, r) ires"
 proof -
   show ?thesis using assms unfolding inv_locate_a.simps inv_locate_b.simps
       at_begin_norm.simps at_begin_fst_bwtn.simps at_begin_fst_awtn.simps
     apply(simp only:in_middle.simps)
     apply(erule disjE, erule exE, erule exE, erule exE)
      apply(rename_tac Lm1 Lm2 Rn)
      apply(rule_tac x = Lm1 in exI, rule_tac x = "tl Lm2" in exI)
      apply(rule_tac x = 0 in exI, rule_tac x = "hd Lm2" in exI)
      apply(rule_tac x = 1 in exI, rule_tac x = "hd Lm2" in exI)
      apply(case_tac Lm2, force simp: tape_of_nl_cons )
      apply(case_tac "tl Lm2", simp_all)
      apply(case_tac Rn, auto simp: tape_of_nl_cons )
     apply(rename_tac tn rn)
     apply(rule_tac x = "lm @ replicate tn 0" in exI, 
         rule_tac x = "[]" in exI, 
         rule_tac x = "Suc tn" in exI, 
         rule_tac x = 0 in exI, auto simp add: replicate_append_same)
     apply(rule_tac x = "Suc 0" in exI, auto)
     done
 qed
 
 lemma length_equal: "xs = ys \<Longrightarrow> length xs = length ys"
   by auto
 
 lemma inv_locate_a_Bk_via_b[simp]: "\<lbrakk>inv_locate_b (as, am) (q, aaa, Bk # xs) ires; 
                 \<not> (\<exists>n. xs = Bk\<up>n)\<rbrakk> 
        \<Longrightarrow> inv_locate_a (as, am) (Suc q, Bk # aaa, xs) ires"
   supply [[simproc del: defined_all]]
   apply(simp add: inv_locate_b.simps inv_locate_a.simps)
   apply(rule_tac disjI1)
   apply(simp only: in_middle.simps at_begin_norm.simps)
   apply(erule_tac exE)+
   apply(rename_tac lm1 lm2 tn m ml mr rn)
   apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = lm2 in exI, simp)
   apply(subgoal_tac "tn = 0", simp , auto split: if_splits)
-    apply(simp add: tape_of_nl_cons)
-   apply(drule_tac length_equal, simp)
-   apply(cases "length am", simp_all, erule_tac x = rn in allE, simp)
+  apply(simp add: tape_of_nl_cons)
+  apply(drule_tac length_equal, simp)
+  apply(cases "length am", simp_all, erule_tac x = rn in allE, simp)
   apply(drule_tac length_equal, simp)
   apply(case_tac "(Suc (length lm1) - length am)", simp_all)
   apply(case_tac lm2, simp, simp)
   done
 
 lemma locate_b_2_a[intro]: 
   "inv_locate_b (as, am) (q, aaa, Bk # xs) ires
     \<Longrightarrow> inv_locate_a (as, am) (Suc q, Bk # aaa, xs) ires"
   apply(cases "\<exists> n. xs = Bk\<up>n", simp, simp)
   done
 
 
 lemma inv_locate_b_Bk[simp]:  "inv_locate_b (as, am) (q, l, []) ires 
            \<Longrightarrow>  inv_locate_b (as, am) (q, l, [Bk]) ires"
   by(force simp add: inv_locate_b.simps in_middle.simps)
 
 (*inv: from locate_b to after_write*)
 
 lemma div_rounding_down[simp]: "(2*q - Suc 0) div 2 = (q - 1)" "(Suc (2*q)) div 2 = q"
   by arith+
 
 lemma even_plus_one_odd[simp]: "x mod 2 = 0 \<Longrightarrow> Suc x mod 2 = Suc 0"
   by arith
 
 lemma odd_plus_one_even[simp]: "x mod 2 = Suc 0 \<Longrightarrow> Suc x mod 2 = 0"
   by arith
 
 lemma locate_b_2_locate_a[simp]: 
   "\<lbrakk>q > 0;  inv_locate_b (as, am) (q - Suc 0, aaa, Bk # xs) ires\<rbrakk>
    \<Longrightarrow>  inv_locate_a (as, am) (q, Bk # aaa, xs) ires"
   apply(insert locate_b_2_a [of as am "q - 1" aaa xs ires], simp)
   done
 
 (*inv: from locate_b to after_write*)
 
 lemma findnth_inv_layout_of_via_crsp[simp]:
   "crsp (layout_of ap) (as, lm) (s, l, r) ires
   \<Longrightarrow> findnth_inv (layout_of ap) n (as, lm) (Suc 0, l, r) ires"
   by(auto simp: crsp.simps findnth_inv.simps inv_locate_a.simps
       at_begin_norm.simps at_begin_fst_awtn.simps at_begin_fst_bwtn.simps)
 
 lemma findnth_correct_pre: 
   assumes layout: "ly = layout_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
     and not0: "n > 0"
     and f: "f = (\<lambda> stp. (steps (Suc 0, l, r) (findnth n, 0) stp, n))"
     and P: "P = (\<lambda> ((s, l, r), n). s = Suc (2 * n))"
     and Q: "Q = (\<lambda> ((s, l, r), n). findnth_inv ly n (as, lm) (s, l, r) ires)"
   shows "\<exists> stp. P (f stp) \<and> Q (f stp)"
 proof(rule_tac LE = findnth_LE in halt_lemma2)
   show "wf findnth_LE"  by(intro wf_findnth_LE)
 next
   show "Q (f 0)"
     using crsp layout
     apply(simp add: f P Q steps.simps)
     done
 next
   show "\<not> P (f 0)"
     using not0
     apply(simp add: f P steps.simps)
     done
 next
   have "\<not> P (f na) \<and> Q (f na) \<Longrightarrow> Q (f (Suc na)) \<and> (f (Suc na), f na) 
         \<in> findnth_LE" for na
   proof(simp add: f, 
       cases "steps (Suc 0, l, r) (findnth n, 0) na", simp add: P)
     fix na a b c
     assume "a \<noteq> Suc (2 * n) \<and> Q ((a, b, c), n)"
     thus  "Q (step (a, b, c) (findnth n, 0), n) \<and> 
         ((step (a, b, c) (findnth n, 0), n), (a, b, c), n) \<in> findnth_LE"
       apply(cases c, case_tac [2] "hd c")
         apply(simp_all add: step.simps findnth_LE_def Q findnth_inv.simps mod_2  lex_pair_def split: if_splits)
          apply(auto simp: mod_ex1 mod_ex2)
       done
   qed
   thus "\<forall>n. \<not> P (f n) \<and> Q (f n) \<longrightarrow>
         Q (f (Suc n)) \<and> (f (Suc n), f n) \<in> findnth_LE" by blast
 qed
 
 lemma inv_locate_a_via_crsp[simp]:
   "crsp ly (as, lm) (s, l, r) ires \<Longrightarrow> inv_locate_a (as, lm) (0, l, r) ires"
   apply(auto simp: crsp.simps inv_locate_a.simps at_begin_norm.simps)
   done
 
 lemma findnth_correct: 
   assumes layout: "ly = layout_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
   shows "\<exists> stp l' r'. steps (Suc 0, l, r) (findnth n, 0) stp = (Suc (2 * n), l', r')
               \<and> inv_locate_a (as, lm) (n, l', r') ires"
   using crsp
   apply(cases "n = 0")
    apply(rule_tac x = 0 in exI, auto simp: steps.simps)
   using assms
   apply(drule_tac findnth_correct_pre, auto)
   using findnth_inv.simps by auto
 
 fun inc_inv :: "nat \<Rightarrow> inc_inv_t"
   where
     "inc_inv n (as, lm) (s, l, r) ires =
               (let lm' = abc_lm_s lm n (Suc (abc_lm_v lm n)) in
                 if s = 0 then False
                 else if s = 1 then 
                    inv_locate_a (as, lm) (n, l, r) ires
                 else if s = 2 then 
                    inv_locate_b (as, lm) (n, l, r) ires
                 else if s = 3 then 
                    inv_after_write (as, lm') (s, l, r) ires
                 else if s = Suc 3 then 
                    inv_after_move (as, lm') (s, l, r) ires
                 else if s = Suc 4 then 
                    inv_after_clear (as, lm') (s, l, r) ires
                 else if s = Suc (Suc 4) then 
                    inv_on_right_moving (as, lm') (s, l, r) ires
                 else if s = Suc (Suc 5) then 
                    inv_on_left_moving (as, lm') (s, l, r) ires
                 else if s = Suc (Suc (Suc 5)) then 
                    inv_check_left_moving (as, lm') (s, l, r) ires
                 else if s = Suc (Suc (Suc (Suc 5))) then 
                    inv_after_left_moving (as, lm') (s, l, r) ires
                 else if s = Suc (Suc (Suc (Suc (Suc 5)))) then 
                    inv_stop (as, lm') (s, l, r) ires
                 else False)"
 
 
 fun abc_inc_stage1 :: "config \<Rightarrow> nat"
   where
     "abc_inc_stage1 (s, l, r) = 
             (if s = 0 then 0
              else if s \<le> 2 then 5
              else if s \<le> 6 then 4
              else if s \<le> 8 then 3
              else if s = 9 then 2
              else 1)"
 
 fun abc_inc_stage2 :: "config \<Rightarrow> nat"
   where
     "abc_inc_stage2 (s, l, r) =
                 (if s = 1 then 2
                  else if s = 2 then 1
                  else if s = 3 then length r
                  else if s = 4 then length r
                  else if s = 5 then length r
                  else if s = 6 then 
                                   if r \<noteq> [] then length r
                                   else 1
                  else if s = 7 then length l
                  else if s = 8 then length l
                  else 0)"
 
 fun abc_inc_stage3 :: "config \<Rightarrow>  nat"
   where
     "abc_inc_stage3 (s, l, r) = (
               if s = 4 then 4
               else if s = 5 then 3
               else if s = 6 then 
                    if r \<noteq> [] \<and> hd r = Oc then 2
                    else 1
               else if s = 3 then 0
               else if s = 2 then length r
               else if s = 1 then 
                       if (r \<noteq> [] \<and> hd r = Oc) then 0
                       else 1
               else 10 - s)"
 
 
 definition inc_measure :: "config \<Rightarrow> nat \<times> nat \<times> nat"
   where
     "inc_measure c = 
     (abc_inc_stage1 c, abc_inc_stage2 c, abc_inc_stage3 c)"
 
 definition lex_triple :: 
   "((nat \<times> (nat \<times> nat)) \<times> (nat \<times> (nat \<times> nat))) set"
   where "lex_triple \<equiv> less_than <*lex*> lex_pair"
 
 definition inc_LE :: "(config \<times> config) set"
   where
     "inc_LE \<equiv> (inv_image lex_triple inc_measure)"
 
 declare inc_inv.simps[simp del]
 
 lemma wf_inc_le[intro]: "wf inc_LE"
   by(auto simp: inc_LE_def lex_triple_def lex_pair_def)
 
 lemma inv_locate_b_2_after_write[simp]:
   assumes "inv_locate_b (as, am) (n, aaa, Bk # xs) ires"
   shows "inv_after_write (as, abc_lm_s am n (Suc (abc_lm_v am n))) (s, aaa, Oc # xs) ires"
 proof -
   from assms show ?thesis
     apply(auto simp: in_middle.simps inv_after_write.simps 
         abc_lm_v.simps abc_lm_s.simps inv_locate_b.simps simp del:split_head_repeat)
      apply(rename_tac lm1 lm2 m ml mr rn)
      apply(case_tac [!] mr, auto split: if_splits)
     apply(rename_tac lm1 lm2 m rn)
     apply(rule_tac x = rn in exI, rule_tac x = "Suc m" in exI,
         rule_tac x = "lm1" in exI, simp)
     apply(rule_tac x = "lm2" in exI)
     apply(simp only: Suc_diff_le exp_ind)
     by(subgoal_tac "lm2 = []"; force dest:length_equal)
 qed
 
 (*inv: from after_write to after_move*)
 lemma inv_after_move_Oc_via_write[simp]: "inv_after_write (as, lm) (x, l, Oc # r) ires
                 \<Longrightarrow> inv_after_move (as, lm) (y, Oc # l, r) ires"
   apply(auto simp:inv_after_move.simps inv_after_write.simps split: if_splits)
   done
 
 lemma inv_after_write_Suc[simp]: "inv_after_write (as, abc_lm_s am n (Suc (abc_lm_v am n)
                 )) (x, aaa, Bk # xs) ires = False"
   "inv_after_write (as, abc_lm_s am n (Suc (abc_lm_v am n))) 
                         (x, aaa, []) ires = False"
    apply(auto simp: inv_after_write.simps )
   done
 
 (*inv: from after_move to after_clear*)
 lemma inv_after_clear_Bk_via_Oc[simp]: "inv_after_move (as, lm) (s, l, Oc # r) ires
                 \<Longrightarrow> inv_after_clear (as, lm) (s', l, Bk # r) ires"
   apply(auto simp: inv_after_move.simps inv_after_clear.simps split: if_splits)
   done
 
 
 lemma inv_after_move_2_inv_on_left_moving[simp]:  
   assumes "inv_after_move (as, lm) (s, l, Bk # r) ires"
   shows "(l = [] \<longrightarrow> 
          inv_on_left_moving (as, lm) (s', [], Bk # Bk # r) ires) \<and>
       (l \<noteq> [] \<longrightarrow> 
          inv_on_left_moving (as, lm) (s', tl l, hd l # Bk # r) ires)"
 proof (cases l)
   case (Cons a list)
   from assms Cons show ?thesis
     apply(simp only: inv_after_move.simps inv_on_left_moving.simps)
     apply(rule conjI, force, rule impI, rule disjI1, simp only: inv_on_left_moving_norm.simps)
     apply(erule exE)+
     apply(rename_tac rn m lm1 lm2)
     apply(subgoal_tac "lm2 = []")
      apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,  
         rule_tac x = m in exI, rule_tac x = m in exI, 
         rule_tac x = 1 in exI,  
         rule_tac x = "rn - 1" in exI)
      apply (auto split:if_splits)
        apply(case_tac [1-2] rn, simp_all)
     by(case_tac [!] lm2, simp_all add: tape_of_nl_cons split: if_splits)
 next
   case Nil thus ?thesis using assms
     unfolding inv_after_move.simps inv_on_left_moving.simps
     by (auto split:if_splits)
 qed
 
 
 lemma inv_after_move_2_inv_on_left_moving_B[simp]: 
   "inv_after_move (as, lm) (s, l, []) ires
       \<Longrightarrow> (l = [] \<longrightarrow> inv_on_left_moving (as, lm) (s', [], [Bk]) ires) \<and>
           (l \<noteq> [] \<longrightarrow> inv_on_left_moving (as, lm) (s', tl l, [hd l]) ires)"
   apply(simp only: inv_after_move.simps inv_on_left_moving.simps)
   apply(subgoal_tac "l \<noteq> []", rule conjI, simp, rule impI, rule disjI1,
       simp only: inv_on_left_moving_norm.simps)
    apply(erule exE)+
    apply(rename_tac rn m lm1 lm2)
    apply(subgoal_tac "lm2 = []")
     apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,  
       rule_tac x = m in exI, rule_tac x = m in exI, 
       rule_tac x = 1 in exI, rule_tac x = "rn - 1" in exI, force)
    apply(metis append_Cons list.distinct(1) list.exhaust replicate_Suc tape_of_nl_cons)
   apply(metis append_Cons list.distinct(1) replicate_Suc)
   done
 
 lemma inv_after_clear_2_inv_on_right_moving[simp]: 
   "inv_after_clear (as, lm) (x, l, Bk # r) ires
       \<Longrightarrow> inv_on_right_moving (as, lm) (y, Bk # l, r) ires"
   apply(auto simp: inv_after_clear.simps inv_on_right_moving.simps simp del:split_head_repeat)
   apply(rename_tac rn m lm1 lm2)
   apply(subgoal_tac "lm2 \<noteq> []")
    apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = "tl lm2" in exI, 
       rule_tac x = "hd lm2" in exI, simp del:split_head_repeat)
    apply(rule_tac x = 0 in exI, rule_tac x = "hd lm2" in exI)
    apply(simp, rule conjI)
     apply(case_tac [!] "lm2::nat list", auto)
     apply(case_tac rn, auto split: if_splits simp: tape_of_nl_cons)
    apply(case_tac [!] rn, simp_all)
   done
 
 (*inv: from on_right_moving to on_right_moving*)
 lemma inv_on_right_moving_Oc[simp]: "inv_on_right_moving (as, lm) (x, l, Oc # r) ires
       \<Longrightarrow> inv_on_right_moving (as, lm) (y, Oc # l, r) ires"
   apply(auto simp: inv_on_right_moving.simps)
    apply(rename_tac lm1 lm2 ml mr rn)
    apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, 
       rule_tac x = "ml + mr" in exI, simp)
    apply(rule_tac x = "Suc ml" in exI, 
       rule_tac x = "mr - 1" in exI, simp) 
    apply (metis One_nat_def Suc_pred cell.distinct(1) empty_replicate list.inject
       list.sel(3) neq0_conv self_append_conv2 tl_append2 tl_replicate)
   apply(rule_tac x = lm1 in exI, rule_tac x = "[]" in exI, 
       rule_tac x = "ml + mr" in exI, simp)
   apply(rule_tac x = "Suc ml" in exI, 
       rule_tac x = "mr - 1" in exI)
   apply (auto simp add: Cons_replicate_eq)
   done
 
 lemma inv_on_right_moving_2_inv_on_right_moving[simp]: 
   "inv_on_right_moving (as, lm) (x, l, Bk # r) ires
      \<Longrightarrow> inv_after_write (as, lm) (y, l, Oc # r) ires"
   apply(auto simp: inv_on_right_moving.simps inv_after_write.simps)
   by (metis append.left_neutral append_Cons )
 
 lemma inv_on_right_moving_singleton_Bk[simp]: "inv_on_right_moving (as, lm) (x, l, []) ires\<Longrightarrow> 
              inv_on_right_moving (as, lm) (y, l, [Bk]) ires"
   apply(auto simp: inv_on_right_moving.simps)
   by fastforce
 
 (*inv: from on_left_moving to on_left_moving*)
 lemma no_inv_on_left_moving_in_middle_B_Oc[simp]: "inv_on_left_moving_in_middle_B (as, lm) 
                (s, l, Oc # r) ires = False"
   by(auto simp: inv_on_left_moving_in_middle_B.simps )
 
 lemma no_inv_on_left_moving_norm_Bk[simp]: "inv_on_left_moving_norm (as, lm) (s, l, Bk # r) ires 
              = False"
   by(auto simp: inv_on_left_moving_norm.simps)
 
 lemma inv_on_left_moving_in_middle_B_Bk[simp]: 
   "\<lbrakk>inv_on_left_moving_norm (as, lm) (s, l, Oc # r) ires;
     hd l = Bk; l \<noteq> []\<rbrakk> \<Longrightarrow> 
      inv_on_left_moving_in_middle_B (as, lm) (s, tl l, Bk # Oc # r) ires"
   apply(cases l, simp, simp)
   apply(simp only: inv_on_left_moving_norm.simps 
       inv_on_left_moving_in_middle_B.simps)
   apply(erule_tac exE)+ unfolding tape_of_nl_cons
   apply(rename_tac a list lm1 lm2 m ml mr rn)
   apply(rule_tac x = lm1 in exI, rule_tac x = "m # lm2" in exI, auto)
    apply(auto simp: tape_of_nl_cons split: if_splits)
   done
 
 lemma inv_on_left_moving_norm_Oc_Oc[simp]: "\<lbrakk>inv_on_left_moving_norm (as, lm) (s, l, Oc # r) ires; 
                 hd l = Oc; l \<noteq> []\<rbrakk>
             \<Longrightarrow> inv_on_left_moving_norm (as, lm) 
                                         (s, tl l, Oc # Oc # r) ires"
   apply(simp only: inv_on_left_moving_norm.simps)
   apply(erule exE)+
   apply(rename_tac lm1 lm2 m ml mr rn)
   apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, 
       rule_tac x = m in exI, rule_tac x = "ml - 1" in exI,
       rule_tac x = "Suc mr" in exI, rule_tac x = rn in exI, simp)
   apply(case_tac ml, auto simp: split: if_splits)
   done
 
 lemma inv_on_left_moving_in_middle_B_Bk_Oc[simp]: "inv_on_left_moving_norm (as, lm) (s, [], Oc # r) ires
      \<Longrightarrow> inv_on_left_moving_in_middle_B (as, lm) (s, [], Bk # Oc # r) ires"
   by(auto simp: inv_on_left_moving_norm.simps 
       inv_on_left_moving_in_middle_B.simps split: if_splits)
 
 lemma inv_on_left_moving_Oc_cases[simp]:"inv_on_left_moving (as, lm) (s, l, Oc # r) ires
     \<Longrightarrow> (l = [] \<longrightarrow> inv_on_left_moving (as, lm) (s, [], Bk # Oc # r) ires)
  \<and>  (l \<noteq> [] \<longrightarrow> inv_on_left_moving (as, lm) (s, tl l, hd l # Oc # r) ires)"
   apply(simp add: inv_on_left_moving.simps)
   apply(cases "l \<noteq> []", rule conjI, simp, simp)
    apply(cases "hd l", simp, simp, simp)
   done
 
 lemma from_on_left_moving_to_check_left_moving[simp]: "inv_on_left_moving_in_middle_B (as, lm) 
                                       (s, Bk # list, Bk # r) ires
           \<Longrightarrow> inv_check_left_moving_on_leftmost (as, lm) 
                                       (s', list, Bk # Bk # r) ires"
   apply(simp only: inv_on_left_moving_in_middle_B.simps inv_check_left_moving_on_leftmost.simps)
   apply(erule_tac exE)+
   apply(rename_tac lm1 lm2 rn)
   apply(case_tac "rev lm1", simp_all)
   apply(case_tac "tl (rev lm1)", simp_all add: tape_of_nat_def tape_of_list_def)
   done
 
 lemma inv_check_left_moving_in_middle_no_Bk[simp]:
   "inv_check_left_moving_in_middle (as, lm) (s, l, Bk # r) ires= False"
   by(auto simp: inv_check_left_moving_in_middle.simps )
 
 lemma inv_check_left_moving_on_leftmost_Bk_Bk[simp]: 
   "inv_on_left_moving_in_middle_B (as, lm) (s, [], Bk # r) ires\<Longrightarrow> 
   inv_check_left_moving_on_leftmost (as, lm) (s', [], Bk # Bk # r) ires"
   apply(auto simp: inv_on_left_moving_in_middle_B.simps 
       inv_check_left_moving_on_leftmost.simps split: if_splits)
   done
 
 lemma inv_check_left_moving_on_leftmost_no_Oc[simp]: "inv_check_left_moving_on_leftmost (as, lm) 
                                        (s, list, Oc # r) ires= False"
   by(auto simp: inv_check_left_moving_on_leftmost.simps split: if_splits)
 
 lemma inv_check_left_moving_in_middle_Oc_Bk[simp]: "inv_on_left_moving_in_middle_B (as, lm) 
                                          (s, Oc # list, Bk # r) ires
  \<Longrightarrow> inv_check_left_moving_in_middle (as, lm) (s', list, Oc # Bk # r) ires"
   apply(auto simp: inv_on_left_moving_in_middle_B.simps 
       inv_check_left_moving_in_middle.simps  split: if_splits)
   done
 
 lemma inv_on_left_moving_2_check_left_moving[simp]:
   "inv_on_left_moving (as, lm) (s, l, Bk # r) ires
  \<Longrightarrow> (l = [] \<longrightarrow> inv_check_left_moving (as, lm) (s', [], Bk # Bk # r) ires)
  \<and> (l \<noteq> [] \<longrightarrow> 
       inv_check_left_moving (as, lm) (s', tl l, hd l # Bk # r) ires)"
   by (cases l;cases "hd l", auto simp: inv_on_left_moving.simps inv_check_left_moving.simps)
 
 lemma inv_on_left_moving_norm_no_empty[simp]: "inv_on_left_moving_norm (as, lm) (s, l, []) ires = False"
   apply(auto simp: inv_on_left_moving_norm.simps)
   done
 
 lemma inv_on_left_moving_no_empty[simp]: "inv_on_left_moving (as, lm) (s, l, []) ires = False"
   apply(simp add: inv_on_left_moving.simps)
   apply(simp add: inv_on_left_moving_in_middle_B.simps)
   done
 
 lemma 
   inv_check_left_moving_in_middle_2_on_left_moving_in_middle_B[simp]:
   assumes "inv_check_left_moving_in_middle (as, lm) (s, Bk # list, Oc # r) ires"
   shows "inv_on_left_moving_in_middle_B (as, lm) (s', list, Bk # Oc # r) ires"
   using assms
   apply(simp only: inv_check_left_moving_in_middle.simps 
       inv_on_left_moving_in_middle_B.simps)
   apply(erule_tac exE)+
   apply(rename_tac lm1 lm2 r' rn)
   apply(rule_tac x = "rev (tl (rev lm1))" in exI, 
       rule_tac x = "[hd (rev lm1)] @ lm2" in exI, auto)
-       apply(case_tac [!] "rev lm1",case_tac [!] "tl (rev lm1)")
-                      apply(simp_all add: tape_of_nat_def tape_of_list_def tape_of_nat_list.simps)
-   apply(case_tac [1] lm2, auto simp:tape_of_nat_def)
+  apply(case_tac [!] "rev lm1",case_tac [!] "tl (rev lm1)")
+  apply(simp_all add: tape_of_nat_def tape_of_list_def)
+  apply(case_tac [1] lm2, auto simp:tape_of_nat_def)
   apply(case_tac lm2, auto simp:tape_of_nat_def)
   done
 
 lemma inv_check_left_moving_in_middle_Bk_Oc[simp]: 
   "inv_check_left_moving_in_middle (as, lm) (s, [], Oc # r) ires\<Longrightarrow>
      inv_check_left_moving_in_middle (as, lm) (s', [Bk], Oc # r) ires"
   apply(auto simp: inv_check_left_moving_in_middle.simps )
   done
 
 lemma inv_on_left_moving_norm_Oc_Oc_via_middle[simp]: "inv_check_left_moving_in_middle (as, lm) 
                        (s, Oc # list, Oc # r) ires
    \<Longrightarrow> inv_on_left_moving_norm (as, lm) (s', list, Oc # Oc # r) ires"
   apply(auto simp: inv_check_left_moving_in_middle.simps 
       inv_on_left_moving_norm.simps)
   apply(rename_tac lm1 lm2 rn)
   apply(rule_tac x = "rev (tl (rev lm1))" in exI, 
       rule_tac x = lm2 in exI, rule_tac x = "hd (rev lm1)" in exI)
   apply(rule_tac conjI)
    apply(case_tac "rev lm1", simp, simp)
   apply(rule_tac x = "hd (rev lm1) - 1" in exI, auto)
    apply(rule_tac [!] x = "Suc (Suc 0)" in exI, simp)
    apply(case_tac [!] "rev lm1", simp_all)
    apply(case_tac [!] "last lm1", simp_all add: tape_of_nl_cons split: if_splits)
   done
 
 lemma inv_check_left_moving_Oc_cases[simp]: "inv_check_left_moving (as, lm) (s, l, Oc # r) ires
 \<Longrightarrow> (l = [] \<longrightarrow> inv_on_left_moving (as, lm) (s', [], Bk # Oc # r) ires) \<and>
    (l \<noteq> [] \<longrightarrow> inv_on_left_moving (as, lm) (s', tl l, hd l # Oc # r) ires)"
   apply(cases l;cases "hd l", auto simp: inv_check_left_moving.simps inv_on_left_moving.simps)
   done
 
 (*inv: check_left_moving to after_left_moving*)
 lemma inv_after_left_moving_Bk_via_check[simp]: "inv_check_left_moving (as, lm) (s, l, Bk # r) ires
                 \<Longrightarrow> inv_after_left_moving (as, lm) (s', Bk # l, r) ires"
   apply(auto simp: inv_check_left_moving.simps 
       inv_check_left_moving_on_leftmost.simps inv_after_left_moving.simps)
   done
 
 
 lemma inv_after_left_moving_Bk_empty_via_check[simp]:"inv_check_left_moving (as, lm) (s, l, []) ires
       \<Longrightarrow> inv_after_left_moving (as, lm) (s', Bk # l, []) ires"
   by(simp add: inv_check_left_moving.simps  
       inv_check_left_moving_in_middle.simps 
       inv_check_left_moving_on_leftmost.simps)
 
 (*inv: after_left_moving to inv_stop*)
 lemma inv_stop_Bk_move[simp]: "inv_after_left_moving (as, lm) (s, l, Bk # r) ires
        \<Longrightarrow> inv_stop (as, lm) (s', Bk # l, r) ires"
   apply(auto simp: inv_after_left_moving.simps inv_stop.simps)
   done
 
 lemma inv_stop_Bk_empty[simp]: "inv_after_left_moving (as, lm) (s, l, []) ires
              \<Longrightarrow> inv_stop (as, lm) (s', Bk # l, []) ires"
   by(auto simp: inv_after_left_moving.simps)
 
 (*inv: stop to stop*)
 lemma inv_stop_indep_fst[simp]: "inv_stop (as, lm) (x, l, r) ires \<Longrightarrow> 
                inv_stop (as, lm) (y, l, r) ires"
   apply(simp add: inv_stop.simps)
   done
 
 lemma inv_after_clear_no_Oc[simp]: "inv_after_clear (as, lm) (s, aaa, Oc # xs) ires= False"
   apply(auto simp: inv_after_clear.simps )
   done
 
 lemma inv_after_left_moving_no_Oc[simp]: 
   "inv_after_left_moving (as, lm) (s, aaa, Oc # xs) ires = False"
   by(auto simp: inv_after_left_moving.simps  )
 
 lemma inv_after_clear_Suc_nonempty[simp]:
   "inv_after_clear (as, abc_lm_s lm n (Suc (abc_lm_v lm n))) (s, b, []) ires = False"
   apply(auto simp: inv_after_clear.simps)
   done
 
 lemma inv_on_left_moving_Suc_nonempty[simp]: "inv_on_left_moving (as, abc_lm_s lm n (Suc (abc_lm_v lm n))) 
            (s, b, Oc # list) ires \<Longrightarrow> b \<noteq> []"
   apply(auto simp: inv_on_left_moving.simps inv_on_left_moving_norm.simps split: if_splits)
   done
 
 lemma inv_check_left_moving_Suc_nonempty[simp]:
   "inv_check_left_moving (as, abc_lm_s lm n (Suc (abc_lm_v lm n))) (s, b, Oc # list) ires \<Longrightarrow> b \<noteq> []"
   apply(auto simp: inv_check_left_moving.simps inv_check_left_moving_in_middle.simps split: if_splits)
   done
 
 lemma tinc_correct_pre:
   assumes layout: "ly = layout_of ap"
     and inv_start: "inv_locate_a (as, lm) (n, l, r) ires"
     and lm': "lm' = abc_lm_s lm n (Suc (abc_lm_v lm n))"
     and f: "f = steps (Suc 0, l, r) (tinc_b, 0)"
     and P: "P = (\<lambda> (s, l, r). s = 10)"
     and Q: "Q = (\<lambda> (s, l, r). inc_inv n (as, lm) (s, l, r) ires)" 
   shows "\<exists> stp. P (f stp) \<and> Q (f stp)"
 proof(rule_tac LE = inc_LE in halt_lemma2)
   show "wf inc_LE" by(auto)
 next
   show "Q (f 0)"
     using inv_start
-    by(simp add: f P Q steps.simps inc_inv.simps)
+    apply(simp add: f P Q steps.simps inc_inv.simps)
+    done
 next
   show "\<not> P (f 0)"
-    by(simp add: f P steps.simps)
+    apply(simp add: f P steps.simps)
+    done
 next
   have "\<not> P (f n) \<and> Q (f n) \<Longrightarrow> Q (f (Suc n)) \<and> (f (Suc n), f n) 
         \<in> inc_LE" for n
   proof(simp add: f, 
       cases "steps (Suc 0, l, r) (tinc_b, 0) n", simp add: P)
     fix n a b c
-    assume 10: "a \<noteq> 10 \<and> Q (a, b, c)"
+    assume "a \<noteq> 10 \<and> Q (a, b, c)"
     thus  "Q (step (a, b, c) (tinc_b, 0)) \<and> (step (a, b, c) (tinc_b, 0), a, b, c) \<in> inc_LE"
       apply(simp add:Q)
       apply(simp add: inc_inv.simps)
       apply(cases c; cases "hd c")
          apply(auto simp: Let_def step.simps tinc_b_def split: if_splits) (* ~ 12 sec *)
                           apply(simp_all add: inc_inv.simps inc_LE_def lex_triple_def lex_pair_def
-          inc_measure_def numeral)
+          inc_measure_def numeral_eqs_upto_12)         
       done
   qed
   thus "\<forall>n. \<not> P (f n) \<and> Q (f n) \<longrightarrow> Q (f (Suc n)) \<and> (f (Suc n), f n) \<in> inc_LE" by blast
 qed
 
 lemma tinc_correct: 
   assumes layout: "ly = layout_of ap"
     and inv_start: "inv_locate_a (as, lm) (n, l, r) ires"
     and lm': "lm' = abc_lm_s lm n (Suc (abc_lm_v lm n))"
   shows "\<exists> stp l' r'. steps (Suc 0, l, r) (tinc_b, 0) stp = (10, l', r')
               \<and> inv_stop (as, lm') (10, l', r') ires"
   using assms
   apply(drule_tac tinc_correct_pre, auto)
   apply(rule_tac x = stp in exI, simp)
   apply(simp add: inc_inv.simps)
   done
 
 lemma is_even_4[simp]: "(4::nat) * n mod 2 = 0"
   apply(arith)
   done
 
 lemma crsp_step_inc_pre:
   assumes layout: "ly = layout_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
     and aexec: "abc_step_l (as, lm) (Some (Inc n)) = (asa, lma)"
   shows "\<exists> stp k. steps (Suc 0, l, r) (findnth n @ shift tinc_b (2 * n), 0) stp 
         = (2*n + 10, Bk # Bk # ires, <lma> @ Bk\<up>k) \<and> stp > 0"
 proof -
   have "\<exists> stp l' r'. steps (Suc 0, l, r) (findnth n, 0) stp = (Suc (2 * n), l', r')
     \<and> inv_locate_a (as, lm) (n, l', r') ires"
     using assms
     apply(rule_tac findnth_correct, simp_all add: crsp layout)
     done
   from this obtain stp l' r' where a:
     "steps (Suc 0, l, r) (findnth n, 0) stp = (Suc (2 * n), l', r')
     \<and> inv_locate_a (as, lm) (n, l', r') ires" by blast
   moreover have
     "\<exists> stp la ra. steps (Suc 0, l', r') (tinc_b, 0) stp = (10, la, ra)
                         \<and> inv_stop (as, lma) (10, la, ra) ires"
     using assms a
   proof(rule_tac lm' = lma and n = n and lm = lm and ly = ly and ap = ap in tinc_correct,
       simp, simp)
     show "lma = abc_lm_s lm n (Suc (abc_lm_v lm n))"
       using aexec
       apply(simp add: abc_step_l.simps)
       done
   qed
   from this obtain stpa la ra where b:
     "steps (Suc 0, l', r') (tinc_b, 0) stpa = (10, la, ra)
     \<and> inv_stop (as, lma) (10, la, ra) ires" by blast
   from a b show "\<exists>stp k. steps (Suc 0, l, r) (findnth n @ shift tinc_b (2 * n), 0) stp
     = (2 * n + 10, Bk # Bk # ires, <lma> @ Bk \<up> k) \<and> stp > 0"
     apply(rule_tac x = "stp + stpa" in exI)
     using tm_append_steps[of "Suc 0" l r "findnth n" stp l' r' tinc_b stpa 10 la ra "length (findnth n) div 2"]
     apply(simp add: length_findnth inv_stop.simps)
     apply(cases stpa, simp_all add: steps.simps)
     done
 qed 
 
 lemma crsp_step_inc:
   assumes layout: "ly = layout_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
     and fetch: "abc_fetch as ap = Some (Inc n)"
   shows "\<exists>stp > 0. crsp ly (abc_step_l (as, lm) (Some (Inc n)))
   (steps (s, l, r) (ci ly (start_of ly as) (Inc n), start_of ly as - Suc 0) stp) ires"
 proof(cases "(abc_step_l (as, lm) (Some (Inc n)))")
   fix a b
   assume aexec: "abc_step_l (as, lm) (Some (Inc n)) = (a, b)"
   then have "\<exists> stp k. steps (Suc 0, l, r) (findnth n @ shift tinc_b (2 * n), 0) stp 
         = (2*n + 10, Bk # Bk # ires, <b> @ Bk\<up>k) \<and> stp > 0"
     using assms
     apply(rule_tac crsp_step_inc_pre, simp_all)
     done
   thus "?thesis"
     using assms aexec
     apply(erule_tac exE)
     apply(erule_tac exE)
     apply(erule_tac conjE)
     apply(rename_tac stp k)
     apply(rule_tac x = stp in exI, simp add: ci.simps tm_shift_eq_steps)
     apply(drule_tac off = "(start_of (layout_of ap) as - Suc 0)" in tm_shift_eq_steps)
      apply(auto simp: crsp.simps abc_step_l.simps fetch start_of_Suc1)
     done
 qed
 
-subsection\<open>Crsp of Dec n e\<close>
+subsection\<open>Compilation of instruction Dec n e\<close>
 
 type_synonym dec_inv_t = "(nat * nat list) \<Rightarrow> config \<Rightarrow> cell list \<Rightarrow>  bool"
 
 fun dec_first_on_right_moving :: "nat \<Rightarrow> dec_inv_t"
   where
     "dec_first_on_right_moving n (as, lm) (s, l, r) ires = 
                (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and> 
          ml + mr = Suc m \<and> length lm1 = n \<and> ml > 0 \<and> m > 0 \<and>
              (if lm1 = [] then l = Oc\<up>ml @ Bk # Bk # ires
                           else  l = Oc\<up>ml @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and> 
     ((r = Oc\<up>mr @ [Bk] @ <lm2> @ Bk\<up>rn) \<or> (r = Oc\<up>mr \<and> lm2 = [])))"
 
 fun dec_on_right_moving :: "dec_inv_t"
   where
     "dec_on_right_moving (as, lm) (s, l, r) ires =  
    (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and> 
                              ml + mr = Suc (Suc m) \<and>
    (if lm1 = [] then l = Oc\<up>ml@ Bk # Bk # ires
                 else  l = Oc\<up>ml @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and> 
    ((r = Oc\<up>mr @ [Bk] @ <lm2> @ Bk\<up>rn) \<or> (r = Oc\<up>mr \<and> lm2 = [])))"
 
 fun dec_after_clear :: "dec_inv_t"
   where
     "dec_after_clear (as, lm) (s, l, r) ires = 
               (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and> 
                 ml + mr = Suc m \<and> ml = Suc m \<and> r \<noteq> [] \<and> r \<noteq> [] \<and>
                (if lm1 = [] then l = Oc\<up>ml@ Bk # Bk # ires
                             else l = Oc\<up>ml @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and> 
                (tl r = Bk # <lm2> @ Bk\<up>rn \<or> tl r = [] \<and> lm2 = []))"
 
 fun dec_after_write :: "dec_inv_t"
   where
     "dec_after_write (as, lm) (s, l, r) ires = 
          (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and> 
        ml + mr = Suc m \<and> ml = Suc m \<and> lm2 \<noteq> [] \<and>
        (if lm1 = [] then l = Bk # Oc\<up>ml @ Bk # Bk # ires
                     else l = Bk # Oc\<up>ml @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and> 
        tl r = <lm2> @ Bk\<up>rn)"
 
 fun dec_right_move :: "dec_inv_t"
   where
     "dec_right_move (as, lm) (s, l, r) ires = 
         (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 
             \<and> ml = Suc m \<and> mr = (0::nat) \<and> 
               (if lm1 = [] then l = Bk # Oc\<up>ml @ Bk # Bk # ires
                           else l = Bk # Oc\<up>ml @ [Bk] @ <rev lm1> @ Bk # Bk # ires) 
            \<and> (r = Bk # <lm2> @ Bk\<up>rn \<or> r = [] \<and> lm2 = []))"
 
 fun dec_check_right_move :: "dec_inv_t"
   where
     "dec_check_right_move (as, lm) (s, l, r) ires = 
         (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and> 
            ml = Suc m \<and> mr = (0::nat) \<and> 
            (if lm1 = [] then l = Bk # Bk # Oc\<up>ml @ Bk # Bk # ires
                        else l = Bk # Bk # Oc\<up>ml @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and> 
            r = <lm2> @ Bk\<up>rn)"
 
 fun dec_left_move :: "dec_inv_t"
   where
     "dec_left_move (as, lm) (s, l, r) ires = 
     (\<exists> lm1 m rn. (lm::nat list) = lm1 @ [m::nat] \<and>   
     rn > 0 \<and> 
    (if lm1 = [] then l = Bk # Oc\<up>Suc m @ Bk # Bk # ires
     else l = Bk # Oc\<up>Suc m @ Bk # <rev lm1> @ Bk # Bk # ires) \<and> r = Bk\<up>rn)"
 
 declare
   dec_on_right_moving.simps[simp del] dec_after_clear.simps[simp del] 
   dec_after_write.simps[simp del] dec_left_move.simps[simp del] 
   dec_check_right_move.simps[simp del] dec_right_move.simps[simp del] 
   dec_first_on_right_moving.simps[simp del]
 
 fun inv_locate_n_b :: "inc_inv_t"
   where
     "inv_locate_n_b (as, lm) (s, l, r) ires= 
     (\<exists> lm1 lm2 tn m ml mr rn. lm @ 0\<up>tn = lm1 @ [m] @ lm2 \<and> 
      length lm1 = s \<and> m + 1 = ml + mr \<and> 
      ml = 1 \<and> tn = s + 1 - length lm \<and>
      (if lm1 = [] then l = Oc\<up>ml @ Bk # Bk # ires
       else l = Oc\<up>ml @ Bk # <rev lm1> @ Bk # Bk # ires) \<and> 
      (r = Oc\<up>mr @ [Bk] @ <lm2>@ Bk\<up>rn \<or> (lm2 = [] \<and> r = Oc\<up>mr))
   )"
 
 fun dec_inv_1 :: "layout \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> dec_inv_t"
   where
     "dec_inv_1 ly n e (as, am) (s, l, r) ires = 
            (let ss = start_of ly as in
             let am' = abc_lm_s am n (abc_lm_v am n - Suc 0) in
             let am'' = abc_lm_s am n (abc_lm_v am n) in
               if s = start_of ly e then inv_stop (as, am'') (s, l, r) ires
               else if s = ss then False
               else if s = ss + 2 * n + 1 then 
                   inv_locate_b (as, am) (n, l, r) ires
               else if s = ss + 2 * n + 13 then 
                   inv_on_left_moving (as, am'') (s, l, r) ires
               else if s = ss + 2 * n + 14 then 
                   inv_check_left_moving (as, am'') (s, l, r) ires
               else if s = ss + 2 * n + 15 then 
                   inv_after_left_moving (as, am'') (s, l, r) ires
               else False)"
 
 declare fetch.simps[simp del]
 
 
 lemma x_plus_helpers:
   "x + 4 = Suc (x + 3)"
   "x + 5 = Suc (x + 4)"
   "x + 6 = Suc (x + 5)"
   "x + 7 = Suc (x + 6)"
   "x + 8 = Suc (x + 7)"
   "x + 9 = Suc (x + 8)"
   "x + 10 = Suc (x + 9)"
   "x + 11 = Suc (x + 10)"
   "x + 12 = Suc (x + 11)"
   "x + 13 = Suc (x + 12)"
   "14 + x = Suc (x + 13)"
   "15 + x = Suc (x + 14)"
   "16 + x = Suc (x + 15)"
   by auto
 
 lemma fetch_Dec[simp]: 
-  "fetch (ci ly (start_of ly as) (Dec n e)) (Suc (2 * n)) Bk = (W1,  start_of ly as + 2 *n)"
+  "fetch (ci ly (start_of ly as) (Dec n e)) (Suc (2 * n)) Bk = (WO,  start_of ly as + 2 *n)"
   "fetch (ci ly (start_of ly as) (Dec n e)) (Suc (2 * n)) Oc = (R,  Suc (start_of ly as) + 2 *n)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (Suc (Suc (2 * n))) Oc
      = (R, start_of ly as + 2*n + 2)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (Suc (Suc (2 * n))) Bk
      = (L, start_of ly as + 2*n + 13)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (Suc (Suc (Suc (2 * n)))) Oc
      = (R, start_of ly as + 2*n + 2)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (Suc (Suc (Suc (2 * n)))) Bk
      = (L, start_of ly as + 2*n + 3)"
-  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 4) Oc = (W0, start_of ly as + 2*n + 3)"
+  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 4) Oc = (WB, start_of ly as + 2*n + 3)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 4) Bk = (R, start_of ly as + 2*n + 4)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 5) Bk = (R, start_of ly as + 2*n + 5)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 6) Bk = (L, start_of ly as + 2*n + 6)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 6) Oc = (L, start_of ly as + 2*n + 7)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 7) Bk = (L, start_of ly as + 2*n + 10)"
-  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 8) Bk = (W1, start_of ly as + 2*n + 7)"
+  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 8) Bk = (WO, start_of ly as + 2*n + 7)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 8) Oc = (R, start_of ly as + 2*n + 8)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 9) Bk = (L, start_of ly as + 2*n + 9)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 9) Oc = (R, start_of ly as + 2*n + 8)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 10) Bk = (R, start_of ly as + 2*n + 4)"
-  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 10) Oc = (W0, start_of ly as + 2*n + 9)"
+  "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 10) Oc = (WB, start_of ly as + 2*n + 9)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 11) Oc = (L, start_of ly as + 2*n + 10)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 11) Bk = (L, start_of ly as + 2*n + 11)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 12) Oc = (L, start_of ly as + 2*n + 10)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 12) Bk = (R, start_of ly as + 2*n + 12)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (2 * n + 13) Bk = (R, start_of ly as + 2*n + 16)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (14 + 2 * n) Oc = (L, start_of ly as + 2*n + 13)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (14 + 2 * n) Bk = (L, start_of ly as + 2*n + 14)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (15 + 2 * n) Oc = (L, start_of ly as + 2*n + 13)"
   "fetch (ci (ly) (start_of ly as) (Dec n e)) (15 + 2 * n) Bk = (R, start_of ly as + 2*n + 15)"
   "fetch (ci (ly) (start_of (ly) as) (Dec n e)) (16 + 2 * n) Bk = (R, start_of (ly) e)"
   unfolding x_plus_helpers fetch.simps
   by(auto simp: ci.simps shift.simps nth_append tdec_b_def length_findnth adjust.simps)
 
 lemma steps_start_of_invb_inv_locate_a1[simp]: 
   "\<lbrakk>r = [] \<or> hd r = Bk; inv_locate_a (as, lm) (n, l, r) ires\<rbrakk>
     \<Longrightarrow> \<exists>stp la ra.
   steps (start_of ly as + 2 * n, l, r) (ci ly (start_of ly as) (Dec n e), 
   start_of ly as - Suc 0) stp = (Suc (start_of ly as + 2 * n), la, ra) \<and>
   inv_locate_b (as, lm) (n, la, ra) ires"
   apply(rule_tac x = "Suc (Suc 0)" in exI)
   apply(auto simp: steps.simps step.simps length_ci_dec)
   apply(cases r, simp_all)
   done
 
 lemma steps_start_of_invb_inv_locate_a2[simp]: 
   "\<lbrakk>inv_locate_a (as, lm) (n, l, r) ires; r \<noteq> [] \<and> hd r \<noteq> Bk\<rbrakk>
     \<Longrightarrow> \<exists>stp la ra.
   steps (start_of ly as + 2 * n, l, r) (ci ly (start_of ly as) (Dec n e), 
   start_of ly as - Suc 0) stp = (Suc (start_of ly as + 2 * n), la, ra) \<and>
   inv_locate_b (as, lm) (n, la, ra) ires"
   apply(rule_tac x = "(Suc 0)" in exI, cases "hd r", simp_all)
   apply(auto simp: steps.simps step.simps length_ci_dec)
   apply(cases r, simp_all)
   done
 
 fun abc_dec_1_stage1:: "config \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "abc_dec_1_stage1 (s, l, r) ss n = 
        (if s > ss \<and> s \<le> ss + 2*n + 1 then 4
         else if s = ss + 2 * n + 13 \<or> s = ss + 2*n + 14 then 3
         else if s = ss + 2*n + 15 then 2
         else 0)"
 
 fun abc_dec_1_stage2:: "config \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "abc_dec_1_stage2 (s, l, r) ss n = 
        (if s \<le> ss + 2 * n + 1 then (ss + 2 * n + 16 - s)
         else if s = ss + 2*n + 13 then length l
         else if s = ss + 2*n + 14 then length l
         else 0)"
 
 fun abc_dec_1_stage3 :: "config \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "abc_dec_1_stage3 (s, l, r) ss n  = 
         (if s \<le> ss + 2*n + 1 then 
              if (s - ss) mod 2 = 0 then 
                          if r \<noteq> [] \<and> hd r = Oc then 0 else 1  
                          else length r
          else if s = ss + 2 * n + 13 then 
              if r \<noteq> [] \<and> hd r = Oc then 2 
              else 1
          else if s = ss + 2 * n + 14 then 
              if r \<noteq> [] \<and> hd r = Oc then 3 else 0 
          else 0)"
 
 fun abc_dec_1_measure :: "(config \<times> nat \<times> nat) \<Rightarrow> (nat \<times> nat \<times> nat)"
   where
     "abc_dec_1_measure (c, ss, n) = (abc_dec_1_stage1 c ss n, 
                    abc_dec_1_stage2 c ss n, abc_dec_1_stage3 c ss n)"
 
 definition abc_dec_1_LE ::
   "((config \<times> nat \<times>
   nat) \<times> (config \<times> nat \<times> nat)) set"
   where "abc_dec_1_LE \<equiv> (inv_image lex_triple abc_dec_1_measure)"
 
 lemma wf_dec_le: "wf abc_dec_1_LE"
-  by(auto intro:wf_inv_image simp:abc_dec_1_LE_def lex_triple_def lex_pair_def)
+  by(auto simp:abc_dec_1_LE_def lex_triple_def lex_pair_def)
 
 lemma startof_Suc2:
   "abc_fetch as ap = Some (Dec n e) \<Longrightarrow> 
         start_of (layout_of ap) (Suc as) = 
             start_of (layout_of ap) as + 2 * n + 16"
   apply(auto simp: start_of.simps layout_of.simps  
       length_of.simps abc_fetch.simps 
       take_Suc_conv_app_nth split: if_splits)
   done
 
 lemma start_of_less_2: 
   "start_of ly e \<le> start_of ly (Suc e)"
   apply(cases "e < length ly")
    apply(auto simp: start_of.simps take_Suc take_Suc_conv_app_nth)
   done
 
 lemma start_of_less_1: "start_of ly e \<le> start_of ly (e + d)"
 proof(induct d)
   case 0 thus "?case" by simp
 next
   case (Suc d)
   have "start_of ly e \<le> start_of ly (e + d)"  by fact
   moreover have "start_of ly (e + d) \<le> start_of ly (Suc (e + d))"
     by(rule_tac start_of_less_2)
   ultimately show"?case"
     by(simp)
 qed
 
 lemma start_of_less: 
   assumes "e < as"
   shows "start_of ly e \<le> start_of ly as"
 proof -
   obtain d where " as = e + d"
     using assms by (metis less_imp_add_positive)
   thus "?thesis"
     by(simp add: start_of_less_1)
 qed
 
 lemma start_of_ge: 
   assumes fetch: "abc_fetch as ap = Some (Dec n e)"
     and layout: "ly = layout_of ap"
     and great: "e > as"
   shows "start_of ly e \<ge> start_of ly as + 2*n + 16"
 proof(cases "e = Suc as")
   case True
   have "e = Suc as" by fact
   moreover hence "start_of ly (Suc as) = start_of ly as + 2*n + 16"
     using layout fetch
     by(simp add: startof_Suc2)
   ultimately show "?thesis" by (simp)
 next
   case False
   have "e \<noteq> Suc as" by fact
   then have "e > Suc as" using great by arith
   then have "start_of ly (Suc as) \<le> start_of ly e"
     by(simp add: start_of_less)
   moreover have "start_of ly (Suc as) = start_of ly as + 2*n + 16"
     using layout fetch
     by(simp add: startof_Suc2)
   ultimately show "?thesis"
     by arith
 qed
 
 declare dec_inv_1.simps[simp del]
 
 lemma start_of_ineq1[simp]: 
   "\<lbrakk>abc_fetch as aprog = Some (Dec n e); ly = layout_of aprog\<rbrakk>
    \<Longrightarrow> (start_of ly e \<noteq> Suc (start_of ly as + 2 * n) \<and>
         start_of ly e \<noteq> Suc (Suc (start_of ly as + 2 * n)) \<and>  
         start_of ly e \<noteq> start_of ly as + 2 * n + 3 \<and> 
         start_of ly e \<noteq> start_of ly as + 2 * n + 4 \<and>
         start_of ly e \<noteq> start_of ly as + 2 * n + 5 \<and> 
         start_of ly e \<noteq> start_of ly as + 2 * n + 6 \<and> 
         start_of ly e \<noteq> start_of ly as + 2 * n + 7 \<and>
         start_of ly e \<noteq> start_of ly as + 2 * n + 8 \<and> 
         start_of ly e \<noteq> start_of ly as + 2 * n + 9 \<and> 
         start_of ly e \<noteq> start_of ly as + 2 * n + 10 \<and>
         start_of ly e \<noteq> start_of ly as + 2 * n + 11 \<and> 
         start_of ly e \<noteq> start_of ly as + 2 * n + 12 \<and> 
         start_of ly e \<noteq> start_of ly as + 2 * n + 13 \<and>
         start_of ly e \<noteq> start_of ly as + 2 * n + 14 \<and> 
         start_of ly e \<noteq> start_of ly as + 2 * n + 15)"
   using start_of_ge[of as aprog n e ly] start_of_less[of e as ly]
   apply(cases "e < as", simp)
   apply(cases "e = as", simp, simp)
   done
 
 lemma start_of_ineq2[simp]: "\<lbrakk>abc_fetch as aprog = Some (Dec n e); ly = layout_of aprog\<rbrakk>
       \<Longrightarrow> (Suc (start_of ly as + 2 * n) \<noteq> start_of ly e \<and>
           Suc (Suc (start_of ly as + 2 * n)) \<noteq> start_of ly e \<and> 
           start_of ly as + 2 * n + 3 \<noteq> start_of ly e \<and> 
           start_of ly as + 2 * n + 4 \<noteq> start_of ly e \<and>
           start_of ly as + 2 * n + 5 \<noteq>start_of ly e \<and> 
           start_of ly as + 2 * n + 6 \<noteq> start_of ly e \<and>
           start_of ly as + 2 * n + 7 \<noteq> start_of ly e \<and> 
           start_of ly as + 2 * n + 8 \<noteq> start_of ly e \<and> 
           start_of ly as + 2 * n + 9 \<noteq> start_of ly e \<and> 
           start_of ly as + 2 * n + 10 \<noteq> start_of ly e \<and>
           start_of ly as + 2 * n + 11 \<noteq> start_of ly e \<and> 
           start_of ly as + 2 * n + 12 \<noteq> start_of ly e \<and> 
           start_of ly as + 2 * n + 13 \<noteq> start_of ly e \<and> 
           start_of ly as + 2 * n + 14 \<noteq> start_of ly e \<and> 
           start_of ly as + 2 * n + 15 \<noteq> start_of ly e)"
   using start_of_ge[of as aprog n e ly] start_of_less[of e as ly]
   apply(cases "e < as", simp, simp)
   apply(cases "e = as", simp, simp)
   done
 
 lemma inv_locate_b_nonempty[simp]: "inv_locate_b (as, lm) (n, [], []) ires = False"
   apply(auto simp: inv_locate_b.simps in_middle.simps split: if_splits)
   done
 
 lemma inv_locate_b_no_Bk[simp]: "inv_locate_b (as, lm) (n, [], Bk # list) ires = False"
   apply(auto simp: inv_locate_b.simps in_middle.simps split: if_splits)
   done
 
 lemma dec_first_on_right_moving_Oc[simp]: 
   "\<lbrakk>dec_first_on_right_moving n (as, am) (s, aaa, Oc # xs) ires\<rbrakk>
    \<Longrightarrow> dec_first_on_right_moving n (as, am) (s', Oc # aaa, xs) ires"
   apply(simp only: dec_first_on_right_moving.simps)
   apply(erule exE)+
   apply(rename_tac lm1 lm2 m ml mr rn)
   apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, 
       rule_tac x = m in exI, rule_tac x = "Suc ml" in exI, 
       rule_tac x = "mr - 1" in exI)
   apply(case_tac [!] mr, auto)
   done
 
 lemma dec_first_on_right_moving_Bk_nonempty[simp]: 
   "dec_first_on_right_moving n (as, am) (s, l, Bk # xs) ires \<Longrightarrow> l \<noteq> []"
   apply(auto simp: dec_first_on_right_moving.simps split: if_splits)
   done
 
 lemma replicateE: 
   "\<lbrakk>\<not> length lm1 < length am; 
     am @ replicate (length lm1 - length am) 0 @ [0::nat] = 
                                                 lm1 @ m # lm2;
     0 < m\<rbrakk>
    \<Longrightarrow> RR"
   apply(subgoal_tac "lm2 = []", simp)
   apply(drule_tac length_equal, simp)
   done
 
 lemma dec_after_clear_Bk_strip_hd[simp]: 
   "\<lbrakk>dec_first_on_right_moving n (as, 
                    abc_lm_s am n (abc_lm_v am n)) (s, l, Bk # xs) ires\<rbrakk>
 \<Longrightarrow> dec_after_clear (as, abc_lm_s am n 
                  (abc_lm_v am n - Suc 0)) (s', tl l, hd l # Bk # xs) ires"
   apply(simp only: dec_first_on_right_moving.simps 
       dec_after_clear.simps abc_lm_s.simps abc_lm_v.simps)
   apply(erule_tac exE)+
   apply(rename_tac lm1 lm2 m ml mr rn)
   apply(cases "n < length am")
   by(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, 
       rule_tac x = "m - 1" in exI, auto elim:replicateE)
 
 lemma dec_first_on_right_moving_dec_after_clear_cases[simp]: 
   "\<lbrakk>dec_first_on_right_moving n (as, 
                    abc_lm_s am n (abc_lm_v am n)) (s, l, []) ires\<rbrakk>
 \<Longrightarrow> (l = [] \<longrightarrow> dec_after_clear (as, 
              abc_lm_s am n (abc_lm_v am n - Suc 0)) (s', [], [Bk]) ires) \<and>
     (l \<noteq> [] \<longrightarrow> dec_after_clear (as, abc_lm_s am n 
                       (abc_lm_v am n - Suc 0)) (s', tl l, [hd l]) ires)"
   apply(subgoal_tac "l \<noteq> []", 
       simp only: dec_first_on_right_moving.simps 
       dec_after_clear.simps abc_lm_s.simps abc_lm_v.simps)
    apply(erule_tac exE)+
    apply(rename_tac lm1 lm2 m ml mr rn)
    apply(cases "n < length am", simp)
     apply(rule_tac x = lm1 in exI, rule_tac x = "m - 1" in exI, auto)
     apply(case_tac [1-2] m, auto)
   apply(auto simp: dec_first_on_right_moving.simps split: if_splits)
   done
 
 lemma dec_after_clear_Bk_via_Oc[simp]: "\<lbrakk>dec_after_clear (as, am) (s, l, Oc # r) ires\<rbrakk>
                 \<Longrightarrow> dec_after_clear (as, am) (s', l, Bk # r) ires"
   apply(auto simp: dec_after_clear.simps)
   done
 
 lemma dec_right_move_Bk_via_clear_Bk[simp]: "\<lbrakk>dec_after_clear (as, am) (s, l, Bk # r) ires\<rbrakk>
                 \<Longrightarrow> dec_right_move (as, am) (s', Bk # l, r) ires"
   apply(auto simp: dec_after_clear.simps dec_right_move.simps split: if_splits)
   done
 
 lemma dec_right_move_Bk_Bk_via_clear[simp]: "\<lbrakk>dec_after_clear (as, am) (s, l, []) ires\<rbrakk>
              \<Longrightarrow> dec_right_move (as, am) (s', Bk # l, [Bk]) ires"
   apply(auto simp: dec_after_clear.simps dec_right_move.simps split: if_splits)
   done
 
 lemma dec_right_move_no_Oc[simp]:"dec_right_move (as, am) (s, l, Oc # r) ires = False"
   apply(auto simp: dec_right_move.simps)
   done
 
 lemma dec_right_move_2_check_right_move[simp]:
   "\<lbrakk>dec_right_move (as, am) (s, l, Bk # r) ires\<rbrakk>
       \<Longrightarrow> dec_check_right_move (as, am) (s', Bk # l, r) ires"
   apply(auto simp: dec_right_move.simps dec_check_right_move.simps split: if_splits)
   done
 
 lemma lm_iff_empty[simp]: "(<lm::nat list> = []) = (lm = [])"
   apply(cases lm, simp_all add: tape_of_nl_cons)
   done
 
 lemma dec_right_move_asif_Bk_singleton[simp]: 
   "dec_right_move (as, am) (s, l, []) ires= 
   dec_right_move (as, am) (s, l, [Bk]) ires"
   apply(simp add: dec_right_move.simps)
   done
 
 lemma dec_check_right_move_nonempty[simp]: "dec_check_right_move (as, am) (s, l, r) ires\<Longrightarrow> l \<noteq> []"
   apply(auto simp: dec_check_right_move.simps split: if_splits)
   done
 
 lemma dec_check_right_move_Oc_tail[simp]: "\<lbrakk>dec_check_right_move (as, am) (s, l, Oc # r) ires\<rbrakk>
              \<Longrightarrow> dec_after_write (as, am) (s', tl l, hd l # Oc # r) ires"
   apply(auto simp: dec_check_right_move.simps dec_after_write.simps)
   apply(rename_tac lm1 lm2 m rn)
   apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, rule_tac x = m in exI, auto)
   done
 
 lemma dec_left_move_Bk_tail[simp]: "\<lbrakk>dec_check_right_move (as, am) (s, l, Bk # r) ires\<rbrakk>
                 \<Longrightarrow> dec_left_move (as, am) (s', tl l, hd l # Bk # r) ires"
   apply(auto simp: dec_check_right_move.simps dec_left_move.simps inv_after_move.simps)
   apply(rename_tac lm1 lm2 m rn)
   apply(rule_tac x = lm1 in exI, rule_tac x = m in exI, auto split: if_splits)
      apply(case_tac [!] lm2, simp_all add: tape_of_nl_cons split: if_splits)
    apply(rule_tac [!] x = "(Suc rn)" in exI, simp_all)
   done
 
 lemma dec_left_move_tail[simp]: "\<lbrakk>dec_check_right_move (as, am) (s, l, []) ires\<rbrakk>
              \<Longrightarrow> dec_left_move (as, am) (s', tl l, [hd l]) ires"
   apply(auto simp: dec_check_right_move.simps dec_left_move.simps inv_after_move.simps)
   apply(rename_tac lm1 m)
   apply(rule_tac x = lm1 in exI, rule_tac x = m in exI, auto)
   done
 
 lemma dec_left_move_no_Oc[simp]: "dec_left_move (as, am) (s, aaa, Oc # xs) ires = False"
   apply(auto simp: dec_left_move.simps inv_after_move.simps)
   done
 
 lemma dec_left_move_nonempty[simp]: "dec_left_move (as, am) (s, l, r) ires
              \<Longrightarrow> l \<noteq> []"
   apply(auto simp: dec_left_move.simps split: if_splits)
   done
 
 lemma inv_on_left_moving_in_middle_B_Oc_Bk_Bks[simp]: "inv_on_left_moving_in_middle_B (as, [m])
   (s', Oc # Oc\<up>m @ Bk # Bk # ires, Bk # Bk\<up>rn) ires"
   apply(simp add: inv_on_left_moving_in_middle_B.simps)
   apply(rule_tac x = "[m]" in exI, auto)
   done
 
 
 lemma inv_on_left_moving_in_middle_B_Oc_Bk_Bks_rev[simp]: "lm1 \<noteq> [] \<Longrightarrow> 
   inv_on_left_moving_in_middle_B (as, lm1 @ [m]) (s', 
   Oc # Oc\<up>m @ Bk # <rev lm1> @ Bk # Bk # ires, Bk # Bk\<up>rn) ires"
   apply(simp only: inv_on_left_moving_in_middle_B.simps)
   apply(rule_tac x = "lm1 @ [m ]" in exI, rule_tac x = "[]" in exI, simp)
   apply(simp add: tape_of_nl_cons split: if_splits)
   done
 
 lemma inv_on_left_moving_Bk_tail[simp]: "dec_left_move (as, am) (s, l, Bk # r) ires
        \<Longrightarrow> inv_on_left_moving (as, am) (s', tl l, hd l # Bk # r) ires"
   apply(auto simp: dec_left_move.simps inv_on_left_moving.simps split: if_splits)
   done
 
 lemma inv_on_left_moving_tail[simp]: "dec_left_move (as, am) (s, l, []) ires
              \<Longrightarrow> inv_on_left_moving (as, am) (s', tl l, [hd l]) ires"
   apply(auto simp: dec_left_move.simps inv_on_left_moving.simps split: if_splits)
   done
 
 lemma dec_on_right_moving_Oc_mv[simp]: "dec_after_write (as, am) (s, l, Oc # r) ires
        \<Longrightarrow> dec_on_right_moving (as, am) (s', Oc # l, r) ires"
   apply(auto simp: dec_after_write.simps dec_on_right_moving.simps)
   apply(rename_tac lm1 lm2 m rn)
   apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = "tl lm2" in exI, 
       rule_tac x = "hd lm2" in exI, simp)
   apply(rule_tac x = "Suc 0" in exI,rule_tac x =  "Suc (hd lm2)" in exI)
   apply(case_tac lm2, auto split: if_splits simp: tape_of_nl_cons)
   done
 
 lemma dec_after_write_Oc_via_Bk[simp]: "dec_after_write (as, am) (s, l, Bk # r) ires
        \<Longrightarrow> dec_after_write (as, am) (s', l, Oc # r) ires"
   apply(auto simp: dec_after_write.simps)
   done
 
 lemma dec_after_write_Oc_empty[simp]: "dec_after_write (as, am) (s, aaa, []) ires
              \<Longrightarrow> dec_after_write (as, am) (s', aaa, [Oc]) ires"
   apply(auto simp: dec_after_write.simps)
   done
 
 lemma dec_on_right_moving_Oc_move[simp]: "dec_on_right_moving (as, am) (s, l, Oc # r) ires
        \<Longrightarrow> dec_on_right_moving (as, am) (s', Oc # l, r) ires"
   apply(simp only: dec_on_right_moving.simps)
   apply(erule_tac exE)+
   apply(rename_tac lm1 lm2 m ml mr rn)
   apply(erule conjE)+
   apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
       rule_tac x = "m" in exI, rule_tac x = "Suc ml" in exI, 
       rule_tac x = "mr - 1" in exI, simp)
   apply(case_tac mr, auto)
   done
 
 lemma dec_on_right_moving_nonempty[simp]: "dec_on_right_moving (as, am) (s, l, r) ires\<Longrightarrow>  l \<noteq> []"
   apply(auto simp: dec_on_right_moving.simps split: if_splits)
   done
 
 lemma dec_after_clear_Bk_tail[simp]: "dec_on_right_moving (as, am) (s, l, Bk # r) ires
       \<Longrightarrow>  dec_after_clear (as, am) (s', tl l, hd l # Bk # r) ires"
   apply(auto simp: dec_on_right_moving.simps dec_after_clear.simps simp del:split_head_repeat)
   apply(rename_tac lm1 lm2 m ml mr rn)
   apply(case_tac mr, auto split: if_splits)
   done
 
 lemma dec_after_clear_tail[simp]: "dec_on_right_moving (as, am) (s, l, []) ires
              \<Longrightarrow> dec_after_clear (as, am) (s', tl l, [hd l]) ires"
   apply(auto simp: dec_on_right_moving.simps dec_after_clear.simps)
   apply(simp_all split: if_splits)
   apply(rule_tac x = lm1 in exI, simp)
   done
 
 lemma dec_false_1[simp]:
   "\<lbrakk>abc_lm_v am n = 0; inv_locate_b (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
   \<Longrightarrow> False"
   apply(auto simp: inv_locate_b.simps in_middle.simps)
    apply(rename_tac lm1 lm2 m ml Mr rn)
    apply(case_tac "length lm1 \<ge> length am", auto)
     apply(subgoal_tac "lm2 = []", simp, subgoal_tac "m = 0", simp)
       apply(case_tac Mr, auto simp: )
      apply(subgoal_tac "Suc (length lm1) - length am = 
                    Suc (length lm1 - length am)", 
       simp add: exp_ind del: replicate.simps, simp)
     apply(drule_tac xs = "am @ replicate (Suc (length lm1) - length am) 0"
       and ys = "lm1 @ m # lm2" in length_equal, simp)
    apply(case_tac Mr, auto simp: abc_lm_v.simps)
   apply(rename_tac lm1 m ml Mr)
   apply(case_tac "Mr = 0", simp_all split: if_splits)
   apply(subgoal_tac "Suc (length lm1) - length am = 
                        Suc (length lm1 - length am)", 
       simp add: exp_ind del: replicate.simps, simp)
   done
 
 lemma inv_on_left_moving_Bk_tl[simp]: 
   "\<lbrakk>inv_locate_b (as, am) (n, aaa, Bk # xs) ires; 
    abc_lm_v am n = 0\<rbrakk>
    \<Longrightarrow> inv_on_left_moving (as, abc_lm_s am n 0) 
                          (s, tl aaa, hd aaa # Bk # xs) ires"
   apply(simp add: inv_on_left_moving.simps)
   apply(simp only: inv_locate_b.simps in_middle.simps) 
   apply(erule_tac exE)+
   apply(rename_tac Lm1 Lm2 tn M ml Mr rn)
   apply(subgoal_tac "\<not> inv_on_left_moving_in_middle_B 
          (as, abc_lm_s am n 0) (s, tl aaa, hd aaa # Bk # xs) ires", simp)
    apply(simp only: inv_on_left_moving_norm.simps)
    apply(erule_tac conjE)+
    apply(rule_tac x = Lm1 in exI, rule_tac x = Lm2 in exI, 
       rule_tac x =  M in exI, rule_tac x = M in exI, 
       rule_tac x = "Suc 0" in exI, simp add: abc_lm_s.simps)
    apply(case_tac Mr, auto simp: abc_lm_v.simps)
    apply(simp only: exp_ind[THEN sym] replicate_Suc Nat.Suc_diff_le)
   apply(auto simp: inv_on_left_moving_in_middle_B.simps split: if_splits)
   done
 
 
 lemma inv_on_left_moving_tl[simp]:
   "\<lbrakk>abc_lm_v am n = 0; inv_locate_b (as, am) (n, aaa, []) ires\<rbrakk>
    \<Longrightarrow> inv_on_left_moving (as, abc_lm_s am n 0) (s, tl aaa, [hd aaa]) ires"
   supply [[simproc del: defined_all]]
   apply(simp add: inv_on_left_moving.simps)
   apply(simp only: inv_locate_b.simps in_middle.simps) 
   apply(erule_tac exE)+
   apply(rename_tac Lm1 Lm2 tn M ml Mr rn)
   apply(simp add: inv_on_left_moving.simps)
   apply(subgoal_tac "\<not> inv_on_left_moving_in_middle_B 
          (as, abc_lm_s am n 0) (s, tl aaa, [hd aaa]) ires", simp)
    apply(simp only: inv_on_left_moving_norm.simps)
    apply(erule_tac conjE)+
    apply(rule_tac x = Lm1 in exI, rule_tac x = Lm2 in exI, 
       rule_tac x =  M in exI, rule_tac x = M in exI, 
       rule_tac x = "Suc 0" in exI, simp add: abc_lm_s.simps)
    apply(case_tac Mr, simp_all, auto simp: abc_lm_v.simps)
-    apply(simp_all only: exp_ind Nat.Suc_diff_le del: replicate_Suc, simp_all)
+    apply(simp_all only: exp_ind Nat.Suc_diff_le)
   apply(auto simp: inv_on_left_moving_in_middle_B.simps split: if_splits)
    apply(case_tac [!] M, simp_all)
   done
 
-declare dec_inv_1.simps[simp del]
+(* declare dec_inv_1.simps[simp del] *)
 
 declare inv_locate_n_b.simps [simp del]
 
 lemma dec_first_on_right_moving_Oc_via_inv_locate_n_b[simp]:
   "\<lbrakk>inv_locate_n_b (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
  \<Longrightarrow> dec_first_on_right_moving n (as, abc_lm_s am n (abc_lm_v am n))  
                                       (s, Oc # aaa, xs) ires"
   apply(auto simp: inv_locate_n_b.simps dec_first_on_right_moving.simps 
       abc_lm_s.simps abc_lm_v.simps)
      apply(rename_tac Lm1 Lm2 m rn)
      apply(rule_tac x = Lm1 in exI, rule_tac x = Lm2 in exI, 
       rule_tac x = m in exI, simp)
      apply(rule_tac x = "Suc (Suc 0)" in exI, 
       rule_tac x = "m - 1" in exI, simp)
      apply (metis One_nat_def Suc_pred cell.distinct(1) empty_replicate list.inject list.sel(3)
       neq0_conv self_append_conv2 tl_append2 tl_replicate)
     apply(rename_tac Lm1 Lm2 m rn)
     apply(rule_tac x = Lm1 in exI, rule_tac x = Lm2 in exI, 
       rule_tac x = m in exI, 
       simp add: Suc_diff_le exp_ind del: replicate.simps)
     apply(rule_tac x = "Suc (Suc 0)" in exI, 
       rule_tac x = "m - 1" in exI, simp)
     apply (metis cell.distinct(1) empty_replicate gr_zeroI list.inject replicateE self_append_conv2)
    apply(rename_tac Lm1 m)
    apply(rule_tac x = Lm1 in exI, rule_tac x = "[]" in exI, 
       rule_tac x = m in exI, simp)
    apply(rule_tac x = "Suc (Suc 0)" in exI, 
       rule_tac x = "m - 1" in exI, simp)
    apply(case_tac m, auto)
   apply(rename_tac Lm1 m)
   apply(rule_tac x = Lm1 in exI, rule_tac x = "[]" in exI, rule_tac x = m in exI, 
       simp add: Suc_diff_le exp_ind del: replicate.simps, simp)
   done
 
 lemma inv_on_left_moving_nonempty[simp]: "inv_on_left_moving (as, am) (s, [], r) ires 
   = False"
   apply(simp add: inv_on_left_moving.simps inv_on_left_moving_norm.simps
       inv_on_left_moving_in_middle_B.simps)
   done
 
 lemma inv_check_left_moving_startof_nonempty[simp]: 
   "inv_check_left_moving (as, abc_lm_s am n 0)
   (start_of (layout_of aprog) as + 2 * n + 14, [], Oc # xs) ires
  = False"
   apply(simp add: inv_check_left_moving.simps inv_check_left_moving_in_middle.simps)
   done
 
 lemma start_of_lessE[elim]: "\<lbrakk>abc_fetch as ap = Some (Dec n e);
                 start_of (layout_of ap) as < start_of (layout_of ap) e; 
                 start_of (layout_of ap) e \<le> Suc (start_of (layout_of ap) as + 2 * n)\<rbrakk>
        \<Longrightarrow> RR"
   using start_of_less[of e as "layout_of ap"] start_of_ge[of as ap n e "layout_of ap"]
   apply(cases "as < e", simp)
   apply(cases "as = e", simp, simp)
   done
 
 lemma crsp_step_dec_b_e_pre':
   assumes layout: "ly = layout_of ap"
     and inv_start: "inv_locate_b (as, lm) (n, la, ra) ires"
     and fetch: "abc_fetch as ap = Some (Dec n e)"
     and dec_0: "abc_lm_v lm n = 0"
     and f: "f = (\<lambda> stp. (steps (Suc (start_of ly as) + 2 * n, la, ra) (ci ly (start_of ly as) (Dec n e), 
             start_of ly as - Suc 0) stp, start_of ly as, n))"
     and P: "P = (\<lambda> ((s, l, r), ss, x). s = start_of ly e)"
     and Q: "Q = (\<lambda> ((s, l, r), ss, x). dec_inv_1 ly x e (as, lm) (s, l, r) ires)"
   shows "\<exists> stp. P (f stp) \<and> Q (f stp)"
 proof(rule_tac LE = abc_dec_1_LE in halt_lemma2)
   show "wf abc_dec_1_LE" by(intro wf_dec_le)
 next
   show "Q (f 0)"
     using layout fetch
     apply(simp add: f steps.simps Q dec_inv_1.simps)
     apply(subgoal_tac "e > as \<or> e = as \<or> e < as")
      apply(auto simp: inv_start)
     done
 next
   show "\<not> P (f 0)"
     using layout fetch
     apply(simp add: f steps.simps P)
     done
 next
   show "\<forall>n. \<not> P (f n) \<and> Q (f n) \<longrightarrow> Q (f (Suc n)) \<and> (f (Suc n), f n) \<in> abc_dec_1_LE"
     using fetch
   proof(rule_tac allI, rule_tac impI)
     fix na
     assume "\<not> P (f na) \<and> Q (f na)"
     thus "Q (f (Suc na)) \<and> (f (Suc na), f na) \<in> abc_dec_1_LE"
       apply(simp add: f)
       apply(cases "steps (Suc (start_of ly as + 2 * n), la, ra)
         (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) na", simp)
     proof -
       fix a b c 
       assume "\<not> P ((a, b, c), start_of ly as, n) \<and> Q ((a, b, c), start_of ly as, n)"
       thus "Q (step (a, b, c) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0), start_of ly as, n) \<and>
                ((step (a, b, c) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0), start_of ly as, n), 
                    (a, b, c), start_of ly as, n) \<in> abc_dec_1_LE"
         apply(simp add: Q)
         apply(cases c;cases "hd c")
-           apply(simp_all add: dec_inv_1.simps Let_def split: if_splits)
+        apply(simp_all add: dec_inv_1.simps Let_def split: if_splits)
         using fetch layout dec_0
-                        apply(auto simp: step.simps P dec_inv_1.simps Let_def abc_dec_1_LE_def
+        apply(auto simp: step.simps P dec_inv_1.simps Let_def abc_dec_1_LE_def
             lex_triple_def lex_pair_def)
         using dec_0
         apply(drule_tac dec_false_1, simp_all)
         done
     qed
   qed
 qed
 
 lemma crsp_step_dec_b_e_pre:
   assumes "ly = layout_of ap"
     and inv_start: "inv_locate_b (as, lm) (n, la, ra) ires"
     and dec_0: "abc_lm_v lm n  = 0"
     and fetch: "abc_fetch as ap = Some (Dec n e)"
   shows "\<exists>stp lb rb.
        steps (Suc (start_of ly as) + 2 * n, la, ra) (ci ly (start_of ly as) (Dec n e), 
        start_of ly as - Suc 0) stp = (start_of ly e, lb, rb) \<and>
        dec_inv_1 ly n e (as, lm) (start_of ly e, lb, rb) ires"
   using assms
   apply(drule_tac crsp_step_dec_b_e_pre', auto)
   apply(rename_tac stp a b)
   apply(rule_tac x = stp in exI, simp)
   done
 
 lemma crsp_abc_step_via_stop[simp]:
   "\<lbrakk>abc_lm_v lm n = 0;
   inv_stop (as, abc_lm_s lm n (abc_lm_v lm n)) (start_of ly e, lb, rb) ires\<rbrakk>
   \<Longrightarrow> crsp ly (abc_step_l (as, lm) (Some (Dec n e))) (start_of ly e, lb, rb) ires"
   apply(auto simp: crsp.simps abc_step_l.simps inv_stop.simps)
   done
 
 lemma crsp_step_dec_b_e:
   assumes layout: "ly = layout_of ap"
     and inv_start: "inv_locate_a (as, lm) (n, l, r) ires"
     and dec_0: "abc_lm_v lm n = 0"
     and fetch: "abc_fetch as ap = Some (Dec n e)"
   shows "\<exists>stp > 0. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
   (steps (start_of ly as + 2 * n, l, r) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) stp) ires"
 proof -
   let ?P = "ci ly (start_of ly as) (Dec n e)"
   let ?off = "start_of ly as - Suc 0"
   have "\<exists> stp la ra. steps (start_of ly as + 2 * n, l, r) (?P, ?off) stp = (Suc (start_of ly as) + 2*n, la, ra)
              \<and>  inv_locate_b (as, lm) (n, la, ra) ires"
     using inv_start
     apply(cases "r = [] \<or> hd r = Bk", simp_all)
     done
   from this obtain stpa la ra where a:
     "steps (start_of ly as + 2 * n, l, r) (?P, ?off) stpa = (Suc (start_of ly as) + 2*n, la, ra)
              \<and>  inv_locate_b (as, lm) (n, la, ra) ires" by blast
   have "\<exists> stp lb rb. steps (Suc (start_of ly as) + 2 * n, la, ra) (?P, ?off) stp = (start_of ly e, lb, rb)
              \<and>  dec_inv_1 ly n e (as, lm) (start_of ly e, lb, rb) ires"
     using assms a
     apply(rule_tac crsp_step_dec_b_e_pre, auto)
     done
   from this obtain stpb lb rb where b:
     "steps (Suc (start_of ly as) + 2 * n, la, ra) (?P, ?off) stpb = (start_of ly e, lb, rb)
              \<and>  dec_inv_1 ly n e (as, lm) (start_of ly e, lb, rb) ires"  by blast
   from a b show "\<exists>stp > 0. crsp ly (abc_step_l (as, lm) (Some (Dec n e))) 
     (steps (start_of ly as + 2 * n, l, r) (?P, ?off) stp) ires"
     apply(rule_tac x = "stpa + stpb" in exI)
     using dec_0
     apply(simp add: dec_inv_1.simps )
     apply(cases stpa, simp_all add: steps.simps)
     done
 qed    
 
 fun dec_inv_2 :: "layout \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> dec_inv_t"
   where
     "dec_inv_2 ly n e (as, am) (s, l, r) ires =
            (let ss = start_of ly as in
             let am' = abc_lm_s am n (abc_lm_v am n - Suc 0) in
             let am'' = abc_lm_s am n (abc_lm_v am n) in
               if s = 0 then False
               else if s = ss + 2 * n then 
                       inv_locate_a (as, am) (n, l, r) ires
               else if s = ss + 2 * n + 1 then 
                       inv_locate_n_b (as, am) (n, l, r) ires
               else if s = ss + 2 * n + 2 then 
                       dec_first_on_right_moving n (as, am'') (s, l, r) ires
               else if s = ss + 2 * n + 3 then 
                       dec_after_clear (as, am') (s, l, r) ires
               else if s = ss + 2 * n + 4 then 
                       dec_right_move (as, am') (s, l, r) ires
               else if s = ss + 2 * n + 5 then 
                       dec_check_right_move (as, am') (s, l, r) ires
               else if s = ss + 2 * n + 6 then 
                       dec_left_move (as, am') (s, l, r) ires
               else if s = ss + 2 * n + 7 then 
                       dec_after_write (as, am') (s, l, r) ires
               else if s = ss + 2 * n + 8 then 
                       dec_on_right_moving (as, am') (s, l, r) ires
               else if s = ss + 2 * n + 9 then 
                       dec_after_clear (as, am') (s, l, r) ires
               else if s = ss + 2 * n + 10 then 
                       inv_on_left_moving (as, am') (s, l, r) ires
               else if s = ss + 2 * n + 11 then 
                       inv_check_left_moving (as, am') (s, l, r) ires
               else if s = ss + 2 * n + 12 then 
                       inv_after_left_moving (as, am') (s, l, r) ires
               else if s = ss + 2 * n + 16 then 
                       inv_stop (as, am') (s, l, r) ires
               else False)"
 
 declare dec_inv_2.simps[simp del]
 fun abc_dec_2_stage1 :: "config \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "abc_dec_2_stage1 (s, l, r) ss n = 
               (if s \<le> ss + 2*n + 1 then 7
                else if s = ss + 2*n + 2 then 6 
                else if s = ss + 2*n + 3 then 5
                else if s \<ge> ss + 2*n + 4 \<and> s \<le> ss + 2*n + 9 then 4
                else if s = ss + 2*n + 6 then 3
                else if s = ss + 2*n + 10 \<or> s = ss + 2*n + 11 then 2
                else if s = ss + 2*n + 12 then 1
                else 0)"
 
 fun abc_dec_2_stage2 :: "config \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "abc_dec_2_stage2 (s, l, r) ss n = 
        (if s \<le> ss + 2 * n + 1 then (ss + 2 * n + 16 - s)
         else if s = ss + 2*n + 10 then length l
         else if s = ss + 2*n + 11 then length l
         else if s = ss + 2*n + 4 then length r - 1
         else if s = ss + 2*n + 5 then length r 
         else if s = ss + 2*n + 7 then length r - 1
         else if s = ss + 2*n + 8 then  
               length r + length (takeWhile (\<lambda> a. a = Oc) l) - 1
         else if s = ss + 2*n + 9 then 
               length r + length (takeWhile (\<lambda> a. a = Oc) l) - 1
         else 0)"
 
 fun abc_dec_2_stage3 :: "config \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "abc_dec_2_stage3 (s, l, r) ss n  =
         (if s \<le> ss + 2*n + 1 then 
             if (s - ss) mod 2 = 0 then if r \<noteq> [] \<and> 
                                           hd r = Oc then 0 else 1  
             else length r
          else if s = ss + 2 * n + 10 then 
              if  r \<noteq> [] \<and> hd r = Oc then 2
              else 1
          else if s = ss + 2 * n + 11 then 
              if r \<noteq> [] \<and> hd r = Oc then 3 
              else 0 
          else (ss + 2 * n + 16 - s))"
 
 fun abc_dec_2_stage4 :: "config \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "abc_dec_2_stage4 (s, l, r) ss n = 
           (if s = ss + 2*n + 2 then length r
            else if s = ss + 2*n + 8 then length r
            else if s = ss + 2*n + 3 then 
                if r \<noteq> [] \<and> hd r = Oc then 1
                else 0
            else if s = ss + 2*n + 7 then 
                if r \<noteq> [] \<and> hd r = Oc then 0 
                else 1
            else if s = ss + 2*n + 9 then 
                if r \<noteq> [] \<and> hd r = Oc then 1
                else 0 
            else 0)"
 
 fun abc_dec_2_measure :: "(config \<times> nat \<times> nat) \<Rightarrow> (nat \<times> nat \<times> nat \<times> nat)"
   where
     "abc_dec_2_measure (c, ss, n) = 
   (abc_dec_2_stage1 c ss n, 
   abc_dec_2_stage2 c ss n, abc_dec_2_stage3 c ss n,  abc_dec_2_stage4 c ss n)"
 
 definition lex_square:: 
   "((nat \<times> nat \<times> nat \<times> nat) \<times> (nat \<times> nat \<times> nat \<times> nat)) set"
   where "lex_square \<equiv> less_than <*lex*> lex_triple"
 
 definition abc_dec_2_LE ::
   "((config \<times> nat \<times>
   nat) \<times> (config \<times> nat \<times> nat)) set"
   where "abc_dec_2_LE \<equiv> (inv_image lex_square abc_dec_2_measure)"
 
 lemma wf_dec2_le: "wf abc_dec_2_LE"
   by(auto simp:abc_dec_2_LE_def lex_square_def lex_triple_def lex_pair_def)
 
 lemma fix_add: "fetch ap ((x::nat) + 2*n) b = fetch ap (2*n + x) b"
   using Suc_1 add.commute by metis
 
 lemma inv_locate_n_b_Bk_elim[elim]: 
   "\<lbrakk>0 < abc_lm_v am n; inv_locate_n_b (as, am) (n, aaa, Bk # xs) ires\<rbrakk> 
  \<Longrightarrow> RR"
   by(auto simp:gr0_conv_Suc inv_locate_n_b.simps abc_lm_v.simps split: if_splits)
 
 lemma inv_locate_n_b_nonemptyE[elim]:
   "\<lbrakk>0 < abc_lm_v am n; inv_locate_n_b (as, am) 
                                 (n, aaa, []) ires\<rbrakk> \<Longrightarrow> RR"
   apply(auto simp: inv_locate_n_b.simps abc_lm_v.simps split: if_splits)
   done
 
 lemma no_Ocs_dec_after_write[simp]: "dec_after_write (as, am) (s, aa, r) ires
            \<Longrightarrow> takeWhile (\<lambda>a. a = Oc) aa = []"
   apply(simp only : dec_after_write.simps)
   apply(erule exE)+
   apply(erule_tac conjE)+
   apply(cases aa, simp)
   apply(cases "hd aa", simp only: takeWhile.simps , simp_all split: if_splits)
   done
 
 lemma fewer_Ocs_dec_on_right_moving[simp]: 
   "\<lbrakk>dec_on_right_moving (as, lm) (s, aa, []) ires; 
        length (takeWhile (\<lambda>a. a = Oc) (tl aa)) 
            \<noteq> length (takeWhile (\<lambda>a. a = Oc) aa) - Suc 0\<rbrakk>
     \<Longrightarrow> length (takeWhile (\<lambda>a. a = Oc) (tl aa)) < 
                        length (takeWhile (\<lambda>a. a = Oc) aa) - Suc 0"
   apply(simp only: dec_on_right_moving.simps)
   apply(erule_tac exE)+
   apply(erule_tac conjE)+
   apply(rename_tac lm1 lm2 m ml Mr rn)
   apply(case_tac Mr, auto split: if_splits)
   done
 
 lemma more_Ocs_dec_after_clear[simp]: 
   "dec_after_clear (as, abc_lm_s am n (abc_lm_v am n - Suc 0)) 
              (start_of (layout_of aprog) as + 2 * n + 9, aa, Bk # xs) ires
  \<Longrightarrow> length xs - Suc 0 < length xs + 
                              length (takeWhile (\<lambda>a. a = Oc) aa)"
   apply(simp only: dec_after_clear.simps)
   apply(erule_tac exE)+
   apply(erule conjE)+
   apply(simp split: if_splits )
   done
 
 lemma more_Ocs_dec_after_clear2[simp]: 
   "\<lbrakk>dec_after_clear (as, abc_lm_s am n (abc_lm_v am n - Suc 0))
        (start_of (layout_of aprog) as + 2 * n + 9, aa, []) ires\<rbrakk>
     \<Longrightarrow> Suc 0 < length (takeWhile (\<lambda>a. a = Oc) aa)"
   apply(simp add: dec_after_clear.simps split: if_splits)
   done
 
 lemma inv_check_left_moving_nonemptyE[elim]: 
   "inv_check_left_moving (as, lm) (s, [], Oc # xs) ires
  \<Longrightarrow> RR"
   apply(simp add: inv_check_left_moving.simps inv_check_left_moving_in_middle.simps)
   done
 
 lemma inv_locate_n_b_Oc_via_at_begin_norm[simp]:
   "\<lbrakk>0 < abc_lm_v am n; 
   at_begin_norm (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
   \<Longrightarrow> inv_locate_n_b (as, am) (n, Oc # aaa, xs) ires"
   apply(simp only: at_begin_norm.simps inv_locate_n_b.simps)
   apply(erule_tac exE)+
   apply(rename_tac lm1 lm2 rn)
   apply(rule_tac x = lm1 in exI, simp)
   apply(case_tac "length lm2", simp)
   apply(case_tac "lm2", simp, simp)
   apply(case_tac "lm2", auto simp: tape_of_nl_cons split: if_splits)
   done
 
 lemma inv_locate_n_b_Oc_via_at_begin_fst_awtn[simp]: 
   "\<lbrakk>0 < abc_lm_v am n; 
    at_begin_fst_awtn (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
  \<Longrightarrow> inv_locate_n_b (as, am) (n, Oc # aaa, xs) ires"
   apply(simp only: at_begin_fst_awtn.simps inv_locate_n_b.simps )
   apply(erule exE)+
   apply(rename_tac lm1 tn rn)
   apply(erule conjE)+
   apply(rule_tac x = lm1 in exI, rule_tac x = "[]" in exI, 
       rule_tac x = "Suc tn" in exI, rule_tac x = 0 in exI)
   apply(simp add: exp_ind del: replicate.simps)
   apply(rule conjI)+
    apply(auto)
   done
 
 lemma inv_locate_n_b_Oc_via_inv_locate_n_a[simp]: 
   "\<lbrakk>0 < abc_lm_v am n; inv_locate_a (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
  \<Longrightarrow> inv_locate_n_b (as, am) (n, Oc#aaa, xs) ires"
   apply(auto simp: inv_locate_a.simps at_begin_fst_bwtn.simps)
   done
 
 lemma more_Oc_dec_on_right_moving[simp]: 
   "\<lbrakk>dec_on_right_moving (as, am) (s, aa, Bk # xs) ires; 
    Suc (length (takeWhile (\<lambda>a. a = Oc) (tl aa)))
    \<noteq> length (takeWhile (\<lambda>a. a = Oc) aa)\<rbrakk>
   \<Longrightarrow> Suc (length (takeWhile (\<lambda>a. a = Oc) (tl aa))) 
     < length (takeWhile (\<lambda>a. a = Oc) aa)"
   apply(simp only: dec_on_right_moving.simps)
   apply(erule exE)+
   apply(rename_tac ml mr rn)
   apply(case_tac ml, auto split: if_splits )
   done
 
 lemma crsp_step_dec_b_suc_pre:
   assumes layout: "ly = layout_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
     and inv_start: "inv_locate_a (as, lm) (n, la, ra) ires"
     and fetch: "abc_fetch as ap = Some (Dec n e)"
     and dec_suc: "0 < abc_lm_v lm n"
     and f: "f = (\<lambda> stp. (steps (start_of ly as + 2 * n, la, ra) (ci ly (start_of ly as) (Dec n e), 
             start_of ly as - Suc 0) stp, start_of ly as, n))"
     and P: "P = (\<lambda> ((s, l, r), ss, x). s = start_of ly as + 2*n + 16)"
     and Q: "Q = (\<lambda> ((s, l, r), ss, x). dec_inv_2 ly x e (as, lm) (s, l, r) ires)"
   shows "\<exists> stp. P (f stp) \<and> Q(f stp)"
 proof(rule_tac LE = abc_dec_2_LE in halt_lemma2)
   show "wf abc_dec_2_LE" by(intro wf_dec2_le)
 next
   show "Q (f 0)"
     using layout fetch inv_start
     apply(simp add: f steps.simps Q)
     apply(simp only: dec_inv_2.simps)
     apply(auto simp: Let_def start_of_ge start_of_less inv_start dec_inv_2.simps)
     done
 next
   show "\<not> P (f 0)"
     using layout fetch
     apply(simp add: f steps.simps P)
     done
 next
   show "\<forall>n. \<not> P (f n) \<and> Q (f n) \<longrightarrow> Q (f (Suc n)) \<and> (f (Suc n), f n) \<in> abc_dec_2_LE"
     using fetch
   proof(rule_tac allI, rule_tac impI)
     fix na
     assume "\<not> P (f na) \<and> Q (f na)"
     thus "Q (f (Suc na)) \<and> (f (Suc na), f na) \<in> abc_dec_2_LE"
       apply(simp add: f)
       apply(cases "steps ((start_of ly as + 2 * n), la, ra)
         (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) na", simp)
     proof -
       fix a b c 
       assume "\<not> P ((a, b, c), start_of ly as, n) \<and> Q ((a, b, c), start_of ly as, n)"
       thus "Q (step (a, b, c) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0), start_of ly as, n) \<and>
                ((step (a, b, c) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0), start_of ly as, n), 
                    (a, b, c), start_of ly as, n) \<in> abc_dec_2_LE"
         apply(simp add: Q)
         apply(erule_tac conjE)
         apply(cases c; cases "hd c")
            apply(simp_all add: dec_inv_2.simps Let_def)
            apply(simp_all split: if_splits)
         using fetch layout dec_suc
                             apply(auto simp: step.simps P dec_inv_2.simps Let_def abc_dec_2_LE_def lex_triple_def lex_pair_def lex_square_def
             fix_add numeral_3_eq_3) 
         done
     qed
   qed
 qed
 
 lemma crsp_abc_step_l_start_of[simp]: 
   "\<lbrakk>inv_stop (as, abc_lm_s lm n (abc_lm_v lm n - Suc 0)) 
   (start_of (layout_of ap) as + 2 * n + 16, a, b) ires;
    abc_lm_v lm n > 0;
    abc_fetch as ap = Some (Dec n e)\<rbrakk>
   \<Longrightarrow> crsp (layout_of ap) (abc_step_l (as, lm) (Some (Dec n e))) 
   (start_of (layout_of ap) as + 2 * n + 16, a, b) ires"
   by(auto simp: inv_stop.simps crsp.simps  abc_step_l.simps startof_Suc2)
 
 lemma crsp_step_dec_b_suc:
   assumes layout: "ly = layout_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
     and inv_start: "inv_locate_a (as, lm) (n, la, ra) ires"
     and fetch: "abc_fetch as ap = Some (Dec n e)"
     and dec_suc: "0 < abc_lm_v lm n"
   shows "\<exists>stp > 0. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
               (steps (start_of ly as + 2 * n, la, ra) (ci (layout_of ap) 
                   (start_of ly as) (Dec n e), start_of ly as - Suc 0) stp) ires"
   using assms
   apply(drule_tac crsp_step_dec_b_suc_pre, auto)
   apply(rename_tac stp a b)
   apply(rule_tac x = stp in exI)
   apply(case_tac stp, simp_all add: steps.simps dec_inv_2.simps)
   done
 
 lemma crsp_step_dec_b:
   assumes layout: "ly = layout_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
     and inv_start: "inv_locate_a (as, lm) (n, la, ra) ires"
     and fetch: "abc_fetch as ap = Some (Dec n e)"
   shows "\<exists>stp > 0. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
   (steps (start_of ly as + 2 * n, la, ra) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) stp) ires"
   using assms
   apply(cases "abc_lm_v lm n = 0")
    apply(rule_tac crsp_step_dec_b_e, simp_all)
   apply(rule_tac crsp_step_dec_b_suc, simp_all)
   done
 
+declare adjust.simps[simp del] 
+
 lemma crsp_step_dec: 
   assumes layout: "ly = layout_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
     and fetch: "abc_fetch as ap = Some (Dec n e)"
   shows "\<exists>stp > 0. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
   (steps (s, l, r) (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) stp) ires"
 proof(simp add: ci.simps)
   let ?off = "start_of ly as - Suc 0"
   let ?A = "findnth n"
   let ?B = "adjust (shift (shift tdec_b (2 * n)) ?off) (start_of ly e)"
   have "\<exists> stp la ra. steps (s, l, r) (shift ?A ?off @ ?B, ?off) stp = (start_of ly as + 2*n, la, ra)
                     \<and> inv_locate_a (as, lm) (n, la, ra) ires"
   proof -
     have "\<exists>stp l' r'. steps (Suc 0, l, r) (?A, 0) stp = (Suc (2 * n), l', r') \<and> 
                      inv_locate_a (as, lm) (n, l', r') ires"
       using assms
       apply(rule_tac findnth_correct, simp_all)
       done
     then obtain stp l' r' where a: 
       "steps (Suc 0, l, r) (?A, 0) stp = (Suc (2 * n), l', r') \<and> 
       inv_locate_a (as, lm) (n, l', r') ires" by blast
     then have "steps (Suc 0 + ?off, l, r) (shift ?A ?off, ?off) stp = (Suc (2 * n) + ?off, l', r')"
       apply(rule_tac tm_shift_eq_steps, simp_all)
       done
     moreover have "s = start_of ly as"
       using crsp
       apply(auto simp: crsp.simps)
       done
     ultimately show "\<exists> stp la ra. steps (s, l, r) (shift ?A ?off @ ?B, ?off) stp = (start_of ly as + 2*n, la, ra)
                     \<and> inv_locate_a (as, lm) (n, la, ra) ires"
       using a
       apply(drule_tac B = ?B in tm_append_first_steps_eq, auto)
       apply(rule_tac x = stp in exI, simp)
       done
   qed
   from this obtain stpa la ra where a: 
     "steps (s, l, r) (shift ?A ?off @ ?B, ?off) stpa = (start_of ly as + 2*n, la, ra)
                     \<and> inv_locate_a (as, lm) (n, la, ra) ires" by blast
   have "\<exists>stp. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
            (steps (start_of ly as + 2*n, la, ra) (shift ?A ?off @ ?B, ?off) stp) ires \<and> stp > 0"
     using assms a
     apply(drule_tac crsp_step_dec_b, auto)
     apply(rename_tac stp)
     apply(rule_tac x = stp in exI, simp add: ci.simps)
     done
   then obtain stpb where b: 
     "crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
     (steps (start_of ly as + 2*n, la, ra) (shift ?A ?off @ ?B, ?off) stpb) ires \<and> stpb > 0" ..
   from a b show "\<exists> stp>0. crsp ly (abc_step_l (as, lm) (Some (Dec n e)))
     (steps (s, l, r) (shift ?A ?off @ ?B, ?off) stp) ires"
     apply(rule_tac x = "stpa + stpb" in exI)
     apply(simp)
     done
-qed    
-
-subsection\<open>Crsp of Goto\<close>
+qed
+
+subsection\<open>Compilation of instruction Goto\<close>
 
 lemma crsp_step_goto:
   assumes layout: "ly = layout_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
   shows "\<exists>stp>0. crsp ly (abc_step_l (as, lm) (Some (Goto n)))
   (steps (s, l, r) (ci ly (start_of ly as) (Goto n), 
             start_of ly as - Suc 0) stp) ires"
   using crsp
   apply(rule_tac x = "Suc 0" in exI)
   apply(cases r;cases "hd r")
      apply(simp_all add: ci.simps steps.simps step.simps crsp.simps fetch.simps abc_step_l.simps)
   done
 
 lemma crsp_step_in:
   assumes layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
     and fetch: "abc_fetch as ap = Some ins"
   shows "\<exists> stp>0. crsp ly (abc_step_l (as, lm) (Some ins))
                       (steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp) ires"
   using assms
   apply(cases ins, simp_all)
     apply(rule crsp_step_inc, simp_all)
    apply(rule crsp_step_dec, simp_all)
   apply(rule_tac crsp_step_goto, simp_all)
   done
 
 lemma crsp_step:
   assumes layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
     and fetch: "abc_fetch as ap = Some ins"
   shows "\<exists> stp>0. crsp ly (abc_step_l (as, lm) (Some ins))
                       (steps (s, l, r) (tp, 0) stp) ires"
 proof -
   have "\<exists> stp>0. crsp ly (abc_step_l (as, lm) (Some ins))
                       (steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp) ires"
     using assms
     apply(rule_tac crsp_step_in, simp_all)
     done
   from this obtain stp where d: "stp > 0 \<and> crsp ly (abc_step_l (as, lm) (Some ins))
                       (steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp) ires" ..
   obtain s' l' r' where e:
     "(steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp) = (s', l', r')"
     apply(cases "(steps (s, l, r) (ci ly (start_of ly as) ins, start_of ly as - 1) stp)")
     by blast
   then have "steps (s, l, r) (tp, 0) stp = (s', l', r')"
     using assms d
     apply(rule_tac steps_eq_in)
          apply(simp_all)
     apply(cases "(abc_step_l (as, lm) (Some ins))", simp add: crsp.simps)
     done    
   thus " \<exists>stp>0. crsp ly (abc_step_l (as, lm) (Some ins)) (steps (s, l, r) (tp, 0) stp) ires"
     using d e
     apply(rule_tac x = stp in exI, simp)
     done
 qed
 
 lemma crsp_steps:
   assumes layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and crsp: "crsp ly (as, lm) (s, l, r) ires"
   shows "\<exists> stp. crsp ly (abc_steps_l (as, lm) ap n)
                       (steps (s, l, r) (tp, 0) stp) ires"
   using crsp
 proof(induct n)
   case 0
   then show ?case  apply(rule_tac x = 0 in exI) 
     by(simp add: steps.simps abc_steps_l.simps)
 next
   case (Suc n)
   then obtain stp where "crsp ly (abc_steps_l (as, lm) ap n) (steps0 (s, l, r) tp stp) ires"
     by blast
   thus ?case  
     apply(cases "(abc_steps_l (as, lm) ap n)", auto)
     apply(frule_tac abc_step_red, simp)
     apply(cases "abc_fetch (fst (abc_steps_l (as, lm) ap n)) ap", simp add: abc_step_l.simps, auto)
     apply(cases "steps (s, l, r) (tp, 0) stp", simp)
     using assms
     apply(drule_tac s = "fst (steps0 (s, l, r) (tm_of ap) stp)"
         and l = "fst (snd (steps0 (s, l, r) (tm_of ap) stp))"
         and r = "snd (snd (steps0 (s, l, r) (tm_of ap) stp))" in crsp_step, auto)
     by (metis steps_add)
 qed
 
 
 lemma tp_correct': 
   assumes layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and crsp: "crsp ly (0, lm) (Suc 0, l, r) ires"
     and abc_halt: "abc_steps_l (0, lm) ap stp = (length ap, am)"
   shows "\<exists> stp k. steps (Suc 0, l, r) (tp, 0) stp = (start_of ly (length ap), Bk # Bk # ires, <am> @ Bk\<up>k)"
   using assms
   apply(drule_tac n = stp in crsp_steps, auto)
   apply(rename_tac stpA)
   apply(rule_tac x = stpA in exI)
   apply(case_tac "steps (Suc 0, l, r) (tm_of ap, 0) stpA", simp add: crsp.simps)
   done
 
 text\<open>The tp @ [(Nop, 0), (Nop, 0)] is nomoral turing machines, so we can use Hoare\_plus when composing with Mop machine\<close>
 
 lemma layout_id_cons: "layout_of (ap @ [p]) = layout_of ap @ [length_of p]"
   apply(simp add: layout_of.simps)
   done
 
 lemma map_start_of_layout[simp]:  
   "map (start_of (layout_of xs @ [length_of x])) [0..<length xs] =  (map (start_of (layout_of xs)) [0..<length xs])"
   apply(auto)
   apply(simp add: layout_of.simps start_of.simps)
   done
 
 lemma tpairs_id_cons: 
   "tpairs_of (xs @ [x]) = tpairs_of xs @ [(start_of (layout_of (xs @ [x])) (length xs), x)]"
   apply(auto simp: tpairs_of.simps layout_id_cons )
   done
 
 lemma map_length_ci:
   "(map (length \<circ> (\<lambda>(xa, y). ci (layout_of xs @ [length_of x]) xa y)) (tpairs_of xs)) = 
   (map (length \<circ> (\<lambda>(x, y). ci (layout_of xs) x y)) (tpairs_of xs)) "
   apply(auto simp: ci.simps adjust.simps) apply(rename_tac A B)
   apply(case_tac B, auto simp: ci.simps adjust.simps)
   done
 
 lemma length_tp'[simp]: 
   "\<lbrakk>ly = layout_of ap; tp = tm_of ap\<rbrakk> \<Longrightarrow>
        length tp = 2 * sum_list (take (length ap) (layout_of ap))"
 proof(induct ap arbitrary: ly tp rule: rev_induct)
   case Nil
   thus "?case"
     by(simp add: tms_of.simps tm_of.simps tpairs_of.simps)
 next
   fix x xs ly tp
   assume ind: "\<And>ly tp. \<lbrakk>ly = layout_of xs; tp = tm_of xs\<rbrakk> \<Longrightarrow> 
     length tp = 2 * sum_list (take (length xs) (layout_of xs))"
     and layout: "ly = layout_of (xs @ [x])"
     and tp: "tp = tm_of (xs @ [x])"
   obtain ly' where a: "ly' = layout_of xs"
     by metis
   obtain tp' where b: "tp' = tm_of xs"
     by metis
   have c: "length tp' = 2 * sum_list (take (length xs) (layout_of xs))"
     using a b
     by(erule_tac ind, simp)
   thus "length tp = 2 * 
     sum_list (take (length (xs @ [x])) (layout_of (xs @ [x])))"
     using tp b
     apply(auto simp: layout_id_cons tm_of.simps tms_of.simps length_concat tpairs_id_cons map_length_ci)
     apply(cases x)
       apply(auto simp: ci.simps tinc_b_def tdec_b_def length_findnth adjust.simps length_of.simps
         split: abc_inst.splits)
     done
 qed
 
 lemma length_tp:
   "\<lbrakk>ly = layout_of ap; tp = tm_of ap\<rbrakk> \<Longrightarrow> 
   start_of ly (length ap) = Suc (length tp div 2)"
   apply(frule_tac length_tp', simp_all)
   apply(simp add: start_of.simps)
   done
 
 lemma compile_correct_halt: 
   assumes layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and crsp: "crsp ly (0, lm) (Suc 0, l, r) ires"
     and abc_halt: "abc_steps_l (0, lm) ap stp = (length ap, am)"
     and rs_loc: "n < length am"
     and rs: "abc_lm_v am n = rs"
     and off: "off = length tp div 2"
-  shows "\<exists> stp i j. steps (Suc 0, l, r) (tp @ shift (mopup n) off, 0) stp = (0, Bk\<up>i @ Bk # Bk # ires, Oc\<up>Suc rs @ Bk\<up>j)"
+  shows "\<exists> stp i j. steps (Suc 0, l, r) (tp @ shift (mopup_n_tm n) off, 0) stp = (0, Bk\<up>i @ Bk # Bk # ires, Oc\<up>Suc rs @ Bk\<up>j)"
 proof -
   have "\<exists> stp k. steps (Suc 0, l, r) (tp, 0) stp = (Suc off, Bk # Bk # ires, <am> @ Bk\<up>k)"
     using assms tp_correct'[of ly ap tp lm l r ires stp am]
     by(simp add: length_tp)
   then obtain stp k where "steps (Suc 0, l, r) (tp, 0) stp = (Suc off, Bk # Bk # ires, <am> @ Bk\<up>k)"
     by blast
-  then have a: "steps (Suc 0, l, r) (tp@shift (mopup n) off , 0) stp = (Suc off, Bk # Bk # ires, <am> @ Bk\<up>k)"
+  then have a: "steps (Suc 0, l, r) (tp@shift (mopup_n_tm n) off , 0) stp = (Suc off, Bk # Bk # ires, <am> @ Bk\<up>k)"
     using assms
     by(auto intro: tm_append_first_steps_eq)
   have "\<exists> stp i j. (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)
     = (0, Bk\<up>i @ Bk # Bk # ires, Oc # Oc\<up> rs @ Bk\<up>j)"
     using assms
     by(rule_tac mopup_correct, auto simp: abc_lm_v.simps)
   then obtain stpb i j where 
     "steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stpb
     = (0, Bk\<up>i @ Bk # Bk # ires, Oc # Oc\<up> rs @ Bk\<up>j)" by blast
-  then have b: "steps (Suc 0 + off, Bk # Bk # ires, <am> @ Bk \<up> k) (tp @ shift (mopup n) off, 0) stpb
+  then have b: "steps (Suc 0 + off, Bk # Bk # ires, <am> @ Bk \<up> k) (tp @ shift (mopup_n_tm n) off, 0) stpb
     = (0, Bk\<up>i @ Bk # Bk # ires, Oc # Oc\<up> rs @ Bk\<up>j)"
-    using assms wf_mopup
+    using assms composable_mopup_n_tm
     apply(drule_tac tm_append_second_halt_eq, auto)
     done
   from a b show "?thesis"
-    by(rule_tac x = "stp + stpb" in exI, simp add: steps_add)
+    by(rule_tac x = "stp + stpb" in exI, simp)
 qed
 
-declare mopup.simps[simp del]
+declare mopup_n_tm.simps[simp del]
 lemma abc_step_red2:
   "abc_steps_l (s, lm) p (Suc n) = (let (as', am') = abc_steps_l (s, lm) p n in
                                     abc_step_l (as', am') (abc_fetch as' p))"
   apply(cases "abc_steps_l (s, lm) p n", simp)
   apply(drule_tac abc_step_red, simp)
   done
 
 lemma crsp_steps2:
   assumes 
     layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and crsp: "crsp ly (0, lm) (Suc 0, l, r) ires"
     and nothalt: "as < length ap"
     and aexec: "abc_steps_l (0, lm) ap stp = (as, am)"
   shows "\<exists>stpa\<ge>stp. crsp ly (as, am) (steps (Suc 0, l, r) (tp, 0) stpa) ires"
   using nothalt aexec
 proof(induct stp arbitrary: as am)
   case 0
   thus "?case"
     using crsp
     by(rule_tac x = 0 in exI, auto simp: abc_steps_l.simps steps.simps crsp)
 next
   case (Suc stp as am)
   have ind: 
     "\<And> as am.  \<lbrakk>as < length ap; abc_steps_l (0, lm) ap stp = (as, am)\<rbrakk> 
     \<Longrightarrow> \<exists>stpa\<ge>stp. crsp ly (as, am) (steps (Suc 0, l, r) (tp, 0) stpa) ires" by fact
   have a: "as < length ap" by fact
   have b: "abc_steps_l (0, lm) ap (Suc stp) = (as, am)" by fact
   obtain as' am' where c: "abc_steps_l (0, lm) ap stp = (as', am')" 
     by(cases "abc_steps_l (0, lm) ap stp", auto)
   then have d: "as' < length ap"
     using a b
     by(simp add: abc_step_red2, cases "as' < length ap", simp,
         simp add: abc_fetch.simps abc_steps_l.simps abc_step_l.simps)
   have "\<exists>stpa\<ge>stp. crsp ly (as', am') (steps (Suc 0, l, r) (tp, 0) stpa) ires"
     using d c ind by simp
   from this obtain stpa where e: 
     "stpa \<ge> stp \<and>  crsp ly (as', am') (steps (Suc 0, l, r) (tp, 0) stpa) ires"
     by blast
   obtain s' l' r' where f: "steps (Suc 0, l, r) (tp, 0) stpa = (s', l', r')"
     by(cases "steps (Suc 0, l, r) (tp, 0) stpa", auto)
   obtain ins where g: "abc_fetch as' ap = Some ins" using d 
     by(cases "abc_fetch as' ap",auto simp: abc_fetch.simps)
   then have "\<exists>stp> (0::nat). crsp ly (abc_step_l (as', am') (Some ins)) 
     (steps (s', l', r') (tp, 0) stp) ires "
     using layout compile e f 
     by(rule_tac crsp_step, simp_all)
   then obtain stpb where "stpb > 0 \<and> crsp ly (abc_step_l (as', am') (Some ins)) 
     (steps (s', l', r') (tp, 0) stpb) ires" ..
   from this show "?case" using b e g f c
-    by(rule_tac x = "stpa + stpb" in exI, simp add: steps_add abc_step_red2)
+    by(rule_tac x = "stpa + stpb" in exI, simp add: abc_step_red2)
 qed
 
 lemma compile_correct_unhalt: 
   assumes layout: "ly = layout_of ap"
     and compile: "tp = tm_of ap"
     and crsp: "crsp ly (0, lm) (1, l, r) ires"
     and off: "off = length tp div 2"
     and abc_unhalt: "\<forall> stp. (\<lambda> (as, am). as < length ap) (abc_steps_l (0, lm) ap stp)"
-  shows "\<forall> stp.\<not> is_final (steps (1, l, r) (tp @ shift (mopup n) off, 0) stp)"
+  shows "\<forall> stp.\<not> is_final (steps (1, l, r) (tp @ shift (mopup_n_tm n) off, 0) stp)"
   using assms
 proof(rule_tac allI, rule_tac notI)
   fix stp
-  assume h: "is_final (steps (1, l, r) (tp @ shift (mopup n) off, 0) stp)"
+  assume h: "is_final (steps (1, l, r) (tp @ shift (mopup_n_tm n) off, 0) stp)"
   obtain as am where a: "abc_steps_l (0, lm) ap stp = (as, am)"
     by(cases "abc_steps_l (0, lm) ap stp", auto)
   then have b: "as < length ap"
     using abc_unhalt
     by(erule_tac x = stp in allE, simp)
   have "\<exists> stpa\<ge>stp. crsp ly (as, am) (steps (1, l, r) (tp, 0) stpa) ires "
     using assms b a
-    apply(simp add: numeral)
+    apply(simp add: numeral_eqs_upto_12)
     apply(rule_tac crsp_steps2)
         apply(simp_all)
     done
   then obtain stpa where 
     "stpa\<ge>stp \<and> crsp ly (as, am) (steps (1, l, r) (tp, 0) stpa) ires" ..
   then obtain s' l' r' where b: "(steps (1, l, r) (tp, 0) stpa) = (s', l', r') \<and> 
        stpa\<ge>stp \<and> crsp ly (as, am) (s', l', r') ires"
     by(cases "steps (1, l, r) (tp, 0) stpa", auto)
   hence c:
-    "(steps (1, l, r) (tp @ shift (mopup n) off, 0) stpa) = (s', l', r')"
+    "(steps (1, l, r) (tp @ shift (mopup_n_tm n) off, 0) stpa) = (s', l', r')"
     by(rule_tac tm_append_first_steps_eq, simp_all add: crsp.simps)
   from b have d: "s' > 0 \<and> stpa \<ge> stp"
     by(simp add: crsp.simps)
   then obtain diff where e: "stpa = stp + diff" by (metis le_iff_add)
   obtain s'' l'' r'' where f:
-    "steps (1, l, r) (tp @ shift (mopup n) off, 0) stp = (s'', l'', r'') \<and> is_final (s'', l'', r'')"
+    "steps (1, l, r) (tp @ shift (mopup_n_tm n) off, 0) stp = (s'', l'', r'') \<and> is_final (s'', l'', r'')"
     using h
-    by(cases "steps (1, l, r) (tp @ shift (mopup n) off, 0) stp", auto)
-
-  then have "is_final (steps (s'', l'', r'') (tp @ shift (mopup n) off, 0) diff)"
+    by(cases "steps (1, l, r) (tp @ shift (mopup_n_tm n) off, 0) stp", auto)
+
+  then have "is_final (steps (s'', l'', r'') (tp @ shift (mopup_n_tm n) off, 0) diff)"
     by(auto intro: after_is_final)
-  then have "is_final (steps (1, l, r) (tp @ shift (mopup n) off, 0) stpa)"
+  then have "is_final (steps (1, l, r) (tp @ shift (mopup_n_tm n) off, 0) stpa)"
     using e f by simp
   from this and c d show "False" by simp
 qed
 
+(* Cleanup simpset: the following proofs depend on a cleaned up simpset *)
+(*
+declare adjust.simps[simp del]
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+declare fetch.simps[simp del]
+*)
 end
 
diff --git a/thys/Universal_Turing_Machine/Abacus_Hoare.thy b/thys/Universal_Turing_Machine/Abacus_Hoare.thy
--- a/thys/Universal_Turing_Machine/Abacus_Hoare.thy
+++ b/thys/Universal_Turing_Machine/Abacus_Hoare.thy
@@ -1,444 +1,641 @@
 (* Title: thys/Abacus_Hoare.thy
    Author: Jian Xu, Xingyuan Zhang, and Christian Urban
    Modifications: Sebastiaan Joosten
-*)
+   Modifications: Franz Regensburger (FABR) 04/2022
+      added comments and lemmas for clarification
+ *)
+
+section \<open>Hoare Rules for Abacus Programs\<close>
 
 theory Abacus_Hoare
   imports Abacus
 begin
 
 type_synonym abc_assert = "nat list \<Rightarrow> bool"
 
 definition 
   assert_imp :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" ("_ \<mapsto> _" [0, 0] 100)
   where
     "assert_imp P Q \<equiv> \<forall>xs. P xs \<longrightarrow> Q xs"
 
 fun abc_holds_for :: "(nat list \<Rightarrow> bool) \<Rightarrow> (nat \<times> nat list) \<Rightarrow> bool" ("_ abc'_holds'_for _" [100, 99] 100)
   where
     "P abc_holds_for (s, lm) = P lm"  
 
 (* Hoare Rules *)
 (* halting case *)
-(*consts abc_Hoare_halt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> abc_assert \<Rightarrow> bool" ("({(1_)}/ (_)/ {(1_)})" 50)*)
+(*consts abc_Hoare_halt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> abc_assert \<Rightarrow> bool" ("(\<lbrace>(1_)\<rbrace>/ (_)/ \<lbrace>(1_)\<rbrace>)" 50)*)
 
 fun abc_final :: "(nat \<times> nat list) \<Rightarrow> abc_prog \<Rightarrow> bool"
   where 
     "abc_final (s, lm) p = (s = length p)"
 
 fun abc_notfinal :: "abc_conf \<Rightarrow> abc_prog \<Rightarrow> bool"
   where
     "abc_notfinal (s, lm) p = (s < length p)"
 
+(* SPIKE: added by FABR:
+
+  The definitions for abc_final and abc_notfinal are somewhat surprising.
+  It is easy to build an abacus program p that jumps to a state length p < s
+
+  Thus, there are programs, that may reach a configuration that is neither abc_final nor abc_notfinal.
+
+  We add a definition abc_out_of_prog and provide a witness for our conjecture.
+
+ *)
+
+fun abc_out_of_prog :: "abc_conf \<Rightarrow> abc_prog \<Rightarrow> bool"
+  where
+    "abc_out_of_prog (s, lm) p = (length p < s)"
+
+definition abcP_out_of_pgm_ex :: abc_prog
+  where
+   "abcP_out_of_pgm_ex = [Dec 0 41, Inc 1, Goto 0]"
+
+(* ABC program abcP_out_of_pgm_ex can reach state 41, which is out of program *)
+
+lemma "abc_steps_l (0,[5,3]) abcP_out_of_pgm_ex (10 +6) = (41, [0, 8])"
+  by (simp add: abc_steps_l.simps abc_step_l.simps abc_fetch.simps abc_lm_v.simps abc_lm_s.simps
+                numeral_eqs_upto_12
+                abcP_out_of_pgm_ex_def )
+
+lemma "abc_out_of_prog (abc_steps_l (0,[5,3]) abcP_out_of_pgm_ex (10 +6)) abcP_out_of_pgm_ex"
+  by (simp add: abc_steps_l.simps abc_step_l.simps abc_fetch.simps  abc_lm_v.simps abc_lm_s.simps
+                numeral_eqs_upto_12
+                abcP_out_of_pgm_ex_def )
+
+(* From the properties abc_notfinal cf p, abc_final cf p, abc_out_of_prog cf holds
+ *   always one of these exlusively holds (the other two are ruled out)
+ *)
+
+lemma "abc_notfinal cf p \<or> abc_final cf p \<or> abc_out_of_prog cf p"
+  by (metis (full_types) abc_final.elims(3) abc_notfinal.elims(3) abc_out_of_prog.elims(3)  not_less_iff_gr_or_eq prod.sel(1))
+
+lemma "\<lbrakk> length p \<noteq> 0; abc_notfinal cf p \<rbrakk> \<Longrightarrow> \<not> abc_final cf p \<and> \<not> abc_out_of_prog cf p"
+  by (metis abc_final.simps abc_notfinal.elims(2) abc_out_of_prog.simps less_Suc_eq nat_neq_iff not_less_eq)
+
+lemma "\<lbrakk> length p \<noteq> 0; abc_final cf p \<rbrakk> \<Longrightarrow> \<not> abc_notfinal cf p \<and> \<not> abc_out_of_prog cf p"
+  by (metis abc_final.elims(2) abc_final.simps abc_notfinal.elims(2) abc_out_of_prog.simps nat_neq_iff)
+
+lemma "\<lbrakk> length p \<noteq> 0; abc_out_of_prog cf p \<rbrakk> \<Longrightarrow> \<not> abc_notfinal cf p \<and> \<not> abc_final cf p"
+  by (metis abc_final.simps abc_notfinal.simps abc_out_of_prog.simps less_iff_Suc_add less_imp_add_positive less_not_refl not_less_eq old.prod.exhaust)
+
+(* END SPIKE: added by FABR *)
+
 definition 
-  abc_Hoare_halt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> abc_assert \<Rightarrow> bool" ("({(1_)}/ (_)/ {(1_)})" 50)
+  abc_Hoare_halt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> abc_assert \<Rightarrow> bool" ("(\<lbrace>(1_)\<rbrace>/ (_)/ \<lbrace>(1_)\<rbrace>)" 50)
   where
     "abc_Hoare_halt P p Q \<equiv> \<forall>lm. P lm \<longrightarrow> (\<exists>n. abc_final (abc_steps_l (0, lm) p n) p \<and> Q abc_holds_for (abc_steps_l (0, lm) p n))"
 
 lemma abc_Hoare_haltI:
   assumes "\<And>lm. P lm \<Longrightarrow> \<exists>n. abc_final (abc_steps_l (0, lm) p n) p \<and> Q abc_holds_for (abc_steps_l (0, lm) p n)"
-  shows "{P} (p::abc_prog) {Q}"
+  shows " \<lbrace>P\<rbrace> (p::abc_prog) \<lbrace>Q\<rbrace> "
   unfolding abc_Hoare_halt_def 
   using assms by auto
 
-text \<open>
-  {P} A {Q}   {Q} B {S} 
+(*
+  \<lbrace>P\<rbrace> A \<lbrace>Q\<rbrace>   \<lbrace>Q\<rbrace> B \<lbrace>S\<rbrace> 
   -----------------------------------------
-  {P} A [+] B {S}
-\<close>
+  \<lbrace>P\<rbrace> A [+] B \<lbrace>S\<rbrace>
+*)
+
+(* Added by FABR for clarification and presentation in classes *)
+
+fun app_mopup :: "tprog0 \<Rightarrow> nat \<Rightarrow> tprog0"
+  where
+    "app_mopup tp n = tp @ shift (mopup_n_tm n) (length tp div 2)"
+
+lemma compile_correct_halt_2:
+  assumes compile: "tp = tm_of ap"
+    and abc_halt: "abc_steps_l (0, ns) ap stp = (length ap, am)"
+    and rs_loc: "n < length am"
+  shows "\<exists>stp i j. steps0 (Suc 0, [Bk,Bk], <ns::nat list>) (app_mopup tp n) stp = (0, Bk\<up>i, <abc_lm_v am n> @ Bk\<up>j)"
+proof -
+  have crsp: "crsp (layout_of ap) (0, ns) (Suc 0, [Bk,Bk], <ns::nat list>) []"
+    by (auto simp add: start_of.simps crsp.simps)
+  with assms have "\<exists> stp i j. steps (Suc 0, [Bk,Bk], <ns::nat list>) (tp @ shift (mopup_n_tm n) (length tp div 2), 0) stp
+                     = (0, Bk\<up>i @ Bk # Bk # [], Oc\<up>Suc (abc_lm_v am n) @ Bk\<up>j)"
+    using compile_correct_halt by simp
+  then have "\<exists>stp i j. steps (Suc 0, [Bk,Bk], <ns::nat list>) (tp @ shift (mopup_n_tm n) (length tp div 2), 0) stp
+                     = (0, Bk\<up>i, Oc\<up>Suc (abc_lm_v am n) @ Bk\<up>j)"
+    by (metis replicate_app_Cons_same replicate_append_same take_suc)
+  then show ?thesis
+    by (simp add: tape_of_nat_def)
+qed
+
+lemma compile_correct_halt_3:
+  assumes compile: "tp = tm_of ap"
+    and abc_halt: "abc_steps_l (0, ns) ap stp = (length ap, am)"
+    and rs_loc: "n < length am"
+  shows "\<exists>stp i j. steps0 (Suc 0, [], <ns::nat list>) (app_mopup tp n) stp = (0, Bk\<up>i, <abc_lm_v am n> @ Bk\<up>j)"
+  using steps_left_tape_ShrinkBkCtx_to_NIL compile_correct_halt_2
+  by (metis abc_halt compile replicate_Suc replicate_once rs_loc take_suc)
+
+lemma compile_correct_halt_4:
+  assumes compile: "tp = tm_of ap"
+    and abc_halt: "abc_steps_l (0, ns) ap stp = (length ap, am)"
+    and rs_loc: "n < length am"
+  shows "TMC_yields_num_res (app_mopup tp n) ns (abc_lm_v am n)"
+  unfolding TMC_yields_num_res_def
+  using compile_correct_halt_3 
+  by (metis One_nat_def abc_halt compile rs_loc)
+
+(* Abacus program ap executed with initial memory ns yields result n in register r *)
+
+definition ABC_yields_res :: "abc_prog \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
+  where "ABC_yields_res ap ns n r \<equiv>
+           (\<exists>stp am.  abc_steps_l (0, ns) ap stp = (length ap, am) \<and>
+                       r < length am \<and> (abc_lm_v am r = n))"
+
+definition ABC_loops_on :: "abc_prog \<Rightarrow> nat list \<Rightarrow>  bool"
+  where "ABC_loops_on ap ns \<equiv>
+          \<forall>stp. abc_notfinal (abc_steps_l (0, ns) ap stp) ap"
+
+theorem ABC_yields_res_imp_TMC_yields_num_res:
+  assumes "tp = tm_of ap"
+    and   "ABC_yields_res ap ns n r"
+  shows   "TMC_yields_num_res (app_mopup tp r) ns n"
+proof -
+  from \<open>ABC_yields_res ap ns n r\<close>
+  have "\<exists>stp am. abc_steps_l (0, ns) ap stp = (length ap, am) \<and>
+                 r < length am \<and> (abc_lm_v am r = n)"
+    unfolding ABC_yields_res_def
+    by auto
+  then obtain stp am where
+    w_stp_am: "abc_steps_l (0, ns) ap stp = (length ap, am) \<and>
+               r < length am \<and> (abc_lm_v am r = n)" by blast
+  have "TMC_yields_num_res (app_mopup tp r) ns (abc_lm_v am r)"
+  proof (rule compile_correct_halt_4)
+    from assms show "tp = tm_of ap" by auto
+  next
+    from w_stp_am
+    show "r < length am"
+      by auto
+  next
+    from w_stp_am
+    show "abc_steps_l (0, ns) ap stp = (length ap, am)"
+      by auto
+  qed
+  with w_stp_am  show "TMC_yields_num_res (app_mopup tp r) ns n" by auto
+qed
+
+lemma abc_unhalt_2:
+  assumes compile: "tp = tm_of ap"
+  and notfinal: "\<forall>stp. abc_notfinal (abc_steps_l (0, ns) ap stp) ap"
+shows "\<forall>stp.\<not> is_final (steps0 (Suc 0, [Bk,Bk], <ns::nat list>) (app_mopup tp r) stp)"
+proof -
+  have "\<forall>stp.\<not> is_final (steps (1, [Bk,Bk], <ns::nat list>) (tp @ shift (mopup_n_tm r) (length tp div 2), 0) stp)"
+  proof (rule  compile_correct_unhalt)
+    show "layout_of ap = layout_of ap" by auto
+  next
+    from compile show "tp = tm_of ap" by auto
+  next
+    show "length tp div 2 = length tp div 2" by auto
+  next
+    show "crsp (layout_of ap) (0, ns) (1, [Bk, Bk], <ns::nat list>) []"
+      by (auto simp add: start_of.simps crsp.simps)
+  next
+    from notfinal show " \<forall>stp. case abc_steps_l (0, ns) ap stp of (as, am) \<Rightarrow> as < length ap"
+      by (metis abc_notfinal.elims(2) case_prodI2 prod.sel(1))
+  qed
+  then show ?thesis by auto
+qed
+
+theorem ABC_loops_imp_TMC_loops:
+  assumes "tp = tm_of ap"
+    and   "ABC_loops_on ap ns"
+  shows   "TMC_loops (app_mopup tp r) ns"
+proof -
+  have "\<forall>stp.\<not> is_final (steps0 (Suc 0, [Bk,Bk], <ns::nat list>) (app_mopup tp r) stp)"
+  proof (rule abc_unhalt_2)
+    from \<open>tp = tm_of ap\<close> 
+    show "tp = tm_of ap" by auto
+  next
+    from \<open>ABC_loops_on ap ns\<close>
+    show "\<forall>stp. abc_notfinal (abc_steps_l (0, ns) ap stp) ap"
+      unfolding ABC_loops_on_def by auto
+  qed
+  have "\<forall>stp. \<not> is_final (steps0 (Suc 0, [], <ns>) (app_mopup tp r) stp)"
+  proof
+    fix stp
+    show "\<not> is_final (steps0 (Suc 0, [], <ns>) (app_mopup tp r) stp)"
+    proof
+      assume "is_final (steps0 (Suc 0, [], <ns>) (app_mopup tp r) stp)"
+      then have "\<exists>ltap rtap. steps0 (Suc 0, Bk \<up>0, <ns>) (app_mopup tp r) stp = (0, ltap, rtap)"
+        using is_final.elims(2) replicate_empty by fastforce
+      then obtain ltap rtap where
+        "steps0 (Suc 0, Bk \<up>0, <ns>) (app_mopup tp r) stp = (0, ltap, rtap)" by blast
+      then have   "\<exists>z3. z3 \<le> 0 + 2 \<and>
+        steps0 (Suc 0, Bk\<up>(0 + 2), <ns>)  (app_mopup tp r) stp = (0,ltap @ Bk\<up>z3 ,rtap)"
+        using steps_left_tape_EnlargeBkCtx_arbitrary_CL
+        by (metis add.left_neutral add_2_eq_Suc' append_Nil)
+      then have "is_final (steps0 (Suc 0, [Bk,Bk], <ns>) (app_mopup tp r) stp)"        
+        using One_nat_def add_2_eq_Suc' add_Suc_shift is_finalI length_replicate list.size(3)
+          list.size(4) plus_1_eq_Suc replicate_Suc replicate_once by force
+      with \<open>\<forall>stp. \<not> is_final (steps0 (Suc 0, [Bk, Bk], <ns>) (app_mopup tp r) stp)\<close>
+      show False by auto
+    qed
+  qed
+  then show "TMC_loops (app_mopup tp r) ns"
+    unfolding TMC_loops_def
+    by simp
+qed
+
+(* END Added by FABR for clarification and presentation in classes *)
 
 definition
-  abc_Hoare_unhalt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> bool" ("({(1_)}/ (_)) \<up>" 50)
+  abc_Hoare_unhalt :: "abc_assert \<Rightarrow> abc_prog \<Rightarrow> bool" ("(\<lbrace>(1_)\<rbrace>/ (_)) \<up>" 50)
   where
-    "abc_Hoare_unhalt P p \<equiv> \<forall>args. P args \<longrightarrow> (\<forall> n .abc_notfinal (abc_steps_l (0, args) p n) p)"
+    "abc_Hoare_unhalt P p \<equiv> \<forall>args. P args \<longrightarrow> (\<forall>n. abc_notfinal (abc_steps_l (0, args) p n) p)"
 
 lemma abc_Hoare_unhaltI:
   assumes "\<And>args n. P args \<Longrightarrow> abc_notfinal (abc_steps_l (0, args) p n) p"
-  shows "{P} (p::abc_prog) \<up>"
+  shows "\<lbrace>P\<rbrace> (p::abc_prog) \<up>"
   unfolding abc_Hoare_unhalt_def 
   using assms by auto
 
 fun abc_inst_shift :: "abc_inst \<Rightarrow> nat \<Rightarrow> abc_inst"
   where
     "abc_inst_shift (Inc m) n = Inc m" |
     "abc_inst_shift (Dec m e) n = Dec m (e + n)" |
     "abc_inst_shift (Goto m) n = Goto (m + n)"
 
 fun abc_shift :: "abc_inst list \<Rightarrow> nat \<Rightarrow> abc_inst list" 
   where
     "abc_shift xs n = map (\<lambda> x. abc_inst_shift x n) xs" 
 
 fun abc_comp :: "abc_inst list \<Rightarrow> abc_inst list \<Rightarrow> 
                            abc_inst list" (infixl "[+]" 99)
   where
     "abc_comp al bl = (let al_len = length al in 
                            al @ abc_shift bl al_len)"
 
 lemma abc_comp_first_step_eq_pre: 
   "s < length A
  \<Longrightarrow> abc_step_l (s, lm) (abc_fetch s (A [+] B)) = 
     abc_step_l (s, lm) (abc_fetch s A)"
   by(simp add: abc_step_l.simps abc_fetch.simps nth_append)
 
 lemma abc_before_final: 
   "\<lbrakk>abc_final (abc_steps_l (0, lm) p n) p; p \<noteq> []\<rbrakk>
   \<Longrightarrow> \<exists> n'. abc_notfinal (abc_steps_l (0, lm) p n') p \<and> 
             abc_final (abc_steps_l (0, lm) p (Suc n')) p"
 proof(induct n)
   case 0
   thus "?thesis"
     by(simp add: abc_steps_l.simps)
 next
   case (Suc n)
   have ind: " \<lbrakk>abc_final (abc_steps_l (0, lm) p n) p; p \<noteq> []\<rbrakk> \<Longrightarrow> 
     \<exists>n'. abc_notfinal (abc_steps_l (0, lm) p n') p \<and> abc_final (abc_steps_l (0, lm) p (Suc n')) p"
     by fact
   have final: "abc_final (abc_steps_l (0, lm) p (Suc n)) p" by fact
   have notnull: "p \<noteq> []" by fact
   show "?thesis"
   proof(cases "abc_final (abc_steps_l (0, lm) p n) p")
     case True
     have "abc_final (abc_steps_l (0, lm) p n) p" by fact
     then have "\<exists>n'. abc_notfinal (abc_steps_l (0, lm) p n') p \<and> abc_final (abc_steps_l (0, lm) p (Suc n')) p"
       using ind notnull
       by simp
     thus "?thesis"
       by simp
   next
     case False
     have "\<not> abc_final (abc_steps_l (0, lm) p n) p" by fact
     from final this have "abc_notfinal (abc_steps_l (0, lm) p n) p" 
       by(case_tac "abc_steps_l (0, lm) p n", simp add: abc_step_red2 
           abc_step_l.simps abc_fetch.simps split: if_splits)
     thus "?thesis"
       using final
       by(rule_tac x = n in exI, simp)
   qed
 qed
 
 lemma notfinal_Suc:
   "abc_notfinal (abc_steps_l (0, lm) A (Suc n)) A \<Longrightarrow>  
   abc_notfinal (abc_steps_l (0, lm) A n) A"
   apply(case_tac "abc_steps_l (0, lm) A n")
   apply(simp add: abc_step_red2 abc_fetch.simps abc_step_l.simps split: if_splits)
   done
 
-lemma abc_comp_frist_steps_eq_pre: 
+lemma abc_comp_first_steps_eq_pre: 
   assumes notfinal: "abc_notfinal (abc_steps_l (0, lm)  A n) A"
     and notnull: "A \<noteq> []"
   shows "abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
   using notfinal
 proof(induct n)
   case 0
   thus "?case"
     by(simp add: abc_steps_l.simps)
 next
   case (Suc n)
   have ind: "abc_notfinal (abc_steps_l (0, lm) A n) A \<Longrightarrow> abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
     by fact
   have h: "abc_notfinal (abc_steps_l (0, lm) A (Suc n)) A" by fact
   then have a: "abc_notfinal (abc_steps_l (0, lm) A n) A"
     by(simp add: notfinal_Suc)
   then have b: "abc_steps_l (0, lm) (A [+] B) n = abc_steps_l (0, lm) A n"
     using ind by simp
   obtain s lm' where c: "abc_steps_l (0, lm) A n = (s, lm')"
     by (metis prod.exhaust)
   then have d: "s < length A \<and> abc_steps_l (0, lm) (A [+] B) n = (s, lm')" 
     using a b by simp
   thus "?case"
     using c
     by(simp add: abc_step_red2 abc_fetch.simps abc_step_l.simps nth_append)
 qed
 
 declare abc_shift.simps[simp del] abc_comp.simps[simp del]
 lemma halt_steps2: "st \<ge> length A \<Longrightarrow> abc_steps_l (st, lm) A stp = (st, lm)"
   apply(induct stp)
   by(simp_all add: abc_step_red2 abc_steps_l.simps abc_step_l.simps abc_fetch.simps)
 
 lemma halt_steps: "abc_steps_l (length A, lm) A n = (length A, lm)"
   apply(induct n, simp add: abc_steps_l.simps)
   apply(simp add: abc_step_red2 abc_step_l.simps nth_append abc_fetch.simps)
   done
 
 lemma abc_steps_add: 
   "abc_steps_l (as, lm) ap (m + n) = 
          abc_steps_l (abc_steps_l (as, lm) ap m) ap n"
   apply(induct m arbitrary: n as lm, simp add: abc_steps_l.simps)
 proof -
   fix m n as lm
   assume ind: 
     "\<And>n as lm. abc_steps_l (as, lm) ap (m + n) = 
                    abc_steps_l (abc_steps_l (as, lm) ap m) ap n"
   show "abc_steps_l (as, lm) ap (Suc m + n) = 
              abc_steps_l (abc_steps_l (as, lm) ap (Suc m)) ap n"
     apply(insert ind[of as lm "Suc n"], simp)
     apply(insert ind[of as lm "Suc 0"], simp add: abc_steps_l.simps)
     apply(case_tac "(abc_steps_l (as, lm) ap m)", simp)
     apply(simp add: abc_steps_l.simps)
     apply(case_tac "abc_step_l (a, b) (abc_fetch a ap)", 
         simp add: abc_steps_l.simps)
     done
 qed
 
 lemma equal_when_halt: 
   assumes exc1: "abc_steps_l (s, lm) A na = (length A, lma)"
     and exc2: "abc_steps_l (s, lm) A nb = (length A, lmb)"
   shows "lma = lmb"
 proof(cases "na > nb")
   case True
   then obtain d where "na = nb + d"
     by (metis add_Suc_right less_iff_Suc_add)
   thus "?thesis" using assms halt_steps
     by(simp add: abc_steps_add)
 next
   case False
   then obtain d where "nb = na + d"
     by (metis add.comm_neutral less_imp_add_positive nat_neq_iff)
   thus "?thesis" using assms halt_steps
     by(simp add: abc_steps_add)
 qed 
 
-lemma abc_comp_frist_steps_halt_eq': 
+lemma abc_comp_first_steps_halt_eq': 
   assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
     and notnull: "A \<noteq> []"
   shows "\<exists> n'. abc_steps_l (0, lm) (A [+] B) n' = (length A, lm')"
 proof -
   have "\<exists> n'. abc_notfinal (abc_steps_l (0, lm) A n') A \<and> 
     abc_final (abc_steps_l (0, lm) A (Suc n')) A"
     using assms
     by(rule_tac n = n in abc_before_final, simp_all)
   then obtain na where a:
     "abc_notfinal (abc_steps_l (0, lm) A na) A \<and> 
             abc_final (abc_steps_l (0, lm) A (Suc na)) A" ..
   obtain sa lma where b: "abc_steps_l (0, lm) A na = (sa, lma)"
     by (metis prod.exhaust)
   then have c: "abc_steps_l (0, lm) (A [+] B) na = (sa, lma)"
-    using a abc_comp_frist_steps_eq_pre[of lm A na B] assms 
+    using a abc_comp_first_steps_eq_pre[of lm A na B] assms 
     by simp
   have d: "sa < length A" using b a by simp
   then have e: "abc_step_l (sa, lma) (abc_fetch sa (A [+] B)) = 
     abc_step_l (sa, lma) (abc_fetch sa A)"
     by(rule_tac abc_comp_first_step_eq_pre)
   from a have "abc_steps_l (0, lm) A (Suc na) = (length A, lm')"
     using final equal_when_halt
     by(case_tac "abc_steps_l (0, lm) A (Suc na)" , simp)
   then have "abc_steps_l (0, lm) (A [+] B) (Suc na) = (length A, lm')"
     using a b c e
     by(simp add: abc_step_red2)
   thus "?thesis"
     by blast
 qed
 
 lemma abc_exec_null: "abc_steps_l sam [] n = sam"
   apply(cases sam)
   apply(induct n)
    apply(auto simp: abc_step_red2)
    apply(auto simp: abc_step_l.simps abc_steps_l.simps abc_fetch.simps)
   done
 
-lemma abc_comp_frist_steps_halt_eq: 
+lemma abc_comp_first_steps_halt_eq: 
   assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
   shows "\<exists> n'. abc_steps_l (0, lm) (A [+] B) n' = (length A, lm')"
   using final
   apply(case_tac "A = []")
    apply(rule_tac x = 0 in exI, simp add: abc_steps_l.simps abc_exec_null)
-  apply(rule_tac abc_comp_frist_steps_halt_eq', simp_all)
+  apply(rule_tac abc_comp_first_steps_halt_eq', simp_all)
   done
 
 
 lemma abc_comp_second_step_eq: 
   assumes exec: "abc_step_l (s, lm) (abc_fetch s B) = (sa, lma)"
   shows "abc_step_l (s + length A, lm) (abc_fetch (s + length A) (A [+] B))
          = (sa + length A, lma)"
   using assms
   apply(auto simp: abc_step_l.simps abc_fetch.simps nth_append abc_comp.simps abc_shift.simps split : if_splits )
   apply(case_tac [!] "B ! s", auto simp: Let_def)
   done
 
 lemma abc_comp_second_steps_eq:
   assumes exec: "abc_steps_l (0, lm) B n = (sa, lm')"
   shows "abc_steps_l (length A, lm) (A [+] B) n = (sa + length A, lm')"
   using assms
 proof(induct n arbitrary: sa lm')
   case 0
   thus "?case"
     by(simp add: abc_steps_l.simps)
 next
   case (Suc n)
   have ind: "\<And>sa lm'. abc_steps_l (0, lm) B n = (sa, lm') \<Longrightarrow> 
     abc_steps_l (length A, lm) (A [+] B) n = (sa + length A, lm')" by fact
   have exec: "abc_steps_l (0, lm) B (Suc n) = (sa, lm')" by fact
   obtain sb lmb where a: " abc_steps_l (0, lm) B n = (sb, lmb)"
     by (metis prod.exhaust)
   then have "abc_steps_l (length A, lm) (A [+] B) n = (sb + length A, lmb)"
     using ind by simp
   moreover have "abc_step_l (sb + length A, lmb) (abc_fetch (sb + length A) (A [+] B)) = (sa + length A, lm') "
     using a exec abc_comp_second_step_eq
     by(simp add: abc_step_red2)    
   ultimately show "?case"
     by(simp add: abc_step_red2)
 qed
 
 lemma length_abc_comp[simp, intro]: 
   "length (A [+] B) = length A + length B"
   by(auto simp: abc_comp.simps abc_shift.simps)   
 
 lemma abc_Hoare_plus_halt : 
-  assumes A_halt : "{P} (A::abc_prog) {Q}"
-    and B_halt : "{Q} (B::abc_prog) {S}"
-  shows "{P} (A [+] B) {S}"
+  assumes A_halt : "\<lbrace>P\<rbrace> (A::abc_prog) \<lbrace>Q\<rbrace>"
+    and B_halt : "\<lbrace>Q\<rbrace> (B::abc_prog) \<lbrace>S\<rbrace>"
+  shows "\<lbrace>P\<rbrace> (A [+] B) \<lbrace>S\<rbrace>"
 proof(rule_tac abc_Hoare_haltI)
   fix lm
   assume a: "P lm"
   then obtain na lma where 
     "abc_final (abc_steps_l (0, lm) A na) A"
     and b: "abc_steps_l (0, lm) A na = (length A, lma)"
     and c: "Q abc_holds_for (length A, lma)"
     using A_halt unfolding abc_Hoare_halt_def
     by (metis (full_types) abc_final.simps abc_holds_for.simps prod.exhaust)
   have "\<exists> n. abc_steps_l (0, lm) (A [+] B) n = (length A, lma)"
-    using abc_comp_frist_steps_halt_eq b
+    using abc_comp_first_steps_halt_eq b
     by(simp)
   then obtain nx where h1: "abc_steps_l (0, lm) (A [+] B) nx = (length A, lma)" ..   
   from c have "Q lma"
     using c unfolding abc_holds_for.simps
     by simp
   then obtain nb lmb where
     "abc_final (abc_steps_l (0, lma) B nb) B"
     and d: "abc_steps_l (0, lma) B nb = (length B, lmb)"
     and e: "S abc_holds_for (length B, lmb)"
     using B_halt unfolding abc_Hoare_halt_def
     by (metis (full_types) abc_final.simps abc_holds_for.simps prod.exhaust)
   have h2: "abc_steps_l (length A, lma) (A [+] B) nb = (length B + length A, lmb)"
     using d abc_comp_second_steps_eq
     by simp
   thus "\<exists>n. abc_final (abc_steps_l (0, lm) (A [+] B) n) (A [+] B) \<and>
     S abc_holds_for abc_steps_l (0, lm) (A [+] B) n"
     using h1 e
     by(rule_tac x = "nx + nb" in exI, simp add: abc_steps_add)
 qed
 
 lemma abc_unhalt_append_eq:
-  assumes unhalt: "{P} (A::abc_prog) \<up>"
+  assumes unhalt: "\<lbrace>P\<rbrace> (A::abc_prog) \<up>"
     and P: "P args"
   shows "abc_steps_l (0, args) (A [+] B) stp = abc_steps_l (0, args) A stp"
 proof(induct stp)
   case 0
   thus "?case"
     by(simp add: abc_steps_l.simps)
 next
   case (Suc stp)
   have ind: "abc_steps_l (0, args) (A [+] B) stp = abc_steps_l (0, args) A stp"
     by fact
   obtain s nl where a: "abc_steps_l (0, args) A stp = (s, nl)"
     by (metis prod.exhaust)
   then have b: "s < length A"
     using unhalt P
     apply(auto simp: abc_Hoare_unhalt_def)
     by (metis abc_notfinal.simps)
   thus "?case"
     using a ind
     by(simp add: abc_step_red2 abc_step_l.simps abc_fetch.simps nth_append abc_comp.simps)
 qed
 
 lemma abc_Hoare_plus_unhalt1: 
-  "{P} (A::abc_prog) \<up> \<Longrightarrow> {P} (A [+] B) \<up>"
+  "\<lbrace>P\<rbrace> (A::abc_prog) \<up> \<Longrightarrow> \<lbrace>P\<rbrace> (A [+] B) \<up>"
   apply(rule abc_Hoare_unhaltI)
   apply(subst abc_unhalt_append_eq,force,force)
   by (metis (mono_tags, lifting) abc_notfinal.elims(3) abc_notfinal.simps add_diff_inverse_nat 
       abc_Hoare_unhalt_def le_imp_less_Suc length_abc_comp not_less_eq order_refl trans_le_add1)
 
 lemma notfinal_all_before:
   "\<lbrakk>abc_notfinal (abc_steps_l (0, args) A x) A; y\<le>x \<rbrakk>
   \<Longrightarrow> abc_notfinal (abc_steps_l (0, args) A y) A "
   apply(subgoal_tac "\<exists> d. x = y + d", auto)
    apply(cases "abc_steps_l (0, args) A y",simp)
    apply(rule classical, simp add: abc_steps_add leI halt_steps2)
   by arith
 
 lemma abc_Hoare_plus_unhalt2':
-  assumes unhalt: "{Q} (B::abc_prog) \<up>"
-    and halt: "{P} (A::abc_prog) {Q}"
+  assumes unhalt: "\<lbrace>Q\<rbrace> (B::abc_prog) \<up>"
+    and halt: "\<lbrace>P\<rbrace> (A::abc_prog) \<lbrace>Q\<rbrace>"
     and notnull: "A \<noteq> []"
     and P: "P args" 
   shows "abc_notfinal (abc_steps_l (0, args) (A [+] B) n) (A [+] B)"
 proof -
   obtain st nl stp where a: "abc_final (abc_steps_l (0, args) A stp) A"
     and b: "Q abc_holds_for (length A, nl)"
     and c: "abc_steps_l (0, args) A stp = (st, nl)"
     using halt P unfolding abc_Hoare_halt_def
     by (metis abc_holds_for.simps prod.exhaust)
   obtain stpa where d: 
     "abc_notfinal (abc_steps_l (0, args) A stpa) A \<and> abc_final (abc_steps_l (0, args) A (Suc stpa)) A"
     using abc_before_final[of args A stp,OF a notnull] by metis
   thus "?thesis"
   proof(cases "n < Suc stpa")
     case True
     have h: "n < Suc stpa" by fact
     then have "abc_notfinal (abc_steps_l (0, args) A n) A"
       using d
       by(rule_tac notfinal_all_before, auto)
     moreover then have "abc_steps_l (0, args) (A [+] B) n = abc_steps_l (0, args) A n"
       using notnull
-      by(rule_tac abc_comp_frist_steps_eq_pre, simp_all)
+      by(rule_tac abc_comp_first_steps_eq_pre, simp_all)
     ultimately show "?thesis"
       by(case_tac "abc_steps_l (0, args) A n", simp)
   next
     case False
     have "\<not> n < Suc stpa" by fact
     then obtain d where i1: "n = Suc stpa + d"
       by (metis add_Suc less_iff_Suc_add not_less_eq)
     have "abc_steps_l (0, args) A (Suc stpa) = (length A, nl)"
       using d a c
       apply(case_tac "abc_steps_l (0, args) A stp", simp add: equal_when_halt)
       by(case_tac "abc_steps_l (0, args) A (Suc stpa)", simp add: equal_when_halt)
     moreover have  "abc_steps_l (0, args) (A [+] B) stpa = abc_steps_l (0, args) A stpa"
       using notnull d
-      by(rule_tac abc_comp_frist_steps_eq_pre, simp_all)
+      by(rule_tac abc_comp_first_steps_eq_pre, simp_all)
     ultimately have i2: "abc_steps_l (0, args) (A [+] B) (Suc stpa) = (length A, nl)"
       using d
       apply(case_tac "abc_steps_l (0, args) A stpa", simp)
       by(simp add: abc_step_red2 abc_steps_l.simps abc_fetch.simps abc_comp.simps nth_append)
     obtain s' nl' where i3:"abc_steps_l (0, nl) B d = (s', nl')"
       by (metis prod.exhaust)
     then have i4: "abc_steps_l (0, args) (A [+] B) (Suc stpa + d) = (length A + s', nl')"
       using i2  apply(simp only: abc_steps_add)
       using abc_comp_second_steps_eq[of nl B d s' nl']
       by simp
     moreover have "s' < length B"
       using unhalt b i3
       apply(simp add: abc_Hoare_unhalt_def)
       apply(erule_tac x = nl in allE, simp)
       by(erule_tac x = d in allE, simp)
     ultimately show "?thesis"
       using i1
       by(simp)
   qed
 qed
 
 lemma abc_comp_null_left[simp]: "[] [+] A = A"
 proof(induct A)
   case (Cons a A)
   then show ?case 
     apply(cases a)
     by(auto simp: abc_comp.simps abc_shift.simps)
 qed (auto simp: abc_comp.simps abc_shift.simps)
 
 lemma abc_comp_null_right[simp]: "A [+] [] = A"
 proof(induct A)
   case (Cons a A)
   then show ?case 
     apply(cases a)
     by(auto simp: abc_comp.simps abc_shift.simps)
 qed (auto simp: abc_comp.simps abc_shift.simps)
 
 lemma abc_Hoare_plus_unhalt2:
-  "\<lbrakk>{Q} (B::abc_prog)\<up>; {P} (A::abc_prog) {Q}\<rbrakk>\<Longrightarrow> {P} (A [+] B) \<up>"
+  "\<lbrakk>\<lbrace>Q\<rbrace> (B::abc_prog)\<up>; \<lbrace>P\<rbrace> (A::abc_prog) \<lbrace>Q\<rbrace>\<rbrakk>\<Longrightarrow> \<lbrace>P\<rbrace> (A [+] B) \<up>"
   apply(case_tac "A = []")
    apply(simp add: abc_Hoare_halt_def abc_Hoare_unhalt_def abc_exec_null)
   apply(rule_tac abc_Hoare_unhaltI)
   apply(erule_tac abc_Hoare_plus_unhalt2', simp)
    apply(simp, simp)
   done
 
-end
\ No newline at end of file
+end
diff --git a/thys/Universal_Turing_Machine/Abacus_Mopup.thy b/thys/Universal_Turing_Machine/Abacus_Mopup.thy
--- a/thys/Universal_Turing_Machine/Abacus_Mopup.thy
+++ b/thys/Universal_Turing_Machine/Abacus_Mopup.thy
@@ -1,831 +1,866 @@
 (* Title: thys/Abacus_Mopup.thy
    Author: Jian Xu, Xingyuan Zhang, and Christian Urban
    Modifications: Sebastiaan Joosten
-*)
+   Modifications: Franz Regensburger (FABR) 08/2022
+     additional comments an re-structuring of section hierarchy
+ *)
 
-chapter \<open>Mopup Turing Machine that deletes all "registers", except one\<close>
+chapter \<open>Abacus Programs\<close>
+
+text \<open>Abacus Machines (aka Counter Machines) and their programs
+ are discussed in \cite{Boolos07}.
+They serve as an intermediate computation model in the course of
+the translation of Recursive Functions into Turing Machines.
+\<close>
+
+section \<open>A Mopup Turing Machine that deletes all "registers" on the tape, except one\<close>
+
+text \<open>In this section we define the higher order function mopup\_n\_tm that generates
+a mopup Turing Machine for every argument n. The generated mopup function deletes all
+numerals from the right tape except the n-th one. Such mopup machines will be used
+in order to tidy up the result computed by Turing Machines that were compiled from Abacus programs.
+Refer to  \cite{Boolos07} for more details.
+\<close>
 
 theory Abacus_Mopup
-  imports Uncomputable
+  imports
+    Turing_Hoare
 begin
 
+(* Cleanup the global simpset for proofs of several theorems about tm_dither *)
+
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+
+(* Temporary removal *)
+declare replicate_Suc[simp del]
+
 fun mopup_a :: "nat \<Rightarrow> instr list"
   where
     "mopup_a 0 = []" |
     "mopup_a (Suc n) = mopup_a n @ 
-       [(R, 2*n + 3), (W0, 2*n + 2), (R, 2*n + 1), (W1, 2*n + 2)]"
+       [(R, 2*n + 3), (WB, 2*n + 2), (R, 2*n + 1), (WO, 2*n + 2)]"
 
 definition mopup_b :: "instr list"
   where
-    "mopup_b \<equiv> [(R, 2), (R, 1), (L, 5), (W0, 3), (R, 4), (W0, 3),
-            (R, 2), (W0, 3), (L, 5), (L, 6), (R, 0), (L, 6)]"
+    "mopup_b \<equiv> [(R, 2), (R, 1), (L, 5), (WB, 3), (R, 4), (WB, 3),
+            (R, 2), (WB, 3), (L, 5), (L, 6), (R, 0), (L, 6)]"
 
-fun mopup :: "nat \<Rightarrow> instr list"
+fun mopup_n_tm :: "nat \<Rightarrow> instr list"
   where 
-    "mopup n = mopup_a n @ shift mopup_b (2*n)"
+    "mopup_n_tm n = mopup_a n @ shift mopup_b (2*n)"
 
 type_synonym mopup_type = "config \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> cell list \<Rightarrow> bool"
 
 fun mopup_stop :: "mopup_type"
   where
     "mopup_stop (s, l, r) lm n ires= 
         (\<exists> ln rn. l = Bk\<up>ln @ Bk # Bk # ires \<and> r = <lm ! n> @ Bk\<up>rn)"
 
 fun mopup_bef_erase_a :: "mopup_type"
   where
     "mopup_bef_erase_a (s, l, r) lm n ires= 
          (\<exists> ln m rn. l = Bk\<up>ln @ Bk # Bk # ires \<and> 
                   r = Oc\<up>m@ Bk # <(drop ((s + 1) div 2) lm)> @ Bk\<up>rn)"
 
 fun mopup_bef_erase_b :: "mopup_type"
   where
     "mopup_bef_erase_b (s, l, r) lm n ires = 
       (\<exists> ln m rn. l = Bk\<up>ln @ Bk # Bk # ires \<and> r = Bk # Oc\<up>m @ Bk # 
                                       <(drop (s div 2) lm)> @ Bk\<up>rn)"
 
 fun mopup_jump_over1 :: "mopup_type"
   where
     "mopup_jump_over1 (s, l, r) lm n ires = 
       (\<exists> ln m1 m2 rn. m1 + m2 = Suc (lm ! n) \<and> 
         l = Oc\<up>m1 @ Bk\<up>ln @ Bk # Bk # ires \<and> 
      (r = Oc\<up>m2 @ Bk # <(drop (Suc n) lm)> @ Bk\<up>rn \<or> 
      (r = Oc\<up>m2 \<and> (drop (Suc n) lm) = [])))"
 
 fun mopup_aft_erase_a :: "mopup_type"
   where
     "mopup_aft_erase_a (s, l, r) lm n ires = 
       (\<exists> lnl lnr rn (ml::nat list) m. 
           m = Suc (lm ! n) \<and> l = Bk\<up>lnr @ Oc\<up>m @ Bk\<up>lnl @ Bk # Bk # ires \<and> 
                                    (r = <ml> @ Bk\<up>rn))"
 
 fun mopup_aft_erase_b :: "mopup_type"
   where
     "mopup_aft_erase_b (s, l, r) lm n ires= 
    (\<exists> lnl lnr rn (ml::nat list) m. 
       m = Suc (lm ! n) \<and> 
       l = Bk\<up>lnr @ Oc\<up>m @ Bk\<up>lnl @ Bk # Bk # ires \<and> 
      (r = Bk # <ml> @ Bk\<up>rn \<or>
       r = Bk # Bk # <ml> @ Bk\<up>rn))"
 
 fun mopup_aft_erase_c :: "mopup_type"
   where
     "mopup_aft_erase_c (s, l, r) lm n ires = 
  (\<exists> lnl lnr rn (ml::nat list) m. 
      m = Suc (lm ! n) \<and> 
      l = Bk\<up>lnr @ Oc\<up>m @ Bk\<up>lnl @ Bk # Bk # ires \<and> 
     (r = <ml> @ Bk\<up>rn \<or> r = Bk # <ml> @ Bk\<up>rn))"
 
 fun mopup_left_moving :: "mopup_type"
   where
     "mopup_left_moving (s, l, r) lm n ires = 
   (\<exists> lnl lnr rn m.
      m = Suc (lm ! n) \<and> 
    ((l = Bk\<up>lnr @ Oc\<up>m @ Bk\<up>lnl @ Bk # Bk # ires \<and> r = Bk\<up>rn) \<or>
     (l = Oc\<up>(m - 1) @ Bk\<up>lnl @ Bk # Bk # ires \<and> r = Oc # Bk\<up>rn)))"
 
 fun mopup_jump_over2 :: "mopup_type"
   where
     "mopup_jump_over2 (s, l, r) lm n ires = 
      (\<exists> ln rn m1 m2.
           m1 + m2 = Suc (lm ! n) 
         \<and> r \<noteq> [] 
         \<and> (hd r = Oc \<longrightarrow> (l = Oc\<up>m1 @ Bk\<up>ln @ Bk # Bk # ires \<and> r = Oc\<up>m2 @ Bk\<up>rn)) 
         \<and> (hd r = Bk \<longrightarrow> (l = Bk\<up>ln @ Bk # ires \<and> r = Bk # Oc\<up>(m1+m2)@ Bk\<up>rn)))"
 
 
 fun mopup_inv :: "mopup_type"
   where
     "mopup_inv (s, l, r) lm n ires = 
       (if s = 0 then mopup_stop (s, l, r) lm n ires
        else if s \<le> 2*n then
                if s mod 2 = 1 then mopup_bef_erase_a (s, l, r) lm n ires
                    else mopup_bef_erase_b (s, l, r) lm n ires
             else if s = 2*n + 1 then 
                 mopup_jump_over1 (s, l, r) lm n ires
             else if s = 2*n + 2 then mopup_aft_erase_a (s, l, r) lm n ires
             else if s = 2*n + 3 then mopup_aft_erase_b (s, l, r) lm n ires
             else if s = 2*n + 4 then mopup_aft_erase_c (s, l, r) lm n ires
             else if s = 2*n + 5 then mopup_left_moving (s, l, r) lm n ires
             else if s = 2*n + 6 then mopup_jump_over2 (s, l, r) lm n ires
             else False)"
 
 lemma mop_bef_length[simp]: "length (mopup_a n) = 4 * n"
   by(induct n, simp_all)
 
 lemma mopup_a_nth: 
   "\<lbrakk>q < n; x < 4\<rbrakk> \<Longrightarrow> mopup_a n ! (4 * q + x) = 
                              mopup_a (Suc q) ! ((4 * q) + x)"
 proof(induct n)
   case (Suc n)
   then show ?case 
     by(cases "q < n";cases "q = n", auto simp add: nth_append)
 qed auto
 
 lemma fetch_bef_erase_a_o[simp]: 
   "\<lbrakk>0 < s; s \<le> 2 * n; s mod 2 = Suc 0\<rbrakk>
-  \<Longrightarrow> (fetch (mopup_a n @ shift mopup_b (2 * n)) s Oc) = (W0, s + 1)"
+  \<Longrightarrow> (fetch (mopup_a n @ shift mopup_b (2 * n)) s Oc) = (WB, s + 1)"
   apply(subgoal_tac "\<exists> q. s = 2*q + 1", auto)
    apply(subgoal_tac "length (mopup_a n) = 4*n")
     apply(auto simp: nth_append)
    apply(subgoal_tac "mopup_a n ! (4 * q + 1) = 
                       mopup_a (Suc q) ! ((4 * q) + 1)", 
       simp add: nth_append)
    apply(rule mopup_a_nth, auto)
   apply arith
   done
 
 lemma fetch_bef_erase_a_b[simp]:
   "\<lbrakk>0 < s; s \<le> 2 * n; s mod 2 = Suc 0\<rbrakk>
    \<Longrightarrow>  (fetch (mopup_a n @ shift mopup_b (2 * n)) s Bk) = (R, s + 2)"
   apply(subgoal_tac "\<exists> q. s = 2*q + 1", auto)
    apply(subgoal_tac "length (mopup_a n) = 4*n")
     apply(auto simp: nth_append)
    apply(subgoal_tac "mopup_a n ! (4 * q + 0) = 
                        mopup_a (Suc q) ! ((4 * q + 0))", 
       simp add: nth_append)
    apply(rule mopup_a_nth, auto)
   apply arith
   done
 
 lemma fetch_bef_erase_b_b: 
   assumes "n < length lm" "0 < s" "s \<le> 2 * n" "s mod 2 = 0"
   shows "(fetch (mopup_a n @ shift mopup_b (2 * n)) s Bk) = (R, s - 1)"
 proof -
   from assms obtain q where q:"s = 2 * q" by auto
   then obtain nat where nat:"q = Suc nat" using assms(2) by (cases q, auto)
   from assms(3) mopup_a_nth[of nat n 2]
   have "mopup_a n ! (4 * nat + 2) = mopup_a (Suc nat) ! ((4 * nat) + 2)"
     unfolding nat q by auto
   thus ?thesis using assms nat q by (auto simp: nth_append)
 qed
 
 lemma fetch_jump_over1_o: 
   "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (2 * n)) Oc
   = (R, Suc (2 * n))"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemma fetch_jump_over1_b: 
   "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (2 * n)) Bk 
  = (R, Suc (Suc (2 * n)))"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemma fetch_aft_erase_a_o: 
   "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (Suc (2 * n))) Oc 
- = (W0, Suc (2 * n + 2))"
+ = (WB, Suc (2 * n + 2))"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemma fetch_aft_erase_a_b: 
   "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (Suc (2 * n))) Bk
   = (L, Suc (2 * n + 4))"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemma fetch_aft_erase_b_b: 
   "fetch (mopup_a n @ shift mopup_b (2 * n)) (2*n + 3) Bk
   = (R, Suc (2 * n + 3))"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(subgoal_tac "2*n + 3 = Suc (2*n + 2)", simp only: fetch.simps)
     apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemma fetch_aft_erase_c_o: 
   "fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 4) Oc 
- = (W0, Suc (2 * n + 2))"
+ = (WB, Suc (2 * n + 2))"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(subgoal_tac "2*n + 4 = Suc (2*n + 3)", simp only: fetch.simps)
     apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemma fetch_aft_erase_c_b: 
   "fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 4) Bk 
  = (R, Suc (2 * n + 1))"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(subgoal_tac "2*n + 4 = Suc (2*n + 3)", simp only: fetch.simps)
     apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemma fetch_left_moving_o: 
   "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 5) Oc) 
  = (L, 2*n + 6)"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(subgoal_tac "2*n + 5 = Suc (2*n + 4)", simp only: fetch.simps)
     apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemma fetch_left_moving_b: 
   "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 5) Bk)
   = (L, 2*n + 5)"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(subgoal_tac "2*n + 5 = Suc (2*n + 4)", simp only: fetch.simps)
     apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemma fetch_jump_over2_b:
   "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 6) Bk) 
  = (R, 0)"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(subgoal_tac "2*n + 6 = Suc (2*n + 5)", simp only: fetch.simps)
     apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemma fetch_jump_over2_o: 
   "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 6) Oc) 
  = (L, 2*n + 6)"
   apply(subgoal_tac "length (mopup_a n) = 4 * n")
    apply(subgoal_tac "2*n + 6 = Suc (2*n + 5)", simp only: fetch.simps)
     apply(auto simp: mopup_b_def nth_append shift.simps)
   done
 
 lemmas mopupfetchs = 
   fetch_bef_erase_a_o fetch_bef_erase_a_b fetch_bef_erase_b_b 
   fetch_jump_over1_o fetch_jump_over1_b fetch_aft_erase_a_o 
   fetch_aft_erase_a_b fetch_aft_erase_b_b fetch_aft_erase_c_o 
   fetch_aft_erase_c_b fetch_left_moving_o fetch_left_moving_b 
   fetch_jump_over2_b fetch_jump_over2_o
 
 declare 
   mopup_jump_over2.simps[simp del] mopup_left_moving.simps[simp del]
   mopup_aft_erase_c.simps[simp del] mopup_aft_erase_b.simps[simp del] 
   mopup_aft_erase_a.simps[simp del] mopup_jump_over1.simps[simp del]
   mopup_bef_erase_a.simps[simp del] mopup_bef_erase_b.simps[simp del]
   mopup_stop.simps[simp del]
 
 lemma mopup_bef_erase_b_Bk_via_a_Oc[simp]: 
   "\<lbrakk>mopup_bef_erase_a (s, l, Oc # xs) lm n ires\<rbrakk> \<Longrightarrow> 
   mopup_bef_erase_b (Suc s, l, Bk # xs) lm n ires"
   apply(auto simp: mopup_bef_erase_a.simps mopup_bef_erase_b.simps)
   by (metis cell.distinct(1) hd_append list.sel(1) list.sel(3) tl_append2 tl_replicate)
 
 lemma mopup_false1:
   "\<lbrakk>0 < s; s \<le> 2 * n; s mod 2 = Suc 0;  \<not> Suc s \<le> 2 * n\<rbrakk> 
   \<Longrightarrow> RR"
   apply(arith)
   done
 
 lemma mopup_bef_erase_a_implies_two[simp]: 
   "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n; s mod 2 = Suc 0; 
    mopup_bef_erase_a (s, l, Oc # xs) lm n ires; r = Oc # xs\<rbrakk>
  \<Longrightarrow> (Suc s \<le> 2 * n \<longrightarrow> mopup_bef_erase_b (Suc s, l, Bk # xs) lm n ires)  \<and>
      (\<not> Suc s \<le> 2 * n \<longrightarrow> mopup_jump_over1 (Suc s, l, Bk # xs) lm n ires) "
   apply(auto elim!: mopup_false1)
   done
 
 lemma tape_of_nl_cons: "<m # lm> = (if lm = [] then Oc\<up>(Suc m)
                     else Oc\<up>(Suc m) @ Bk # <lm>)"
   by(cases lm, simp_all add: tape_of_list_def  tape_of_nat_def split: if_splits)
 
 lemma drop_tape_of_cons: 
   "\<lbrakk>Suc q < length lm; x = lm ! q\<rbrakk> \<Longrightarrow> <drop q lm> = Oc # Oc \<up> x @ Bk # <drop (Suc q) lm>"
   using Suc_lessD append_Cons list.simps(2) Cons_nth_drop_Suc replicate_Suc tape_of_nl_cons
   by metis
 
 lemma erase2jumpover1:
   "\<lbrakk>q < length list; 
              \<forall>rn. <drop q list> \<noteq> Oc # Oc \<up> (list ! q) @ Bk # <drop (Suc q) list> @ Bk \<up> rn\<rbrakk>
        \<Longrightarrow> <drop q list> = Oc # Oc \<up> (list ! q)"
   apply(erule_tac x = 0 in allE, simp)
   apply(cases "Suc q < length list")
    apply(erule_tac notE)
    apply(rule_tac drop_tape_of_cons, simp_all)
   apply(subgoal_tac "length list = Suc q", auto)
   apply(subgoal_tac "drop q list = [list ! q]")
    apply(simp add: tape_of_nat_def tape_of_list_def replicate_Suc)
   by (metis append_Nil2 append_eq_conv_conj Cons_nth_drop_Suc lessI)
 
 lemma erase2jumpover2:
   "\<lbrakk>q < length list; \<forall>rn. <drop q list> @ Bk # Bk \<up> n \<noteq>
   Oc # Oc \<up> (list ! q) @ Bk # <drop (Suc q) list> @ Bk \<up> rn\<rbrakk>
   \<Longrightarrow> RR"
   apply(cases "Suc q < length list")
    apply(erule_tac x = "Suc n" in allE, simp)
    apply(erule_tac notE, simp add: replicate_Suc)
    apply(rule_tac drop_tape_of_cons, simp_all)
   apply(subgoal_tac "length list = Suc q", auto)
   apply(erule_tac x = "n" in allE, simp add: tape_of_list_def)
   by (metis append_Nil2 append_eq_conv_conj Cons_nth_drop_Suc lessI replicate_Suc tape_of_list_def tape_of_nl_cons)
 
 lemma mod_ex1: "(a mod 2 = Suc 0) = (\<exists> q. a = Suc (2 * q))"
   by arith
 
 declare replicate_Suc[simp]
 
 lemma mopup_bef_erase_a_2_jump_over[simp]:
   "\<lbrakk>n < length lm; 0 < s; s mod 2 = Suc 0;  s \<le> 2 * n;
    mopup_bef_erase_a (s, l, Bk # xs) lm n ires; \<not> (Suc (Suc s) \<le> 2 * n)\<rbrakk> 
 \<Longrightarrow> mopup_jump_over1 (s', Bk # l, xs) lm n ires"
 proof(cases n)
   case (Suc nat)
   assume assms: "n < length lm" "0 < s" "s mod 2 = Suc 0" "s \<le> 2 * n"
     "mopup_bef_erase_a (s, l, Bk # xs) lm n ires" "\<not> (Suc (Suc s) \<le> 2 * n)"
   from assms obtain a lm' where Cons:"lm = Cons a lm'" by (cases lm,auto)
   from assms have n:"Suc s div 2 = n" by auto
   have [simp]:"s = Suc (2 * q) \<longleftrightarrow> q = nat" for q using assms Suc by presburger
   from assms obtain ln m rn where ln:"l = Bk \<up> ln @ Bk # Bk # ires"
     and "Bk # xs = Oc \<up> m @ Bk # <drop (Suc s div 2) lm> @ Bk \<up> rn"
     by (auto simp: mopup_bef_erase_a.simps mopup_jump_over1.simps)
   hence xs:"xs = <drop n lm> @ Bk \<up> rn" by(cases m;auto simp: n mod_ex1)
   have [intro]:"nat < length lm' \<Longrightarrow>
     \<forall>rna. xs \<noteq> Oc # Oc \<up> (lm' ! nat) @ Bk # <drop (Suc nat) lm'> @ Bk \<up> rna \<Longrightarrow>
     <drop nat lm'> @ Bk \<up> rn = Oc # Oc \<up> (lm' ! nat)"
     by(cases rn, auto elim: erase2jumpover1 erase2jumpover2 simp:xs Suc Cons)
   have [intro]:"<drop nat lm'> \<noteq> Oc # Oc \<up> (lm' ! nat) @ Bk # <drop (Suc nat) lm'> @ Bk \<up> 0 \<Longrightarrow> length lm' \<le> Suc nat"
     using drop_tape_of_cons[of nat lm'] by fastforce
   from assms(1,3) have [intro!]:"
             0 + Suc (lm' ! nat) = Suc (lm' ! nat) \<and>
             Bk # Bk \<up> ln = Oc \<up> 0 @ Bk \<up> Suc ln \<and>
             ((\<exists>rna. xs = Oc \<up> Suc (lm' ! nat) @ Bk # <drop (Suc nat) lm'> @ Bk \<up> rna) \<or>
              xs = Oc \<up> Suc (lm' ! nat) \<and> length lm' \<le> Suc nat)"
     by (auto simp:Cons ln xs Suc)
   from assms(1,3) show ?thesis unfolding Cons ln Suc
     by(auto simp: mopup_bef_erase_a.simps mopup_jump_over1.simps simp del:split_head_repeat)
 qed auto
 
 
 lemma Suc_Suc_div:  "\<lbrakk>0 < s; s mod 2 = Suc 0; Suc (Suc s) \<le> 2 * n\<rbrakk>
            \<Longrightarrow> (Suc (Suc (s div 2))) \<le> n" by(arith)
 
 lemma mopup_bef_erase_a_2_a[simp]: 
   assumes "n < length lm" "0 < s" "s mod 2 = Suc 0" 
     "mopup_bef_erase_a (s, l, Bk # xs) lm n ires"
     "Suc (Suc s) \<le> 2 * n"
   shows "mopup_bef_erase_a (Suc (Suc s), Bk # l, xs) lm n ires"
 proof-
   from assms obtain rn m ln where
     rn:"l = Bk \<up> ln @ Bk # Bk # ires" "Bk # xs = Oc \<up> m @ Bk # <drop (Suc s div 2) lm> @ Bk \<up> rn"
     by (auto simp: mopup_bef_erase_a.simps)
   hence m:"m = 0" using assms by (cases m,auto)
   hence d:"drop (Suc (Suc (s div 2))) lm \<noteq> []"
     using assms(1,3,5) by auto arith
   hence "Bk # l = Bk \<up> Suc ln @ Bk # Bk # ires \<and>
     xs = Oc \<up> Suc (lm ! (Suc s div 2)) @ Bk # <drop ((Suc (Suc s) + 1) div 2) lm> @ Bk \<up> rn"
     using rn by(auto intro:drop_tape_of_cons simp:m) 
   thus ?thesis unfolding mopup_bef_erase_a.simps by blast
 qed
 
 lemma mopup_false2: 
   "\<lbrakk>0 < s; s \<le> 2 * n; 
    s mod 2 = Suc 0; Suc s \<noteq> 2 * n;
    \<not> Suc (Suc s) \<le> 2 * n\<rbrakk> \<Longrightarrow> RR"
   by(arith)
 
 lemma ariths[simp]: "\<lbrakk>0 < s; s \<le> 2 *n; s mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow> 
                                       (s - Suc 0) mod 2 = Suc 0"
   "\<lbrakk>0 < s; s \<le> 2 *n; s mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow>
                                        s - Suc 0 \<le> 2 * n"
   "\<lbrakk>0 < s; s \<le> 2 *n; s mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow> \<not> s \<le> Suc 0"
   by(arith)+
 
 lemma take_suc[intro]:
   "\<exists>lna. Bk # Bk \<up> ln = Bk \<up> lna"
   by(rule_tac x = "Suc ln" in exI, simp)
 
 
 lemma mopup_bef_erase[simp]: "mopup_bef_erase_a (s, l, []) lm n ires \<Longrightarrow> 
                         mopup_bef_erase_a (s, l, [Bk]) lm n ires"
   "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n; s mod 2 = Suc 0; \<not> Suc (Suc s) \<le> 2 *n;
      mopup_bef_erase_a (s, l, []) lm n ires\<rbrakk>
     \<Longrightarrow>  mopup_jump_over1 (s', Bk # l, []) lm n ires"
   "mopup_bef_erase_b (s, l, Oc # xs) lm n ires \<Longrightarrow> l \<noteq> []"
   "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n; 
                s mod 2 \<noteq> Suc 0; 
                mopup_bef_erase_b (s, l, Bk # xs) lm n ires; r = Bk # xs\<rbrakk> 
            \<Longrightarrow> mopup_bef_erase_a (s - Suc 0, Bk # l, xs) lm n ires"
   "\<lbrakk>mopup_bef_erase_b (s, l, []) lm n ires\<rbrakk> \<Longrightarrow> 
                    mopup_bef_erase_a (s - Suc 0, Bk # l, []) lm n ires"
   by(auto simp: mopup_bef_erase_b.simps mopup_bef_erase_a.simps)
 
 
 lemma mopup_jump_over1_in_ctx[simp]:
   assumes "mopup_jump_over1 (Suc (2 * n), l, Oc # xs) lm n ires"
   shows "mopup_jump_over1 (Suc (2 * n), Oc # l, xs) lm n ires"
 proof -
   from assms obtain ln m1 m2 rn where
     "m1 + m2 = Suc (lm ! n)"
     "l = Oc \<up> m1 @ Bk \<up> ln @ Bk # Bk # ires"
     "(Oc # xs = Oc \<up> m2 @ Bk # <drop (Suc n) lm> @ Bk \<up> rn \<or>
          Oc # xs = Oc \<up> m2 \<and> drop (Suc n) lm = [])" unfolding mopup_jump_over1.simps by blast
   thus ?thesis unfolding mopup_jump_over1.simps
     apply(rule_tac x = ln in exI, rule_tac x = "Suc m1" in exI
         ,rule_tac x = "m2 - 1" in exI)
     by(cases "m2", auto)
 qed
 
 lemma mopup_jump_over1_2_aft_erase_a[simp]:  
   assumes "mopup_jump_over1 (Suc (2 * n), l, Bk # xs) lm n ires"
   shows "mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, xs) lm n ires"
 proof -
   from assms obtain ln m1 m2 rn where
     "m1 + m2 = Suc (lm ! n)"
     "l = Oc \<up> m1 @ Bk \<up> ln @ Bk # Bk # ires"
     "(Bk # xs = Oc \<up> m2 @ Bk # <drop (Suc n) lm> @ Bk \<up> rn \<or>
         Bk # xs = Oc \<up> m2 \<and> drop (Suc n) lm = [])" unfolding mopup_jump_over1.simps by blast
   thus ?thesis unfolding mopup_aft_erase_a.simps
     apply( rule_tac x = ln in exI, rule_tac x = "Suc 0" in exI,rule_tac x = rn in exI
         , rule_tac x = "drop (Suc n) lm" in exI)
     by(cases m2, auto)
 qed
 
 lemma mopup_aft_erase_a_via_jump_over1[simp]: 
   "\<lbrakk>mopup_jump_over1 (Suc (2 * n), l, []) lm n ires\<rbrakk> \<Longrightarrow> 
     mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, []) lm n ires"
 proof(rule mopup_jump_over1_2_aft_erase_a)
   assume a:"mopup_jump_over1 (Suc (2 * n), l, []) lm n ires"
   then obtain ln where ln:"length lm \<le> Suc n \<Longrightarrow> l = Oc # Oc \<up> (lm ! n) @ Bk \<up> ln @ Bk # Bk # ires"
     unfolding mopup_jump_over1.simps by auto
   show "mopup_jump_over1 (Suc (2 * n), l, [Bk]) lm n ires"
     unfolding mopup_jump_over1.simps
     apply(rule_tac x = ln in exI, rule_tac x = "Suc (lm ! n)" in exI, 
         rule_tac x = 0 in exI)
     using a ln by(auto simp: mopup_jump_over1.simps tape_of_list_def )
 qed
 
-lemma tape_of_list_empty[simp]: "<[]> = []" by(simp add: tape_of_list_def)
+(*
+The lemma was moved to Numerals.thy by FABR
 
-lemma mopup_aft_erase_b_via_a[simp]: 
+lemma tape_of_list_empty[simp]: "<[]> = []" by (simp add: tape_of_list_def)
+*)
+
+lemma mopup_aft_erase_b_via_a[simp]:
   assumes "mopup_aft_erase_a (Suc (Suc (2 * n)), l, Oc # xs) lm n ires"
   shows "mopup_aft_erase_b (Suc (Suc (Suc (2 * n))), l, Bk # xs) lm n ires"
 proof -
   from assms obtain lnl lnr rn ml where
     assms:
     "l = Bk \<up> lnr @ Oc \<up> Suc (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
     "Oc # xs = <ml::nat list> @ Bk \<up> rn"
     unfolding mopup_aft_erase_a.simps by auto
   then obtain a list where ml:"ml = a # list" by (cases ml,cases rn,auto)
   with assms show ?thesis unfolding mopup_aft_erase_b.simps
     apply(auto simp add: tape_of_nl_cons split: if_splits)
      apply(cases a, simp_all)
       apply(rule_tac x = rn in exI, rule_tac x = "[]" in exI, force)
      apply(rule_tac x = rn in exI, rule_tac x = "[a-1]" in exI)
      apply(cases "a"; force simp add: tape_of_list_def tape_of_nat_def) 
     apply(cases "a")
      apply(rule_tac x = rn in exI, rule_tac x = list in exI, force)
     apply(rule_tac x = rn in exI,rule_tac x = "(a-1) # list" in exI, simp add: tape_of_nl_cons)
     done
 qed
 
 lemma mopup_left_moving_via_aft_erase_a[simp]:
   assumes "mopup_aft_erase_a (Suc (Suc (2 * n)), l, Bk # xs) lm n ires"
   shows "mopup_left_moving (5 + 2 * n, tl l, hd l # Bk # xs) lm n ires"
 proof-
   from assms[unfolded mopup_aft_erase_a.simps] obtain lnl lnr rn ml where
     "l = Bk \<up> lnr @ Oc \<up> Suc (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
     "Bk # xs = <ml::nat list> @ Bk \<up> rn"
     by auto
   thus ?thesis unfolding mopup_left_moving.simps
     by(cases lnr;cases ml,auto simp: tape_of_nl_cons)
 qed
 
 lemma mopup_aft_erase_a_nonempty[simp]:
   "mopup_aft_erase_a (Suc (Suc (2 * n)), l, xs) lm n ires \<Longrightarrow> l \<noteq> []"
   by(auto simp only: mopup_aft_erase_a.simps)
 
 lemma mopup_left_moving_via_aft_erase_a_emptylst[simp]:
   assumes "mopup_aft_erase_a (Suc (Suc (2 * n)), l, []) lm n ires"
   shows "mopup_left_moving (5 + 2 * n, tl l, [hd l]) lm n ires"
 proof -
   have [intro!]:"[Bk] = Bk \<up> 1" by auto
   from assms obtain lnl lnr where "l = Bk \<up> lnr @ Oc # Oc \<up> (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
     unfolding mopup_aft_erase_a.simps by auto
   thus ?thesis by(case_tac lnr, auto simp add:mopup_left_moving.simps)
 qed
 
 lemma mopup_aft_erase_b_no_Oc[simp]: "mopup_aft_erase_b (2 * n + 3, l, Oc # xs) lm n ires = False"
   by(auto simp: mopup_aft_erase_b.simps)
 
 lemma tape_of_ex1[intro]: 
   "\<exists>rna ml. Oc \<up> a @ Bk \<up> rn = <ml::nat list> @ Bk \<up> rna \<or> Oc \<up> a @ Bk \<up> rn = Bk # <ml> @ Bk \<up> rna"
   by(rule_tac x = rn in exI, rule_tac x = "if a = 0 then [] else [a-1]" in exI,
       simp add: tape_of_list_def tape_of_nat_def)
 
 lemma mopup_aft_erase_b_via_c_helper: "\<exists>rna ml. Oc \<up> a @ Bk # <list::nat list> @ Bk \<up> rn = 
   <ml> @ Bk \<up> rna \<or> Oc \<up> a @ Bk # <list> @ Bk \<up> rn = Bk # <ml::nat list> @ Bk \<up> rna"
   apply(cases "list = []", simp add: replicate_Suc[THEN sym] del: replicate_Suc split_head_repeat)
    apply(rule_tac rn = "Suc rn" in tape_of_ex1)
   apply(cases a, simp)
    apply(rule_tac x = rn in exI, rule_tac x = list in exI, simp)
   apply(rule_tac x = rn in exI, rule_tac x = "(a-1) # list" in exI)
   apply(simp add: tape_of_nl_cons)
   done
 
 lemma mopup_aft_erase_b_via_c[simp]: 
   assumes "mopup_aft_erase_c (2 * n + 4, l, Oc # xs) lm n ires"
   shows "mopup_aft_erase_b (Suc (Suc (Suc (2 * n))), l, Bk # xs) lm n ires"
 proof-
   from assms obtain lnl rn lnr ml where assms:
     "l = Bk \<up> lnr @ Oc # Oc \<up> (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
     "Oc # xs = <ml::nat list> @ Bk \<up> rn" unfolding mopup_aft_erase_c.simps by auto
   hence "Oc # xs = Bk \<up> rn \<Longrightarrow> False" by(cases rn,auto)
   thus ?thesis using assms unfolding mopup_aft_erase_b.simps
     by(cases ml)
       (auto simp add: tape_of_nl_cons split: if_splits intro:mopup_aft_erase_b_via_c_helper
         simp del:split_head_repeat)
 qed
 
 lemma mopup_aft_erase_c_aft_erase_a[simp]: 
   assumes "mopup_aft_erase_c (2 * n + 4, l, Bk # xs) lm n ires"
   shows "mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, xs) lm n ires"
 proof -
   from assms obtain lnl lnr rn ml where
     "l = Bk \<up> lnr @ Oc \<up> Suc (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
     "(Bk # xs = <ml::nat list> @ Bk \<up> rn \<or> Bk # xs = Bk # <ml> @ Bk \<up> rn)"
     unfolding mopup_aft_erase_c.simps by auto
   thus ?thesis unfolding mopup_aft_erase_a.simps
     apply(clarify)
     apply(erule disjE)
      apply(subgoal_tac "ml = []", simp, case_tac rn, 
         simp, simp, rule conjI)
        apply(rule_tac x = lnl in exI, rule_tac x = "Suc lnr" in exI, simp)
       apply (insert tape_of_list_empty,blast)
      apply(case_tac ml, simp, simp add: tape_of_nl_cons split: if_splits)
     apply(rule_tac x = lnl in exI, rule_tac x = "Suc lnr" in exI)
     apply(rule_tac x = rn in exI, rule_tac x = "ml" in exI, simp)
     done
 qed
 
 lemma mopup_aft_erase_a_via_c[simp]: 
   "\<lbrakk>mopup_aft_erase_c (2 * n + 4, l, []) lm n ires\<rbrakk> 
  \<Longrightarrow> mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, []) lm n ires"
   by (rule mopup_aft_erase_c_aft_erase_a)
     (auto simp:mopup_aft_erase_c.simps)
 
 lemma mopup_aft_erase_b_2_aft_erase_c[simp]:
   assumes "mopup_aft_erase_b (2 * n + 3, l, Bk # xs) lm n ires"
   shows "mopup_aft_erase_c (4 + 2 * n, Bk # l, xs) lm n ires"
 proof -
   from assms obtain lnl lnr ml rn where
     "l = Bk \<up> lnr @ Oc \<up> Suc (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
     "Bk # xs = Bk # <ml::nat list> @ Bk \<up> rn \<or> Bk # xs = Bk # Bk # <ml> @ Bk \<up> rn"
     unfolding  mopup_aft_erase_b.simps by auto
   thus ?thesis unfolding mopup_aft_erase_c.simps
     by (rule_tac x = "lnl" in exI) auto
 qed
 
 lemma mopup_aft_erase_c_via_b[simp]: 
   "\<lbrakk>mopup_aft_erase_b (2 * n + 3, l, []) lm n ires\<rbrakk> 
  \<Longrightarrow> mopup_aft_erase_c (4 + 2 * n, Bk # l, []) lm n ires"
   by(auto simp add: mopup_aft_erase_b.simps intro:mopup_aft_erase_b_2_aft_erase_c)
 
 lemma mopup_left_moving_nonempty[simp]: 
   "mopup_left_moving (2 * n + 5, l, Oc # xs) lm n ires \<Longrightarrow> l \<noteq> []"
   by(auto simp: mopup_left_moving.simps)
 
 lemma exp_ind: "a\<up>(Suc x) = a\<up>x @ [a]"
   by(induct x, auto)
 
 lemma mopup_jump_over2_via_left_moving[simp]:  
   "\<lbrakk>mopup_left_moving (2 * n + 5, l, Oc # xs) lm n ires\<rbrakk>
   \<Longrightarrow> mopup_jump_over2 (2 * n + 6, tl l, hd l # Oc # xs) lm n ires"
   apply(simp only: mopup_left_moving.simps mopup_jump_over2.simps)
   apply(erule_tac exE)+
   apply(erule conjE, erule disjE, erule conjE)
    apply (simp add: Cons_replicate_eq)
   apply(rename_tac Lnl lnr rn m)
   apply(cases "hd l", simp add:  )
    apply(cases "lm ! n", simp)
     apply(rule exI, rule_tac x = "length xs" in exI, 
       rule_tac x = "Suc 0" in exI, rule_tac x = 0 in exI)
     apply(case_tac Lnl, simp,simp,  simp add: exp_ind[THEN sym])
    apply(cases "lm ! n", simp)
    apply(case_tac Lnl, simp, simp)
   apply(rule_tac x = Lnl in exI, rule_tac x = "length xs" in exI, auto)
   apply(cases "lm ! n", simp)
    apply(case_tac Lnl, simp_all add: numeral_2_eq_2)
   done
 
 lemma mopup_left_moving_nonempty_snd[simp]: "mopup_left_moving (2 * n + 5, l, xs) lm n ires \<Longrightarrow> l \<noteq> []"
   apply(auto simp: mopup_left_moving.simps)
   done
 
 lemma mopup_left_moving_hd_Bk[simp]:
   "\<lbrakk>mopup_left_moving (2 * n + 5, l, Bk # xs) lm n ires\<rbrakk> 
  \<Longrightarrow> mopup_left_moving (2 * n + 5, tl l, hd l # Bk # xs) lm n ires"
   apply(simp only: mopup_left_moving.simps)
   apply(erule exE)+ apply(rename_tac lnl Lnr rn m)
   apply(case_tac Lnr, auto)
   done
 
 lemma mopup_left_moving_emptylist[simp]: 
   "\<lbrakk>mopup_left_moving (2 * n + 5, l, []) lm n ires\<rbrakk>
     \<Longrightarrow> mopup_left_moving (2 * n + 5, tl l, [hd l]) lm n ires"
   apply(simp only: mopup_left_moving.simps)
   apply(erule exE)+ apply(rename_tac lnl Lnr rn m)
   apply(case_tac Lnr, auto)
   apply(rule_tac x = 1 in exI, simp)
   done
 
 
 lemma mopup_jump_over2_Oc_nonempty[simp]: 
   "mopup_jump_over2 (2 * n + 6, l, Oc # xs) lm n ires \<Longrightarrow> l \<noteq> []"
   apply(auto simp: mopup_jump_over2.simps )
   done
 
 lemma mopup_jump_over2_context[simp]: 
   "\<lbrakk>mopup_jump_over2 (2 * n + 6, l, Oc # xs) lm n ires\<rbrakk>
  \<Longrightarrow>  mopup_jump_over2 (2 * n + 6, tl l, hd l # Oc # xs) lm n ires"
   apply(simp only: mopup_jump_over2.simps)
   apply(erule_tac exE)+
   apply(simp, erule conjE, erule_tac conjE)
   apply(rename_tac Ln Rn M1 M2)
   apply(case_tac M1, simp)
    apply(rule_tac x = Ln in exI, rule_tac x = Rn in exI, 
       rule_tac x = 0 in exI)
    apply(case_tac Ln, simp, simp, simp only: exp_ind[THEN sym], simp)
   apply(rule_tac x = Ln in exI, rule_tac x = Rn in exI, 
       rule_tac x = "M1-1" in exI, rule_tac x = "Suc M2" in exI, simp)
   done
 
 lemma mopup_stop_via_jump_over2[simp]: 
   "\<lbrakk>mopup_jump_over2 (2 * n + 6, l, Bk # xs) lm n ires\<rbrakk> 
   \<Longrightarrow> mopup_stop (0, Bk # l, xs) lm n ires"
   apply(auto simp: mopup_jump_over2.simps mopup_stop.simps tape_of_nat_def)
   apply(simp add: exp_ind[THEN sym])
   done
 
 lemma mopup_jump_over2_nonempty[simp]: "mopup_jump_over2 (2 * n + 6, l, []) lm n ires = False"
   by(auto simp: mopup_jump_over2.simps)
 
 declare fetch.simps[simp del]
 lemma mod_ex2: "(a mod (2::nat) = 0) = (\<exists> q. a = 2 * q)"
   by arith
 
 lemma mod_2: "x mod 2  = 0 \<or>  x mod 2 = Suc 0"
   by arith
 
 
 lemma mopup_inv_step:
   "\<lbrakk>n < length lm; mopup_inv (s, l, r) lm n ires\<rbrakk>
   \<Longrightarrow> mopup_inv (step (s, l, r) (mopup_a n @ shift mopup_b (2 * n), 0)) lm n ires"
   apply(cases r;cases "hd r")
      apply(auto split:if_splits simp add:step.simps mopupfetchs fetch.simps(1))
       apply(drule_tac mopup_false2, simp_all add: mopup_bef_erase_b.simps)
     apply(drule_tac mopup_false2, simp_all)
    apply(drule_tac mopup_false2, simp_all)
   by presburger
 
 declare mopup_inv.simps[simp del]
 lemma mopup_inv_steps: 
   "\<lbrakk>n < length lm; mopup_inv (s, l, r) lm n ires\<rbrakk> \<Longrightarrow> 
      mopup_inv (steps (s, l, r) (mopup_a n @ shift mopup_b (2 * n), 0)  stp) lm n ires"
 proof(induct stp)
   case (Suc stp)
   then show ?case 
     by ( cases "steps (s, l, r) 
                 (mopup_a n @ shift mopup_b (2 * n), 0) stp"
         , auto simp add: steps.simps intro:mopup_inv_step)
 qed (auto simp add: steps.simps)
 
 fun abc_mopup_stage1 :: "config \<Rightarrow> nat \<Rightarrow> nat"
   where
     "abc_mopup_stage1 (s, l, r) n = 
            (if s > 0 \<and> s \<le> 2*n then 6
             else if s = 2*n + 1 then 4
             else if s \<ge> 2*n + 2 \<and> s \<le> 2*n + 4 then 3
             else if s = 2*n + 5 then 2
             else if s = 2*n + 6 then 1
             else 0)"
 
 fun abc_mopup_stage2 :: "config \<Rightarrow> nat \<Rightarrow> nat"
   where
     "abc_mopup_stage2 (s, l, r) n = 
            (if s > 0 \<and> s \<le> 2*n then length r
             else if s = 2*n + 1 then length r
             else if s = 2*n + 5 then length l
             else if s = 2*n + 6 then length l
             else if s \<ge> 2*n + 2 \<and> s \<le> 2*n + 4 then length r
             else 0)"
 
 fun abc_mopup_stage3 :: "config \<Rightarrow> nat \<Rightarrow> nat"
   where
     "abc_mopup_stage3 (s, l, r) n = 
           (if s > 0 \<and> s \<le> 2*n then 
               if hd r = Bk then 0
               else 1
            else if s = 2*n + 2 then 1 
            else if s = 2*n + 3 then 0
            else if s = 2*n + 4 then 2
            else 0)"
 
 definition
   "abc_mopup_measure = measures [\<lambda>(c, n). abc_mopup_stage1 c n, 
                                  \<lambda>(c, n). abc_mopup_stage2 c n, 
                                  \<lambda>(c, n). abc_mopup_stage3 c n]"
 
 lemma wf_abc_mopup_measure:
   shows "wf abc_mopup_measure" 
   unfolding abc_mopup_measure_def 
   by auto
 
 lemma abc_mopup_measure_induct [case_names Step]: 
   "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> abc_mopup_measure\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
   using wf_abc_mopup_measure
   by (metis wf_iff_no_infinite_down_chain)
 
 lemma mopup_erase_nonempty[simp]:
   "mopup_bef_erase_a (a, aa, []) lm n ires = False"
   "mopup_bef_erase_b (a, aa, []) lm n ires = False"
   "mopup_aft_erase_b (2 * n + 3, aa, []) lm n ires = False"
   by(auto simp: mopup_bef_erase_a.simps mopup_bef_erase_b.simps mopup_aft_erase_b.simps)
 
 declare mopup_inv.simps[simp del]
 
 lemma fetch_mopup_a_shift[simp]: 
   assumes "0 < q" "q \<le> n"
   shows "fetch (mopup_a n @ shift mopup_b (2 * n)) (2*q) Bk = (R, 2*q - 1)"
 proof(cases q)
   case (Suc nat) with assms
   have "mopup_a n ! (4 * nat + 2) = mopup_a (Suc nat) ! ((4 * nat) + 2)" using assms
     by (metis Suc_le_lessD add_2_eq_Suc' less_Suc_eq mopup_a_nth numeral_Bit0)
   then show ?thesis using assms Suc
     by(auto simp: fetch.simps nth_of.simps nth_append)
 qed (insert assms,auto)
 
 lemma mopup_halt:
   assumes 
     less: "n < length lm"
     and inv: "mopup_inv (Suc 0, l, r) lm n ires"
     and f: "f = (\<lambda> stp. (steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) stp, n))"
     and P: "P = (\<lambda> (c, n). is_final c)"
   shows "\<exists> stp. P (f stp)"
 proof (induct rule: abc_mopup_measure_induct) 
   case (Step na)
   have h: "\<not> P (f na)" by fact
   show "(f (Suc na), f na) \<in> abc_mopup_measure"
   proof(simp add: f)
     obtain a b c where g:"steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na = (a, b, c)"
       apply(case_tac "steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na", auto)
       done
     then have "mopup_inv (a, b, c) lm n ires"
       using inv less mopup_inv_steps[of n lm "Suc 0" l r ires na]
       apply(simp)
       done
     moreover have "a > 0"
       using h g
       apply(simp add: f P)
       done
     ultimately 
     have "((step (a, b, c) (mopup_a n @ shift mopup_b (2 * n), 0), n), (a, b, c), n) \<in> abc_mopup_measure"
       apply(case_tac c;cases "hd c")
          apply(auto split:if_splits simp add:step.simps mopup_inv.simps mopup_bef_erase_b.simps)
       by (auto split:if_splits simp: mopupfetchs abc_mopup_measure_def )
     thus "((step (steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na) 
       (mopup_a n @ shift mopup_b (2 * n), 0), n),
       steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na, n)
       \<in> abc_mopup_measure"
       using g by simp
   qed
 qed
 
 lemma mopup_inv_start: 
   "n < length am \<Longrightarrow> mopup_inv (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) am n ires"
   apply(cases am;auto simp: mopup_inv.simps mopup_bef_erase_a.simps mopup_jump_over1.simps)
     apply(auto simp: tape_of_nl_cons)
      apply(rule_tac x = "Suc (hd am)" in exI, rule_tac x = k in exI, simp)
     apply(cases k;cases n;force)
    apply(cases n; force)
   by(cases n; force split:if_splits)
 
 lemma mopup_correct:
   assumes less: "n < length (am::nat list)"
     and rs: "am ! n = rs"
   shows "\<exists> stp i j. (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)
     = (0, Bk\<up>i @ Bk # Bk # ires, Oc # Oc\<up> rs @ Bk\<up>j)"
   using less
 proof -
   have a: "mopup_inv (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) am n ires"
     using less
     apply(simp add: mopup_inv_start)
     done    
   then have "\<exists> stp. is_final (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)"
     using less mopup_halt[of n am  "Bk # Bk # ires" "<am> @ Bk \<up> k" ires
         "(\<lambda>stp. (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp, n))"
         "(\<lambda>(c, n). is_final c)"]
     apply(simp)
     done
   from this obtain stp where b:
     "is_final (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)" ..
   from a b have
     "mopup_inv (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)
     am n ires"
     apply(rule_tac mopup_inv_steps, simp_all add: less)
     done    
   from b and this show "?thesis"
     apply(rule_tac x = stp in exI, simp)
     apply(case_tac "steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) 
       (mopup_a n @ shift mopup_b (2 * n), 0) stp")
     apply(simp add: mopup_inv.simps mopup_stop.simps rs)
     using rs
     apply(simp add: tape_of_nat_def)
     done
 qed
 
-lemma wf_mopup[intro]: "tm_wf (mopup n, 0)"
-  by(induct n, auto simp add: shift.simps mopup_b_def tm_wf.simps)
+lemma composable_mopup_n_tm[intro]: "composable_tm (mopup_n_tm n, 0)"
+  by(induct n, auto simp add: shift.simps mopup_b_def composable_tm.simps)
 
-end
\ No newline at end of file
+end
diff --git a/thys/Universal_Turing_Machine/Abacus_alt_Compile.thy b/thys/Universal_Turing_Machine/Abacus_alt_Compile.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/Abacus_alt_Compile.thy
@@ -0,0 +1,66 @@
+(* Title: thys/Abacus_alt_Compile.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+ *)
+
+subsection \<open>Alternative Definitions for Translating Abacus Machines to TMs\<close>
+
+theory Abacus_alt_Compile
+  imports Abacus
+begin
+
+abbreviation
+  "layout \<equiv> layout_of"
+
+
+fun address :: "abc_prog \<Rightarrow> nat \<Rightarrow> nat"
+  where
+    "address p x = (Suc (sum_list (take x (layout p)))) "
+
+abbreviation
+  "TMGoto \<equiv> [(Nop, 1), (Nop, 1)]"
+
+abbreviation 
+  "TMInc \<equiv> [(WO, 1), (R, 2), (WO, 3), (R, 2), (WO, 3), (R, 4), 
+            (L, 7), (WB, 5), (R, 6), (WB, 5), (WO, 3), (R, 6),
+            (L, 8), (L, 7), (R, 9), (L, 7), (R, 10), (WB, 9)]"
+
+abbreviation
+  "TMDec \<equiv> [(WO, 1), (R, 2), (L, 14), (R, 3), (L, 4), (R, 3),
+             (R, 5), (WB, 4), (R, 6), (WB, 5), (L, 7), (L, 8),
+             (L, 11), (WB, 7), (WO, 8), (R, 9), (L, 10), (R, 9),
+             (R, 5), (WB, 10), (L, 12), (L, 11), (R, 13), (L, 11),
+             (R, 17), (WB, 13), (L, 15), (L, 14), (R, 16), (L, 14),
+             (R, 0), (WB, 16)]"
+
+abbreviation
+  "TMFindnth \<equiv> findnth"
+
+fun compile_goto :: "nat \<Rightarrow> instr list" 
+  where
+    "compile_goto s = shift TMGoto (s - 1)"
+
+fun compile_inc :: "nat \<Rightarrow> nat \<Rightarrow> instr list"
+  where
+    "compile_inc s n = (shift (TMFindnth n) (s - 1)) @ (shift (shift TMInc (2 * n)) (s - 1))"
+
+fun compile_dec :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> instr list"
+  where
+    "compile_dec s n e = (shift (TMFindnth n) (s - 1)) @ (adjust (shift (shift TMDec (2 * n)) (s - 1)) e)"
+
+fun compile :: "abc_prog \<Rightarrow> nat \<Rightarrow> abc_inst \<Rightarrow> instr list"
+  where
+    "compile ap s (Inc n) = compile_inc s n"
+  | "compile ap s (Dec n e) = compile_dec s n (address ap e)"
+  | "compile ap s (Goto e) = compile_goto (address ap e)"
+
+lemma
+  "compile ap s i = ci (layout ap) s i"
+  apply(cases i)
+    apply(simp add: ci.simps shift.simps start_of.simps tinc_b_def)
+   apply(simp add: ci.simps shift.simps start_of.simps tdec_b_def)
+  apply(simp add: ci.simps shift.simps start_of.simps)
+  done
+
+
+end
diff --git a/thys/Universal_Turing_Machine/BlanksDoNotMatter.thy b/thys/Universal_Turing_Machine/BlanksDoNotMatter.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/BlanksDoNotMatter.thy
@@ -0,0 +1,1260 @@
+(* Title: thys/BlanksDoNotMatter.thy
+   Author: Franz Regensburger (FABR) 04/2022
+ *)
+
+section \<open>Trailing Blanks on the input tape do not matter\<close>
+
+theory BlanksDoNotMatter
+  imports Turing
+begin
+
+(* ----- Configure sledgehammer ------ *)
+sledgehammer_params[minimize=false,preplay_timeout=10,timeout=30,strict=true,
+                    provers="e z3 cvc4 vampire "]
+
+(*
+sledgehammer_params[minimize=false,preplay_timeout=10,timeout=30,verbose=true,strict=true,
+                    provers="spass e z3 cvc4 vampire "]
+*)
+(* ----------------------------------- *)
+
+
+subsection \<open>Replication of symbols\<close>
+
+abbreviation exponent :: "'a \<Rightarrow> nat \<Rightarrow> 'a list" ("_ \<up> _" [100, 99] 100)
+  where "x \<up> n == replicate n x"
+
+lemma hd_repeat_cases:
+  "P (hd (a \<up> m @ r)) \<longleftrightarrow> (m = 0 \<longrightarrow> P (hd r)) \<and> (\<forall>nat. m = Suc nat \<longrightarrow> P a)"
+  by (cases m,auto)
+
+lemma hd_repeat_cases':
+  "P (hd (a \<up> m @ r)) = (if m = 0 then P (hd r) else P a)"
+  by auto
+
+(* hd_repeat_cases \<equiv> hd_repeat_cases'.
+ * However, hd_repeat_cases' is better for rewriting
+ *)
+
+lemma
+  "(if m = 0 then P (hd r) else P a) = ((m = 0 \<longrightarrow> P (hd r)) \<and> (\<forall>nat. m = Suc nat \<longrightarrow> P a))"
+proof -
+  have "(if m = 0 then P (hd r) else P a) = P (hd (a \<up> m @ r))" by auto
+  also have "... = ((m = 0 \<longrightarrow> P (hd r)) \<and> (\<forall>nat. m = Suc nat \<longrightarrow> P a))"
+    by (simp add: iffI hd_repeat_cases)
+  finally show ?thesis .
+qed
+
+lemma split_head_repeat[simp]:
+  "Oc # list1 = Bk \<up> j @ list2 \<longleftrightarrow> j = 0 \<and> Oc # list1 = list2"
+  "Bk # list1 = Oc \<up> j @ list2 \<longleftrightarrow> j = 0 \<and> Bk # list1 = list2"
+  "Bk \<up> j @ list2 = Oc # list1 \<longleftrightarrow> j = 0 \<and> Oc # list1 = list2"
+  "Oc \<up> j @ list2 = Bk # list1 \<longleftrightarrow> j = 0 \<and> Bk # list1 = list2"
+  by(cases j;force)+
+
+lemma Bk_no_Oc_repeatE[elim]: "Bk # list = Oc \<up> t \<Longrightarrow> RR"
+  by (cases t, auto)
+
+lemma replicate_Suc_1: "a \<up> (z1 + Suc z2) = (a \<up> z1) @ (a \<up> Suc z2)"
+  by (meson replicate_add)
+
+lemma replicate_Suc_2: "a \<up> (z1 + Suc z2) = (a \<up> Suc z1) @ (a \<up> z2)"
+    by (simp add: replicate_add)
+
+
+
+subsection \<open>Trailing blanks on the left tape do not matter\<close>
+
+text\<open>In this section we will show that we may add or remove trailing blanks on the
+initial left and right portions of the tape at will.
+However, we may not add or remove trailing blanks on the tape resulting from the computation.
+The resulting tape is completely determined by the contents of the initial tape.\<close>
+
+(* -------------------- Remove trailing blanks from the left tape -------------------------- *)
+
+lemma step_left_tape_ShrinkBkCtx_right_Nil:
+  assumes "step0 (s,CL@Bk\<up> z1 , []) tm = (s',l',r')"
+    and "za < z1"
+  shows "\<exists>CL' zb. l' = CL'@Bk\<up>za@Bk\<up>zb \<and>
+                 (step0 (s,CL@Bk\<up>za, []) tm = (s',CL'@Bk\<up>za,r') \<or>
+                  step0 (s,CL@Bk\<up>za, []) tm = (s',CL'@Bk\<up>(za-1),r'))"
+proof (cases "fetch tm (s - 0) (read [])")
+  case (Pair a s2)
+  then have A1: "fetch tm (s - 0) (read []) = (a, s2)" .
+  show ?thesis 
+  proof (cases a)
+    assume "a = WB"
+    from \<open>a = WB\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, []) tm =  (s2, CL@Bk \<up> z1, [Bk])" by auto
+    moreover from \<open>a = WB\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, []) tm =  (s2,CL@Bk\<up>za , [Bk])" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, []) tm = (s2,CL@Bk\<up>za , [Bk])"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, []) tm = (s2, CL @ Bk \<up> z1, [Bk])\<close> assms(1) by auto
+  next
+    assume "a = WO"
+    from \<open>a = WO\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, []) tm =  (s2, CL@Bk \<up> z1, [Oc])" by auto
+    moreover from \<open>a = WO\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, []) tm =  (s2,CL@Bk\<up>za , [Oc])" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, []) tm = (s2,CL@Bk\<up>za , [Oc])"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, []) tm = (s2, CL @ Bk \<up> z1, [Oc])\<close> assms(1) by auto
+  next
+    assume "a = Nop"
+    from \<open>a = Nop\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, []) tm =  (s2, CL@Bk \<up> z1, [])" by auto
+    moreover from \<open>a = Nop\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, []) tm =  (s2,CL@Bk\<up>za , [])" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, []) tm = (s2,CL@Bk\<up>za , [])"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, []) tm = (s2, CL @ Bk \<up> z1, [])\<close> assms(1) by auto
+  next
+    assume "a = R"
+    from \<open>a = R\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, []) tm =  (s2, [Bk]@CL@Bk\<up>z1, [])"
+      by auto
+    moreover from \<open>a = R\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, []) tm =  (s2,[Bk]@CL@Bk\<up>za, [])" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, []) tm = (s2,[Bk]@CL@Bk\<up>za, [])"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, []) tm = (s2, [Bk] @ CL @ Bk \<up> z1, [])\<close>
+      by (metis  append_Cons append_Nil assms(1) fst_conv snd_conv)
+  next
+    assume "a = L"
+    show ?thesis
+    proof (cases CL)
+      case Nil
+      then have "CL = []" .
+      then show ?thesis
+      proof (cases z1)
+        case 0
+        then have "z1 = 0" .
+        with assms and \<open>CL = []\<close> show ?thesis by auto
+      next
+        case (Suc nat)
+        then have "z1 = Suc nat" .
+        from \<open>a = L\<close> and \<open>CL = []\<close> and \<open>z1 = Suc nat\<close> and assms and A1
+        have "step0 (s, CL@Bk \<up> z1, []) tm =  (s2, []@Bk \<up>(z1-1), [Bk])"
+          by auto
+        moreover from \<open>a = L\<close> and \<open>CL = []\<close> and A1 have "step0 (s, CL@Bk\<up>za, []) tm =  (s2, []@Bk\<up>(za-1) , [Bk])" by auto
+        ultimately have "Bk\<up>(z1-1) = Bk\<up>za@Bk\<up>(z1-1-za) \<and> step0 (s, CL@Bk\<up>za, []) tm =  (s2, []@Bk\<up>(za-1) , [Bk])"
+          using assms using \<open>z1 = Suc nat\<close>
+          by (metis diff_Suc_1 le_eq_less_or_eq less_Suc_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+        with assms  and \<open>CL = []\<close> and \<open>z1 = Suc nat\<close> and \<open>step0 (s, CL@Bk\<up>z1, []) tm = (s2, [] @ Bk \<up> (z1 - 1), [Bk])\<close>
+        show ?thesis
+          by auto
+      qed
+    next
+      case (Cons c cs)
+      then have "CL = c # cs" .
+      from \<open>a = L\<close> and \<open>CL = c # cs\<close> and assms and A1
+      have "step0 (s, CL@Bk \<up> z1, []) tm =  (s2, cs@Bk \<up>z1, [c])"
+        by auto
+      moreover from \<open>a = L\<close> and \<open>CL = c # cs\<close> and A1
+      have "step0 (s, CL@Bk\<up>za, []) tm =  (s2, cs@Bk \<up>za, [c])" by auto
+      ultimately have "Bk\<up>(z1-1) = Bk\<up>za@Bk\<up>(z1-1-za) \<and> step0 (s, CL@Bk\<up>za, []) tm =  (s2, cs@Bk \<up>za, [c])"
+        using assms
+        by (metis One_nat_def Suc_pred add_diff_inverse_nat neq0_conv not_less_eq not_less_zero replicate_add)
+      with assms  and \<open>CL = c # cs\<close> and \<open>Bk\<up>(z1-1) = Bk\<up>za@Bk\<up>(z1-1-za) \<and> step0 (s, CL@Bk\<up>za, []) tm =  (s2, cs@Bk \<up>za, [c])\<close>
+      show ?thesis
+        using \<open>step0 (s, CL @ Bk \<up> z1, []) tm = (s2, cs @ Bk \<up> z1, [c])\<close> 
+        by (metis fst_conv nat_le_linear not_less ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add snd_conv)
+    qed
+  qed
+qed
+
+lemma step_left_tape_ShrinkBkCtx_right_Bk:
+  assumes "step0 (s,CL@Bk\<up> z1 , Bk#rs) tm = (s',l',r')"
+    and "za < z1"
+  shows "\<exists>CL' zb. l' = CL'@Bk\<up>za@Bk\<up>zb \<and>
+                 (step0 (s,CL@Bk\<up>za, Bk#rs) tm = (s',CL'@Bk\<up>za,r') \<or>
+                  step0 (s,CL@Bk\<up>za, Bk#rs) tm = (s',CL'@Bk\<up>(za-1),r'))"
+proof (cases "fetch tm (s - 0) (read (Bk#rs))")
+  case (Pair a s2)
+  then have A1: "fetch tm (s - 0) (read (Bk#rs)) = (a, s2)" .
+  show ?thesis 
+  proof (cases a)
+    assume "a = WB"
+    from \<open>a = WB\<close> and assms A1
+    have "step0 (s, CL@Bk \<up> z1, Bk#rs) tm =  (s2, CL@Bk \<up> z1, Bk#rs)"
+      by (auto simp add:  split: if_splits)
+    moreover from \<open>a = WB\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, Bk#rs) tm =  (s2,CL@Bk\<up>za , Bk#rs)" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, Bk#rs) tm = (s2,CL@Bk\<up>za , Bk#rs)"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, Bk#rs) tm = (s2, CL @ Bk \<up> z1, Bk#rs)\<close> assms(1) by auto
+  next
+    assume "a = WO"
+    from \<open>a = WO\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, Bk#rs) tm =  (s2, CL@Bk \<up> z1, Oc#rs)" by auto
+    moreover from \<open>a = WO\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, Bk#rs) tm =  (s2,CL@Bk\<up>za , Oc#rs)" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, Bk#rs) tm = (s2,CL@Bk\<up>za , Oc#rs)"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, Bk#rs) tm = (s2, CL @ Bk \<up> z1, Oc#rs)\<close> assms(1) by auto
+  next
+    assume "a = Nop"
+    from \<open>a = Nop\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, Bk#rs) tm =  (s2, CL@Bk \<up> z1, Bk#rs)" by auto
+    moreover from \<open>a = Nop\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, Bk#rs) tm =  (s2,CL@Bk\<up>za , Bk#rs)" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, Bk#rs) tm = (s2,CL@Bk\<up>za , Bk#rs)"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, Bk#rs) tm = (s2, CL @ Bk \<up> z1, Bk#rs)\<close> assms(1) by auto
+  next
+    assume "a = R"
+    from \<open>a = R\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, Bk#rs) tm =  (s2, [Bk]@CL@Bk\<up>z1, rs)"
+      by auto
+    moreover from \<open>a = R\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, Bk#rs) tm =  (s2,[Bk]@CL@Bk\<up>za, rs)" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, Bk#rs) tm = (s2,[Bk]@CL@Bk\<up>za, rs)"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, Bk#rs) tm = (s2, [Bk] @ CL @ Bk \<up> z1, rs)\<close>
+      by (metis  append_Cons append_Nil assms(1) fst_conv snd_conv)
+  next
+    assume "a = L"
+    show ?thesis
+    proof (cases CL)
+      case Nil
+      then have "CL = []" .
+      then show ?thesis
+      proof (cases z1)
+        case 0
+        then have "z1 = 0" .
+        with assms and \<open>CL = []\<close> show ?thesis by auto
+      next
+        case (Suc nat)
+        then have "z1 = Suc nat" .
+        from \<open>a = L\<close> and \<open>CL = []\<close> and \<open>z1 = Suc nat\<close> and assms and A1
+        have "step0 (s, CL@Bk \<up> z1, Bk#rs) tm =  (s2, []@Bk \<up>(z1-1), Bk#Bk#rs)"
+          by auto
+        moreover from \<open>a = L\<close> and \<open>CL = []\<close> and A1 have "step0 (s, CL@Bk\<up>za, Bk#rs) tm =  (s2, []@Bk\<up>(za-1) ,  Bk#Bk#rs)" by auto
+        ultimately have "Bk\<up>(z1-1) = Bk\<up>za@Bk\<up>(z1-1-za) \<and> step0 (s, CL@Bk\<up>za, Bk#rs) tm =  (s2, []@Bk\<up>(za-1) ,  Bk#Bk#rs)"
+          using assms using \<open>z1 = Suc nat\<close>
+          by (metis diff_Suc_1 le_eq_less_or_eq less_Suc_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+        with assms  and \<open>CL = []\<close> and \<open>z1 = Suc nat\<close> and \<open>step0 (s, CL@Bk\<up>z1, Bk#rs) tm = (s2, [] @ Bk \<up> (z1 - 1),  Bk#Bk#rs)\<close>
+        show ?thesis
+          by auto
+      qed
+    next
+      case (Cons c cs)
+      then have "CL = c # cs" .
+      from \<open>a = L\<close> and \<open>CL = c # cs\<close> and assms and A1
+      have "step0 (s, CL@Bk \<up> z1, Bk#rs) tm =  (s2, cs@Bk \<up>z1, c#Bk#rs)"
+        by auto
+      moreover from \<open>a = L\<close> and \<open>CL = c # cs\<close> and A1
+      have "step0 (s, CL@Bk\<up>za, Bk#rs) tm =  (s2, cs@Bk \<up>za, c#Bk#rs)" by auto
+      ultimately have "Bk\<up>(z1-1) = Bk\<up>za@Bk\<up>(z1-1-za) \<and> step0 (s, CL@Bk\<up>za, Bk#rs) tm =  (s2, cs@Bk \<up>za, c#Bk#rs)"
+        using assms
+        by (metis One_nat_def Suc_pred add_diff_inverse_nat neq0_conv not_less_eq not_less_zero replicate_add)
+      with assms  and \<open>CL = c # cs\<close> and \<open>Bk\<up>(z1-1) = Bk\<up>za@Bk\<up>(z1-1-za) \<and> step0 (s, CL@Bk\<up>za, Bk#rs) tm =  (s2, cs@Bk \<up>za, c#Bk#rs)\<close>
+      show ?thesis
+        using \<open>step0 (s, CL @ Bk \<up> z1, Bk#rs) tm = (s2, cs @ Bk \<up> z1, c#Bk#rs)\<close> 
+        by (metis fst_conv nat_le_linear not_less ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add snd_conv)
+    qed
+  qed
+qed
+
+lemma step_left_tape_ShrinkBkCtx_right_Oc:
+  assumes "step0 (s,CL@Bk\<up> z1 , Oc#rs) tm = (s',l',r')"
+    and "za < z1"
+  shows "\<exists>CL' zb. l' = CL'@Bk\<up>za@Bk\<up>zb \<and>
+                 (step0 (s,CL@Bk\<up>za, Oc#rs) tm = (s',CL'@Bk\<up>za,r') \<or>
+                  step0 (s,CL@Bk\<up>za, Oc#rs) tm = (s',CL'@Bk\<up>(za-1),r'))"
+proof (cases "fetch tm (s - 0) (read (Oc#rs))")
+  case (Pair a s2)
+  then have A1: "fetch tm (s - 0) (read (Oc#rs)) = (a, s2)" .
+  show ?thesis 
+  proof (cases a)
+    assume "a = WB"
+    from \<open>a = WB\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, Oc#rs) tm =  (s2, CL@Bk \<up> z1, Bk#rs)" by auto
+    moreover from \<open>a = WB\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, Oc#rs) tm =  (s2,CL@Bk\<up>za , Bk#rs)" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, Oc#rs) tm = (s2,CL@Bk\<up>za ,Bk#rs)"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, Oc#rs) tm = (s2, CL @ Bk \<up> z1, Bk#rs)\<close> assms(1) by auto
+  next
+    assume "a = WO"
+    from \<open>a = WO\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, Oc#rs) tm =  (s2, CL@Bk \<up> z1, Oc#rs)" by auto
+    moreover from \<open>a = WO\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, Oc#rs) tm =  (s2,CL@Bk\<up>za , Oc#rs)" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, Oc#rs) tm = (s2,CL@Bk\<up>za , Oc#rs)"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, Oc#rs) tm = (s2, CL @ Bk \<up> z1, Oc#rs)\<close> assms(1) by auto
+  next
+    assume "a = Nop"
+    from \<open>a = Nop\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, Oc#rs) tm =  (s2, CL@Bk \<up> z1, Oc#rs)" by auto
+    moreover from \<open>a = Nop\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, Oc#rs) tm =  (s2,CL@Bk\<up>za , Oc#rs)" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, Oc#rs) tm = (s2,CL@Bk\<up>za , Oc#rs)"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, Oc#rs) tm = (s2, CL @ Bk \<up> z1, Oc#rs)\<close> assms(1) by auto
+  next
+    assume "a = R"
+    from \<open>a = R\<close> and assms A1 have "step0 (s, CL@Bk \<up> z1, Oc#rs) tm =  (s2, [Oc]@CL@Bk\<up>z1, rs)"
+      by auto
+    moreover from \<open>a = R\<close> and assms A1 have "step0 (s, CL@Bk\<up>za, Oc#rs) tm =  (s2,[Oc]@CL@Bk\<up>za, rs)" by auto
+    ultimately have "Bk\<up>z1 = Bk\<up>za@Bk\<up>(z1-za) \<and> step0 (s, CL@Bk\<up>za, Oc#rs) tm = (s2,[Oc]@CL@Bk\<up>za, rs)"
+      using assms
+      by (metis le_eq_less_or_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+    then show ?thesis
+      using \<open>step0 (s, CL @ Bk \<up> z1, Oc#rs) tm = (s2, [Oc] @ CL @ Bk \<up> z1, rs)\<close>
+      by (metis  append_Cons append_Nil assms(1) fst_conv snd_conv)
+  next
+    assume "a = L"
+    show ?thesis
+    proof (cases CL)
+      case Nil
+      then have "CL = []" .
+      then show ?thesis
+      proof (cases z1)
+        case 0
+        then have "z1 = 0" .
+        with assms and \<open>CL = []\<close> show ?thesis by auto
+      next
+        case (Suc nat)
+        then have "z1 = Suc nat" .
+        from \<open>a = L\<close> and \<open>CL = []\<close> and \<open>z1 = Suc nat\<close> and assms and A1
+        have "step0 (s, CL@Bk \<up> z1, Oc#rs) tm =  (s2, []@Bk \<up>(z1-1), Bk#Oc#rs)"
+          by auto
+        moreover from \<open>a = L\<close> and \<open>CL = []\<close> and A1 have "step0 (s, CL@Bk\<up>za, Oc#rs) tm =  (s2, []@Bk\<up>(za-1) ,  Bk#Oc#rs)" by auto
+        ultimately have "Bk\<up>(z1-1) = Bk\<up>za@Bk\<up>(z1-1-za) \<and> step0 (s, CL@Bk\<up>za, Oc#rs) tm =  (s2, []@Bk\<up>(za-1) ,  Bk#Oc#rs)"
+          using assms using \<open>z1 = Suc nat\<close>
+          by (metis diff_Suc_1 le_eq_less_or_eq less_Suc_eq ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add)
+        with assms  and \<open>CL = []\<close> and \<open>z1 = Suc nat\<close> and \<open>step0 (s, CL@Bk\<up>z1, Oc#rs) tm = (s2, [] @ Bk \<up> (z1 - 1),  Bk#Oc#rs)\<close>
+        show ?thesis
+          by auto
+      qed
+    next
+      case (Cons c cs)
+      then have "CL = c # cs" .
+      from \<open>a = L\<close> and \<open>CL = c # cs\<close> and assms and A1
+      have "step0 (s, CL@Bk \<up> z1, Oc#rs) tm =  (s2, cs@Bk \<up>z1, c#Oc#rs)"
+        by auto
+      moreover from \<open>a = L\<close> and \<open>CL = c # cs\<close> and A1
+      have "step0 (s, CL@Bk\<up>za, Oc#rs) tm =  (s2, cs@Bk \<up>za, c#Oc#rs)" by auto
+      ultimately have "Bk\<up>(z1-1) = Bk\<up>za@Bk\<up>(z1-1-za) \<and> step0 (s, CL@Bk\<up>za, Oc#rs) tm =  (s2, cs@Bk \<up>za, c#Oc#rs)"
+        using assms
+        by (metis One_nat_def Suc_pred add_diff_inverse_nat neq0_conv not_less_eq not_less_zero replicate_add)
+      with assms  and \<open>CL = c # cs\<close> and \<open>Bk\<up>(z1-1) = Bk\<up>za@Bk\<up>(z1-1-za) \<and> step0 (s, CL@Bk\<up>za, Oc#rs) tm =  (s2, cs@Bk \<up>za, c#Oc#rs)\<close>
+      show ?thesis
+        using \<open>step0 (s, CL @ Bk \<up> z1, Oc#rs) tm = (s2, cs @ Bk \<up> z1, c#Oc#rs)\<close> 
+        by (metis fst_conv nat_le_linear not_less ordered_cancel_comm_monoid_diff_class.add_diff_inverse replicate_add snd_conv)
+    qed
+  qed
+qed
+
+corollary step_left_tape_ShrinkBkCtx:
+  assumes "step0 (s,CL@Bk\<up> z1 , r) tm = (s',l',r')"
+    and "za < z1"
+  shows "\<exists>zb CL'. l' = CL'@Bk\<up>za@Bk\<up>zb \<and>
+                 (step0 (s,CL@Bk\<up>za, r) tm = (s',CL'@Bk\<up>za,r') \<or>
+                 step0 (s,CL@Bk\<up>za, r) tm = (s',CL'@Bk\<up>(za-1),r'))"
+proof (cases r)
+  case Nil
+  then show ?thesis using step_left_tape_ShrinkBkCtx_right_Nil
+    using assms by blast
+next
+  case (Cons rx rs)
+  then have "r = rx # rs" .
+  show ?thesis
+  proof (cases rx)
+    case Bk
+    with assms and \<open>r = rx # rs\<close> show ?thesis using step_left_tape_ShrinkBkCtx_right_Bk by blast
+  next
+    case Oc
+    with assms and \<open>r = rx # rs\<close> show ?thesis using step_left_tape_ShrinkBkCtx_right_Oc by blast
+  qed
+qed
+
+(* propagate the step lemmas step_left_tape_ShrinkBkCtx* to steps *)
+
+lemma steps_left_tape_ShrinkBkCtx_arbitrary_CL:
+  "\<lbrakk> steps0 (s, CL@Bk\<up>z1 , r) tm stp = (s',l',r'); 0 < z1 \<rbrakk> \<Longrightarrow> 
+     \<exists>zb CL'. l' = CL'@Bk\<up>zb  \<and> steps0 (s,CL, r) tm stp = (s',CL',r')"
+proof (induct stp arbitrary: s CL z1 r s' l' r' z1)
+  case 0
+  assume "steps0 (s, CL @ Bk \<up> z1, r) tm 0 = (s', l', r')" and "0 < z1"
+  then show ?case
+    using less_imp_add_positive replicate_add by fastforce
+next
+  fix stp s CL z1 r s' l' r'
+  assume IV: "\<And>s2 CL2 z12 r2 s2' l2' r2'. \<lbrakk>steps0 (s2, CL2 @ Bk \<up> z12, r2) tm stp = (s2', l2', r2'); 0 < z12\<rbrakk>
+          \<Longrightarrow> \<exists>zb2' CL2'. l2' = CL2' @ Bk \<up> zb2' \<and> 
+                    steps0 (s2, CL2, r2) tm stp = (s2', CL2', r2')"
+    and major: "steps0 (s, CL @ Bk \<up> z1, r) tm (Suc stp) = (s', l', r')"
+    and minor: "0< z1"
+  show "\<exists>zb CL'. l' = CL' @ Bk \<up> zb \<and> steps0 (s, CL, r) tm (Suc stp) = (s', CL', r')"
+  proof -
+    have F1: "steps0 (s, CL, r) tm (Suc stp) = step0 (steps0 (s, CL, r) tm stp) tm"
+      by (rule step_red)
+
+    have "steps0 (s, CL @ Bk \<up> z1, r) tm (Suc stp) = step0 (steps0 (s, CL @ Bk \<up> z1, r) tm stp) tm"
+      by (rule step_red)
+
+    with major
+    have F3: "step0 (steps0 (s, CL @ Bk \<up> z1, r) tm stp) tm = (s', l', r')" by auto
+
+    show ?thesis
+    proof (cases z1)
+      case 0
+      then have "z1 = 0" .
+      with minor 
+      show ?thesis by auto
+    next
+      case (Suc z1')
+      then have "z1 = Suc z1'" .
+      show ?thesis
+      proof (cases "steps0 (s, CL @ Bk \<up> z1, r) tm stp")
+        case (fields sx lx rx)
+        then have C: "steps0 (s, CL @ Bk \<up> z1, r) tm stp = (sx, lx, rx)" .
+        with  minor and IV
+        have F0: "\<exists>zb2' CL2'. lx = CL2' @ Bk \<up> zb2' \<and> 
+                                 steps0 (s, CL, r) tm stp = (sx, CL2', rx)"
+          by auto
+
+        then obtain zb2' CL2' where
+          w_zb2'_CL2'_zc2': "lx = CL2' @ Bk \<up> zb2' \<and> 
+                    steps0 (s, CL, r) tm stp = (sx, CL2', rx)"
+          by blast
+
+        from F3 and C have "step0 (sx,lx,rx) tm = (s',l',r')" by auto
+
+        with w_zb2'_CL2'_zc2' have F4: "step0 (sx,CL2' @ Bk \<up> zb2',rx) tm = (s',l',r')" by auto
+
+        then have "step0 (sx,CL2' @ Bk \<up> (zb2'),rx) tm = (s',l',r')"
+          by (simp add: replicate_add)
+
+        show ?thesis
+        proof (cases zb2')
+          case 0
+          then show ?thesis 
+
+            using F1 \<open>step0 (sx, lx, rx) tm = (s', l', r')\<close> append_Nil2 replicate_0 w_zb2'_CL2'_zc2' by auto
+        next
+          case (Suc zb3')
+          then have "zb2' = Suc zb3'" .
+
+          then show ?thesis
+            by (metis F1 F4
+                append_Nil2 diff_is_0_eq'
+                replicate_0 self_append_conv2 step_left_tape_ShrinkBkCtx w_zb2'_CL2'_zc2'
+                zero_le_one zero_less_Suc)
+        qed
+      qed
+    qed
+  qed
+qed
+
+(* -------------------- Add trailing blanks on the left tape ------------------------------- *)
+
+lemma step_left_tape_EnlargeBkCtx_eq_Bks:
+  assumes "step0 (s,Bk\<up> z1,     r) tm = (s',l',r')"
+  shows   "step0 (s,Bk\<up>(z1+Suc z2), r) tm = (s',l'@Bk\<up>Suc z2,r') \<or>
+           step0 (s,Bk\<up>(z1+Suc z2), r) tm = (s',l'@Bk\<up>z2,r')"
+proof (cases s)
+  assume "s = 0"
+  with assms have "step0 (s, Bk\<up>(z1+Suc z2), r) tm = (s',l'@Bk\<up>Suc z2,r')"
+    using replicate_Suc_1 by fastforce
+  then show ?thesis by auto
+next
+  fix s2
+  assume "s = Suc s2"
+  then show ?thesis
+  proof (cases r)
+    assume "r = []"
+    then show "step0 (s, Bk \<up> (z1 + Suc z2), r) tm = (s', l' @ Bk \<up> Suc z2, r') \<or>
+               step0 (s, Bk \<up> (z1 + Suc z2), r) tm = (s', l' @ Bk \<up> z2, r')"
+    proof (cases "fetch tm (s - 0) (read r)")
+      case (Pair a s3)
+      then have "fetch tm (s - 0) (read r) = (a, s3)" .
+      then show ?thesis
+      proof (cases a)
+        case WB
+        from \<open>a = WB\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, Bk\<up>(z1+Suc z2), r) tm = (s3, Bk\<up>(z1+Suc z2), [Bk])" by auto
+        moreover from  \<open>a = WB\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, Bk \<up> z1, r) tm = (s3, Bk \<up> z1, [Bk])" by auto
+        ultimately show ?thesis
+          using assms replicate_Suc_1 by fastforce    
+      next
+        case WO
+        from \<open>a = WO\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s,Bk\<up>(z1+Suc z2), r) tm = (s3, Bk\<up>(z1+Suc z2), [Oc])" by auto
+        moreover from  \<open>a = WO\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, Bk \<up> z1, r) tm = (s3, Bk \<up> z1, [Oc])" by auto
+        ultimately show ?thesis
+          using assms replicate_Suc_1 by fastforce
+      next
+        case L
+        from \<open>a = L\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, Bk\<up>(z1+Suc z2), r) tm = (s3, Bk \<up> (z1 + z2), [Bk])" by auto
+        moreover from  \<open>a = L\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s,  Bk \<up> z1, r) tm = (s3,  Bk \<up> (z1-1), [Bk])" by auto
+        ultimately show ?thesis   
+          by (metis (no_types, lifting) Pair_inject add_Suc_right add_eq_if
+              assms diff_is_0_eq' replicate_add zero_le_one)
+      next
+        case R
+        from \<open>a = R\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, Bk\<up>(z1+Suc z2), r) tm = (s3, Bk# Bk\<up>(z1+Suc z2), [])" by auto
+        moreover from  \<open>a = R\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, Bk \<up> z1, r) tm = (s3, Bk# Bk \<up> z1, [])" by auto
+        ultimately show ?thesis
+          using assms replicate_Suc_1 by fastforce
+      next
+        case Nop
+        from \<open>a = Nop\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, Bk\<up>(z1+Suc z2), r) tm = (s3,  Bk\<up>(z1+Suc z2), [])" by auto
+        moreover from  \<open>a = Nop\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s,  Bk \<up> z1, r) tm = (s3, Bk \<up> z1, [])" by auto
+        ultimately show ?thesis
+          using assms replicate_Suc_1 by fastforce
+      qed
+    qed
+  next
+    fix ra rrs
+    assume "r = ra # rrs"
+    then show "step0 (s, Bk \<up> (z1 + Suc z2), r) tm = (s', l' @ Bk \<up> Suc z2, r') \<or>
+               step0 (s, Bk \<up> (z1 + Suc z2), r) tm = (s', l' @ Bk \<up> z2, r')"
+    proof (cases "fetch tm (s - 0) (read r)")
+      case (Pair a s3)
+      then have "fetch tm (s - 0) (read r) = (a, s3)" .
+      then show ?thesis
+      proof (cases a)
+        case WB
+        from \<open>a = WB\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s,  Bk\<up>(z1+Suc z2), r) tm = (s3, Bk\<up>(z1+Suc z2), Bk# rrs)" by auto
+        moreover from  \<open>a = WB\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s,  Bk \<up> z1, r) tm = (s3,  Bk \<up> z1, Bk# rrs)" by auto
+        ultimately show ?thesis
+          using assms replicate_Suc_1 by fastforce    
+      next
+        case WO
+        from \<open>a = WO\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, Bk\<up>(z1+Suc z2), r) tm = (s3, Bk\<up>(z1+Suc z2), Oc# rrs)" by auto
+        moreover from  \<open>a = WO\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, Bk \<up> z1, r) tm = (s3, Bk \<up> z1, Oc# rrs)" by auto
+        ultimately show ?thesis
+          using assms replicate_Suc_1 by fastforce    
+      next
+        case L
+        from \<open>a = L\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, Bk\<up>(z1+Suc z2), r) tm = (s3, Bk \<up> (z1 + z2), Bk#ra#rrs)" by auto
+        moreover from  \<open>a = L\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s,  Bk \<up> z1, r) tm = (s3,  Bk \<up> (z1-1), Bk#ra#rrs)" by auto
+        ultimately show ?thesis   
+          by (metis (no_types, lifting) Pair_inject add_Suc_right add_eq_if
+              assms diff_is_0_eq' replicate_add zero_le_one)
+      next
+        case R
+        from \<open>a = R\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s,   Bk\<up>(z1+Suc z2), r) tm = (s3, ra#   Bk\<up>(z1+Suc z2), rrs)" by auto
+        moreover from  \<open>a = R\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s,  Bk \<up> z1, r) tm = (s3, ra# Bk \<up> z1,rrs)" by auto
+        ultimately show ?thesis
+          using assms replicate_Suc_1 by fastforce    
+      next
+        case Nop
+        from \<open>a = Nop\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s,  Bk\<up>(z1+Suc z2), r) tm = (s3, Bk\<up>(z1+Suc z2), ra # rrs)" by auto
+        moreover from  \<open>a = Nop\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s,  Bk \<up> z1, r) tm = (s3,  Bk \<up> z1, ra # rrs)" by auto
+        ultimately show ?thesis
+          using assms replicate_Suc_1 by fastforce    
+      qed
+    qed
+  qed
+qed
+
+lemma step_left_tape_EnlargeBkCtx_eq_Bk_C_Bks:
+  assumes "step0 (s,(Bk#C)@Bk\<up> z1,     r) tm = (s',l',r')"
+  shows "  step0 (s,(Bk#C)@Bk\<up>(z1+z2), r) tm = (s',l'@Bk\<up>z2,r')"
+proof (cases s)
+  assume "s = 0"
+  with assms show "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s', l' @ Bk \<up> z2, r')"
+    by (auto simp add: replicate_add)
+next
+  fix s2
+  assume "s = Suc s2"
+  then show "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s', l' @ Bk \<up> z2, r')"
+  proof (cases r)
+    assume "r = []"
+    then show ?thesis
+    proof (cases "fetch tm (s - 0) (read r)")
+      case (Pair a s3)
+      then have "fetch tm (s - 0) (read r) = (a, s3)" .
+      then show ?thesis
+      proof (cases a)
+        case WB
+        from \<open>a = WB\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Bk # C) @ Bk \<up> (z1 + z2), [Bk])" by auto
+        moreover from  \<open>a = WB\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> z1, r) tm = (s3, (Bk # C) @ Bk \<up> z1, [Bk])" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case WO
+        from \<open>a = WO\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Bk # C) @ Bk \<up> (z1 + z2), [Oc])" by auto
+        moreover from  \<open>a = WO\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> z1, r) tm = (s3, (Bk # C) @ Bk \<up> z1, [Oc])" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case L
+        from \<open>a = L\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (C) @ Bk \<up> (z1 + z2), [Bk])" by auto
+        moreover from  \<open>a = L\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> z1, r) tm = (s3, (C) @ Bk \<up> z1, [Bk])" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case R
+        from \<open>a = R\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Bk# Bk # C) @ Bk \<up> (z1 + z2), [])" by auto
+        moreover from  \<open>a = R\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> z1, r) tm = (s3, (Bk#Bk # C) @ Bk \<up> z1, [])" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case Nop
+        from \<open>a = Nop\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Bk # C) @ Bk \<up> (z1 + z2), [])" by auto
+        moreover from  \<open>a = Nop\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> z1, r) tm = (s3, (Bk # C) @ Bk \<up> z1, [])" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      qed
+    qed
+  next
+    fix ra rrs
+    assume "r = ra # rrs"
+    then show "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s', l' @ Bk \<up> z2, r')"
+    proof (cases "fetch tm (s - 0) (read r)")
+      case (Pair a s3)
+      then have "fetch tm (s - 0) (read r) = (a, s3)" .
+      then show ?thesis
+      proof (cases a)
+        case WB
+        from \<open>a = WB\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Bk # C) @ Bk \<up> (z1 + z2), Bk# rrs)" by auto
+        moreover from  \<open>a = WB\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> z1, r) tm = (s3, (Bk # C) @ Bk \<up> z1, Bk# rrs)" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case WO
+        from \<open>a = WO\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Bk # C) @ Bk \<up> (z1 + z2), Oc# rrs)" by auto
+        moreover from  \<open>a = WO\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> z1, r) tm = (s3, (Bk # C) @ Bk \<up> z1, Oc# rrs)" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case L
+        from \<open>a = L\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (C) @ Bk \<up> (z1 + z2), Bk#ra#rrs)" by auto
+        moreover from  \<open>a = L\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> z1, r) tm = (s3, (C) @ Bk \<up> z1, Bk#ra#rrs)" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case R
+        from \<open>a = R\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (ra# Bk # C) @ Bk \<up> (z1 + z2), rrs)" by auto
+        moreover from  \<open>a = R\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> z1, r) tm = (s3, (ra#Bk # C) @ Bk \<up> z1,rrs)" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case Nop
+        from \<open>a = Nop\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Bk # C) @ Bk \<up> (z1 + z2), ra # rrs)" by auto
+        moreover from  \<open>a = Nop\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Bk # C) @ Bk \<up> z1, r) tm = (s3, (Bk # C) @ Bk \<up> z1, ra # rrs)" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      qed
+    qed
+  qed
+qed
+
+lemma step_left_tape_EnlargeBkCtx_eq_Oc_C_Bks:
+  assumes "step0 (s,(Oc#C)@Bk\<up> z1,     r) tm = (s',l',r')"
+  shows "  step0 (s,(Oc#C)@Bk\<up>(z1+z2), r) tm = (s',l'@Bk\<up>z2,r')"
+proof (cases s)
+  assume "s = 0"
+  with assms show "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s', l' @ Bk \<up> z2, r')"
+    by (auto simp add: replicate_add)
+next
+  fix s2
+  assume "s = Suc s2"
+  then show "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s', l' @ Bk \<up> z2, r')"
+  proof (cases r)
+    assume "r = []"
+    then show ?thesis
+    proof (cases "fetch tm (s - 0) (read r)")
+      case (Pair a s3)
+      then have "fetch tm (s - 0) (read r) = (a, s3)" .
+      then show ?thesis
+      proof (cases a)
+        case WB
+        from \<open>a = WB\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Oc # C) @ Bk \<up> (z1 + z2), [Bk])" by auto
+        moreover from  \<open>a = WB\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> z1, r) tm = (s3, (Oc # C) @ Bk \<up> z1, [Bk])" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case WO
+        from \<open>a = WO\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Oc # C) @ Bk \<up> (z1 + z2), [Oc])" by auto
+        moreover from  \<open>a = WO\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> z1, r) tm = (s3, (Oc # C) @ Bk \<up> z1, [Oc])" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case L
+        from \<open>a = L\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (C) @ Bk \<up> (z1 + z2), [Oc])" by auto
+        moreover from  \<open>a = L\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> z1, r) tm = (s3, (C) @ Bk \<up> z1, [Oc])" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case R
+        from \<open>a = R\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Bk# Oc # C) @ Bk \<up> (z1 + z2), [])" by auto
+        moreover from  \<open>a = R\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> z1, r) tm = (s3, (Bk#Oc # C) @ Bk \<up> z1, [])" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case Nop
+        from \<open>a = Nop\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Oc # C) @ Bk \<up> (z1 + z2), [])" by auto
+        moreover from  \<open>a = Nop\<close> \<open>r = []\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> z1, r) tm = (s3, (Oc # C) @ Bk \<up> z1, [])" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      qed
+    qed
+  next
+    fix ra rrs
+    assume "r = ra # rrs"
+    then show "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s', l' @ Bk \<up> z2, r')"
+    proof (cases "fetch tm (s - 0) (read r)")
+      case (Pair a s3)
+      then have "fetch tm (s - 0) (read r) = (a, s3)" .
+      then show ?thesis
+      proof (cases a)
+        case WB
+        from \<open>a = WB\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Oc # C) @ Bk \<up> (z1 + z2), Bk# rrs)" by auto
+        moreover from  \<open>a = WB\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> z1, r) tm = (s3, (Oc # C) @ Bk \<up> z1, Bk# rrs)" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case WO
+        from \<open>a = WO\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Oc # C) @ Bk \<up> (z1 + z2), Oc# rrs)" by auto
+        moreover from  \<open>a = WO\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> z1, r) tm = (s3, (Oc # C) @ Bk \<up> z1, Oc# rrs)" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case L
+        from \<open>a = L\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (C) @ Bk \<up> (z1 + z2), Oc#ra#rrs)" by auto
+        moreover from  \<open>a = L\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> z1, r) tm = (s3, (C) @ Bk \<up> z1, Oc#ra#rrs)" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case R
+        from \<open>a = R\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (ra# Oc # C) @ Bk \<up> (z1 + z2), rrs)" by auto
+        moreover from  \<open>a = R\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> z1, r) tm = (s3, (ra#Oc # C) @ Bk \<up> z1,rrs)" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      next
+        case Nop
+        from \<open>a = Nop\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> (z1 + z2), r) tm = (s3, (Oc # C) @ Bk \<up> (z1 + z2), ra # rrs)" by auto
+        moreover from  \<open>a = Nop\<close> \<open>r = ra # rrs\<close> \<open>fetch tm (s - 0) (read r) = (a, s3)\<close>
+        have "step0 (s, (Oc # C) @ Bk \<up> z1, r) tm = (s3, (Oc # C) @ Bk \<up> z1, ra # rrs)" by auto
+        ultimately show ?thesis
+          using assms 
+          by (auto simp add: replicate_add)
+      qed
+    qed
+  qed
+qed
+
+lemma step_left_tape_EnlargeBkCtx_eq_C_Bks_Suc:
+  assumes "step0 (s,C@Bk\<up> z1,     r) tm = (s',l',r')"
+  shows   "step0 (s,C@Bk\<up>(z1+ Suc z2), r) tm = (s',l'@Bk\<up>Suc z2,r') \<or>
+           step0 (s,C@Bk\<up>(z1+ Suc z2), r) tm = (s',l'@Bk\<up>z2,r')"
+proof (cases C)
+  case Nil
+  then have "C = []" .
+  with assms show ?thesis by (metis append.left_neutral step_left_tape_EnlargeBkCtx_eq_Bks)
+next
+  case (Cons x C')
+  then have "C = x # C'" .
+  then show ?thesis
+  proof (cases x)
+    case Bk
+    then have "x = Bk" .
+    then show ?thesis
+      using assms local.Cons step_left_tape_EnlargeBkCtx_eq_Bk_C_Bks by blast
+  next
+    case Oc
+    then have "x = Oc" .
+    then show ?thesis
+      using assms local.Cons step_left_tape_EnlargeBkCtx_eq_Oc_C_Bks by blast
+  qed
+qed
+
+lemma step_left_tape_EnlargeBkCtx_eq_C_Bks:
+  assumes "step0 (s,C@Bk\<up> z1,     r) tm = (s',l',r')"
+  shows   "step0 (s,C@Bk\<up>(z1+ z2), r) tm = (s',l'@Bk\<up>z2,r') \<or>
+           step0 (s,C@Bk\<up>(z1+ z2), r) tm = (s',l'@Bk\<up>(z2-1),r')"
+  by (smt step_left_tape_EnlargeBkCtx_eq_C_Bks_Suc One_nat_def Suc_pred add.right_neutral
+          append.right_neutral assms neq0_conv replicate_empty)
+
+(* propagate the step lemmas step_left_tape_EnlargeBkCtx* to steps *)
+
+lemma steps_left_tape_EnlargeBkCtx_arbitrary_CL:
+  "steps0 (s, CL @ Bk\<up>z1, r) tm stp = (s', l',r')
+   \<Longrightarrow>
+   \<exists>z3. z3 \<le> z1 + z2 \<and>
+        steps0 (s, CL @ Bk\<up>(z1 + z2), r) tm stp = (s',l' @ Bk\<up>z3 ,r')"
+proof (induct stp arbitrary: s CL z1 r z2 s' l' r')
+  fix s CL z1 r z2 s' l' r'
+  assume  "steps0 (s, CL @ Bk \<up> z1, r) tm 0 = (s', l', r')"
+  show "\<exists>z3\<le>z1 + z2. steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm 0 = (s', l' @ Bk \<up> z3, r')"  
+    by (metis \<open>steps0 (s, CL @ Bk \<up> z1, r) tm 0 = (s', l', r')\<close>
+        append.assoc fst_conv le_add2 replicate_add snd_conv steps.simps(1))
+next
+  fix stp s CL z1 r z2 s' l' r'
+  assume IV: "\<And>s CL z1 r z2 s' l' r'. steps0 (s, CL @ Bk \<up> z1, r) tm stp = (s', l', r')
+              \<Longrightarrow> \<exists>z3\<le>z1 + z2. steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm stp = (s', l' @ Bk \<up> z3, r')"
+    and minor: "steps0 (s, CL @ Bk \<up> z1, r) tm (Suc stp) = (s', l', r')"
+  show "\<exists>z3\<le>z1 + z2. steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm (Suc stp) = (s', l' @ Bk \<up> z3, r')"
+
+  proof -
+    have F1: "steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm (Suc stp) = step0 (steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm stp) tm"
+      by (rule step_red)
+
+    have "steps0 (s, CL @ Bk \<up> z1, r) tm (Suc stp) = step0 (steps0 (s, CL @ Bk \<up> z1, r) tm stp) tm"
+      by (rule step_red)
+
+    with minor
+    have F3: "step0 (steps0 (s, CL @ Bk \<up> z1, r) tm stp) tm = (s', l', r')" by auto
+
+    show "\<exists>z3. z3 \<le> z1 + z2 \<and> steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm (Suc stp) = (s', l' @ Bk \<up> z3, r')"
+    proof (cases "steps0 (s, CL @ Bk \<up> z1, r) tm stp")
+      case (fields sx lx rx)
+      then have CL: "steps0 (s, CL @ Bk \<up> z1, r) tm stp = (sx, lx, rx)" .
+      with IV
+      have "\<exists>z3'\<le>z1 + z2. steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm stp = (sx, lx @ Bk \<up> z3', rx)" by auto
+      then obtain z3' where
+        w_z3': "z3'\<le>z1 + z2 \<and>
+              steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm stp = (sx, lx @ Bk \<up> z3', rx)" by blast
+
+      moreover
+      have "step0 (sx,lx@Bk\<up>z3', rx) tm = (s',l' @ Bk\<up>(z3')  ,r') \<or>
+            step0 (sx,lx@Bk\<up>z3', rx) tm = (s',l' @ Bk\<up>(z3'-1),r')"
+      proof -
+        from F3 and CL have "step0 (sx, lx@Bk\<up>0, rx) tm = (s', l', r')" by auto
+
+        then have "step0 (sx,lx@Bk\<up>(0+z3'), rx) tm = (s',l' @ Bk\<up>(z3')   ,r') \<or>
+                   step0 (sx,lx@Bk\<up>(0+z3'), rx) tm = (s',l' @ Bk\<up>(z3'-1) ,r')"
+          by (rule step_left_tape_EnlargeBkCtx_eq_C_Bks)  (* <-- the step argument *)
+
+        then show "step0 (sx,lx@Bk\<up>z3', rx) tm = (s',l' @ Bk\<up>(z3')  ,r') \<or>
+                   step0 (sx,lx@Bk\<up>z3', rx) tm = (s',l' @ Bk\<up>(z3'-1),r')"
+          by auto
+      qed
+
+      moreover from w_z3' and F1
+      have "steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm (Suc stp) = step0 (sx, lx @ Bk \<up> z3', rx) tm"
+        by auto
+
+      ultimately
+      have "steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm (Suc stp) = (s', l' @ Bk \<up> z3', r') \<or>
+            steps0 (s, CL @ Bk \<up> (z1 + z2), r) tm (Suc stp) = (s', l' @ Bk \<up> (z3'-1), r')"
+        by auto
+      with w_z3' show ?thesis
+        by (auto simp add:  split: if_splits)
+    qed
+  qed
+qed
+
+(* ---------------------------------------------------------------------------------- *)
+(* The grand lemmas about trailing blanks on the left tape                            *)
+(* ---------------------------------------------------------------------------------- *)
+
+corollary steps_left_tape_EnlargeBkCtx:
+  "     steps0 (s, Bk \<up> k, r) tm stp = (s', Bk \<up> l, r')
+   \<Longrightarrow>
+   \<exists>z3. z3 \<le> k + z2 \<and>
+        steps0 (s, Bk \<up> (k + z2), r) tm stp = (s',Bk \<up> (l + z3), r')"
+
+proof -
+  assume "steps0 (s, Bk \<up> k, r) tm stp = (s', Bk \<up> l, r')"
+  then have "\<exists>z3. z3 \<le> k + z2 \<and>
+        steps0 (s, Bk \<up> (k + z2), r) tm stp = (s',Bk \<up> l @ Bk \<up> z3, r')"
+  by (metis append_Nil steps_left_tape_EnlargeBkCtx_arbitrary_CL)
+  then show ?thesis by (simp add: replicate_add)
+qed
+
+corollary steps_left_tape_ShrinkBkCtx_to_NIL:
+  "     steps0 (s, Bk \<up> k, r) tm stp = (s', Bk \<up> l, r')
+   \<Longrightarrow> 
+   \<exists>z3. z3 \<le> l \<and>
+        steps0 (s, [], r) tm stp = (s', Bk \<up> z3, r')"
+proof -
+  assume A: "steps0 (s, Bk \<up> k, r) tm stp = (s', Bk \<up> l, r')"
+  then have F0: "\<exists>zb CL'. Bk \<up> l = CL'@Bk\<up>zb  \<and> steps0 (s,[], r) tm stp = (s',CL',r')"
+  proof (cases k)
+    case 0
+    then show ?thesis
+      using A append_Nil2 replicate_0 by auto
+  next
+    case (Suc nat)
+    then have "0 < k" by auto
+    with A show ?thesis
+      using steps_left_tape_ShrinkBkCtx_arbitrary_CL by auto
+  qed
+  then obtain zb CL' where
+    w: "Bk \<up> l = CL'@Bk\<up>zb  \<and> steps0 (s,[], r) tm stp = (s',CL',r')" by blast
+  then show ?thesis 
+    by (metis  append_same_eq le_add1 length_append length_replicate replicate_add)
+qed
+
+lemma steps_left_tape_Nil_imp_All:
+      "steps0 (s, ([]  , r)) p stp = (s', Bk \<up> k, CR @ Bk \<up> l)
+   \<Longrightarrow>
+   \<forall>z. \<exists>stp k l. (steps0 (s, (Bk\<up>z, r)) p stp) = (s', Bk \<up> k, CR @ Bk \<up> l)"
+proof
+  fix z
+  assume A: "steps0 (s, [], r) p stp = (s', Bk \<up> k, CR @ Bk \<up> l)"
+
+  then have "steps0 (s, Bk \<up> 0 , r) p stp = (s', Bk \<up> k, CR @ Bk \<up> l)" by auto
+  then have "\<exists>z3. z3 \<le> 0 + z \<and>
+        steps0 (s, Bk \<up> (0 + z), r) p stp = (s',Bk \<up> (k + z3), CR @ Bk \<up> l)"
+    by (rule steps_left_tape_EnlargeBkCtx)
+  then have "\<exists>z3. steps0 (s, Bk \<up> z,  r) p stp = (s',Bk \<up> (k + z3), CR @ Bk \<up> l)"
+    by auto
+  then obtain z3 where
+    "steps0 (s, Bk \<up> z,  r) p stp = (s',Bk \<up> (k + z3), CR @ Bk \<up> l)" by blast
+  then show "\<exists>stp k l. steps0 (s, Bk \<up> z,r) p stp = (s', Bk \<up> k, CR @ Bk \<up> l)"
+    by auto
+qed
+
+lemma ex_steps_left_tape_Nil_imp_All:
+      "\<exists>stp k l. (steps0 (s, ([]  , r)) p stp) = (s', Bk \<up> k, CR @ Bk \<up> l)
+   \<Longrightarrow>
+   \<forall>z. \<exists>stp k l. (steps0 (s, (Bk\<up>z, r)) p stp) = (s', Bk \<up> k, CR @ Bk \<up> l)"
+proof
+  fix z
+  assume A: "\<exists>stp k l. steps0 (s, [], r) p stp = (s', Bk \<up> k, CR @ Bk \<up> l)"
+  then obtain stp k l where
+    "steps0 (s, [], r) p stp = (s', Bk \<up> k, CR @ Bk \<up> l)" by blast
+  then show "\<exists>stp k l. steps0 (s, Bk \<up> z, r) p stp = (s', Bk \<up> k, CR @ Bk \<up> l)"
+    using steps_left_tape_Nil_imp_All
+    by auto
+qed
+
+subsection \<open>Trailing blanks on the right tape do not matter\<close>
+
+(* --------------------------------------------------------------- *)
+(* Blanks on the right tape, too                                   *)
+(* --------------------------------------------------------------- *)
+
+lemma step_left_tape_Nil_imp_all_trailing_right_Nil:
+  assumes "step0 (s, CL1, [] ) tm = (s', CR1, CR2 )"
+  shows   "step0 (s, CL1, [] @ Bk \<up> y) tm = (s', CR1, CR2 @ Bk \<up> y) \<or>
+           step0 (s, CL1, [] @ Bk \<up> y) tm = (s', CR1, CR2 @ Bk \<up> (y-1))"
+proof (cases "fetch tm (s - 0) (read ([] ))")
+  case (Pair a s2)
+  then have A1: "fetch tm (s - 0) (read ([])) = (a, s2)" .
+  show ?thesis
+  proof (cases a)
+    assume "a = WB"
+    from \<open>a = WB\<close> and assms A1          have "step0 (s, CL1, []     ) tm = (s2, CL1, [Bk])" by auto
+    moreover from \<open>a = WB\<close> and assms A1 have "step0 (s, CL1, [] @ Bk \<up> y) tm = (s2, CL1, [Bk]@Bk \<up> (y-1))" by auto
+    ultimately show ?thesis using assms by auto
+  next
+    assume "a = WO"
+    from \<open>a = WO\<close> and assms A1          have "step0 (s, CL1, []     ) tm = (s2, CL1, [Oc])" by auto
+    moreover from \<open>a = WO\<close> and assms A1 have "step0 (s, CL1, [] @ Bk \<up> y) tm = (s2, CL1, [Oc] @ Bk \<up> (y-1))" by auto
+    ultimately show ?thesis using assms by auto
+  next
+    assume "a = L"
+    show ?thesis
+    proof (cases CL1)
+      case Nil
+      then have "CL1 = []" .
+      from \<open>CL1 = []\<close> and \<open>a = L\<close> and assms A1          have "step0 (s, CL1, []     ) tm = (s2, CL1, [Bk])"
+        by auto
+      moreover from \<open>CL1 = []\<close> and \<open>a = L\<close> and assms A1
+      have "step0 (s, CL1, [] @ Bk \<up> y) tm = (s2, CL1, Bk # Bk \<up> y)"
+        by (auto simp add:  split: if_splits)
+      ultimately show ?thesis using assms by auto
+    next
+      case (Cons c cs)
+      then have "CL1 = c # cs" .
+      from \<open>CL1 = c # cs \<close> and \<open>a = L\<close> and assms A1         have "step0 (s, CL1, []     ) tm = (s2, cs, [c])"
+        by auto
+      moreover from \<open>CL1 = c # cs\<close> and \<open>a = L\<close> and assms A1
+      have "step0 (s, CL1, [] @ Bk \<up> y) tm = (s2, cs, c # Bk \<up> y)"
+        by (auto simp add:  split: if_splits)
+      ultimately show ?thesis using assms by auto
+    qed
+  next
+    assume "a = Nop"
+    from \<open>a = Nop\<close> and assms and A1          have "step0 (s, CL1, []     ) tm = (s2, CL1, [] )"
+      by auto
+    moreover from \<open>a = Nop\<close> and assms and A1 have "step0 (s, CL1, [] @ Bk \<up> y) tm = (s2, CL1, [] @ Bk \<up> y)" by auto
+    ultimately show ?thesis using assms by auto
+  next
+    assume "a = R"
+    from \<open>a = R\<close> and assms A1 have "step0 (s, CL1, []     ) tm = (s2, Bk#CL1, [] )"
+      by auto
+    moreover from \<open>a = R\<close> and assms A1 have "step0 (s, CL1, [] @ Bk \<up> y) tm = (s2, Bk#CL1, []@ Bk \<up> (y-1) )"
+      by auto
+    ultimately show ?thesis using assms by auto
+  qed
+qed
+
+lemma step_left_tape_Nil_imp_all_trailing_right_Cons:
+  assumes "step0 (s, CL1, rx#rs     ) tm = (s', CR1, CR2 )"
+  shows   "step0 (s, CL1, rx#rs @ Bk \<up> y) tm = (s', CR1, CR2 @ Bk \<up> y)"
+proof (cases "fetch tm (s - 0) (read (rx#rs ))")
+  case (Pair a s2)
+  then have A1: "fetch tm (s - 0) (read (rx#rs )) = (a, s2)" .
+  show ?thesis
+  proof (cases a)
+    assume "a = WB"
+    from \<open>a = WB\<close> and assms A1          have "step0 (s, CL1, rx#rs     ) tm = (s2, CL1, Bk#rs )" by auto
+    moreover from \<open>a = WB\<close> and assms A1 have "step0 (s, CL1, rx#rs @ Bk \<up> y) tm = (s2, CL1, Bk#rs @ Bk \<up> y)" by auto
+    ultimately show ?thesis using assms by auto
+  next
+    assume "a = WO"
+    from \<open>a = WO\<close> and assms A1          have "step0 (s, CL1, rx#rs     ) tm = (s2, CL1, Oc#rs )" by auto
+    moreover from \<open>a = WO\<close> and assms A1 have "step0 (s, CL1, rx#rs @ Bk \<up> y) tm = (s2, CL1, Oc#rs @ Bk \<up> y)" by auto
+    ultimately show ?thesis using assms by auto
+  next
+    assume "a = L"
+    show ?thesis
+    proof (cases CL1)
+      case Nil
+      then have "CL1 = []" .
+      show ?thesis
+      proof -
+        from \<open>a = L\<close> and \<open>CL1 = []\<close> and assms A1          have "step0 (s, CL1, rx#rs     ) tm = (s2, CL1, Bk#rx#rs )" by auto
+        moreover from \<open>a = L\<close> and \<open>CL1 = []\<close> and assms A1 have "step0 (s, CL1, rx#rs @ Bk \<up> y) tm = (s2, CL1, Bk#rx#rs @ Bk \<up> y)" by auto
+        ultimately show ?thesis using assms by auto
+      qed
+    next
+      case (Cons c cs)
+      then have "CL1 = c # cs" .
+      show ?thesis
+      proof -
+        from \<open>a = L\<close> and \<open>CL1 = c # cs\<close> and assms A1          have "step0 (s, CL1, rx#rs     ) tm = (s2, cs, c#rx#rs )" by auto
+        moreover from \<open>a = L\<close> and \<open>CL1 = c # cs\<close> and assms A1 have "step0 (s, CL1, rx#rs @ Bk \<up> y) tm = (s2, cs, c#rx#rs @ Bk \<up> y)" by auto
+        ultimately show ?thesis using assms by auto
+      qed
+    qed
+  next
+    assume "a = R"
+    from \<open>a = R\<close> and assms A1          have "step0 (s, CL1, rx#rs     ) tm = (s2, rx#CL1, rs )" by auto
+    moreover from \<open>a = R\<close> and assms A1 have "step0 (s, CL1, rx#rs @ Bk \<up> y) tm = (s2, rx#CL1, rs @ Bk \<up> y)" by auto
+    ultimately show ?thesis using assms by auto
+  next
+    assume "a = Nop"
+    from \<open>a = Nop\<close> and assms A1          have "step0 (s, CL1, rx#rs     ) tm = (s2, CL1, rx#rs )"
+      by (auto simp add:  split: if_splits)
+    moreover from \<open>a = Nop\<close> and assms A1 have "step0 (s, CL1, rx#rs @ Bk \<up> y) tm = (s2, CL1, rx#rs @ Bk \<up> y)" by auto
+    ultimately show ?thesis using assms by auto
+  qed
+qed
+
+lemma step_left_tape_Nil_imp_all_trailing_right: 
+  assumes "step0 (s, CL1, r     ) tm = (s', CR1, CR2 )"
+  shows   "step0 (s, CL1, r @ Bk \<up> y) tm = (s', CR1, CR2 @ Bk \<up> y) \<or>
+           step0 (s, CL1, r @ Bk \<up> y) tm = (s', CR1, CR2 @ Bk \<up> (y-1))"
+proof (cases r)
+  case Nil
+  then show ?thesis using step_left_tape_Nil_imp_all_trailing_right_Nil assms by auto
+next
+  case (Cons a list)
+  then show ?thesis using step_left_tape_Nil_imp_all_trailing_right_Cons assms by auto
+qed
+
+(* propagate to steps *)
+
+lemma steps_left_tape_Nil_imp_all_trailing_right:
+          "steps0 (s, CL1, r ) tm stp = (s', CR1, CR2)
+   \<Longrightarrow>
+      \<exists>x1 x2. y = x1 + x2 \<and>
+              steps0 (s, CL1, r @ Bk \<up> y ) tm stp = (s', CR1, CR2 @ Bk \<up> x2)"
+proof (induct stp arbitrary: s CL1 r y s' CR1 CR2)
+  case 0
+  then show ?case
+    by (simp add: "0.prems" steps_left_tape_Nil_imp_All)
+next
+  fix stp s CL1 r y s' CR1 CR2
+  assume IV: "\<And>s CL1 r y s' CR1 CR2. steps0 (s, CL1, r) tm stp = (s', CR1, CR2) \<Longrightarrow> \<exists>x1 x2. y = x1 + x2 \<and> steps0 (s, CL1, r @ Bk \<up> y) tm stp = (s', CR1, CR2 @ Bk \<up> x2)"
+  and major: "steps0 (s, CL1, r) tm (Suc stp) = (s', CR1, CR2)"
+
+  show "\<exists>x1 x2. y = x1 + x2 \<and> steps0 (s, CL1, r @ Bk \<up> y) tm (Suc stp) = (s', CR1, CR2 @ Bk \<up> x2)"
+   proof -
+    have F1: "steps0 (s, CL1, r @ Bk \<up> y) tm (Suc stp) = step0 (steps0 (s, CL1, r @ Bk \<up> y) tm stp) tm"
+      by (rule step_red)
+
+    have "steps0 (s, CL1, r) tm (Suc stp) = step0 (steps0 (s, CL1, r) tm stp) tm"
+      by (rule step_red)
+
+    with major
+    have F3: "step0 (steps0 (s, CL1, r) tm stp) tm = (s', CR1, CR2)" by auto
+
+    show "\<exists>x1 x2. y = x1 + x2 \<and> steps0 (s, CL1, r @ Bk \<up> y) tm (Suc stp) = (s', CR1, CR2 @ Bk \<up> x2)"
+    proof (cases y)
+      case 0
+      then have "y = 0" .
+      with major show ?thesis by auto
+    next
+      case (Suc y')
+      then have "y = Suc y'" .
+      then show ?thesis 
+      proof (cases "steps0 (s, CL1, r) tm stp")
+        case (fields sx lx rx)
+        then have C: "steps0 (s, CL1, r) tm stp = (sx, lx, rx)" .
+        with major and IV have F0:               "\<exists>x1' x2'. y = x1' + x2' \<and> steps0 (s, CL1, r @ Bk \<up> y) tm stp = (sx, lx, rx @ Bk \<up> x2')"
+          by auto
+        then obtain x1' x2' where w_x1'_x2': " y = x1' + x2' \<and> steps0 (s, CL1, r @ Bk \<up> y) tm stp = (sx, lx, rx @ Bk \<up> x2')" by blast
+
+        moreover have "step0 (sx, lx, rx @ Bk \<up> x2') tm =  (s', CR1, CR2 @ Bk \<up> x2') \<or>
+                       step0 (sx, lx, rx @ Bk \<up> x2') tm = (s', CR1, CR2 @ Bk \<up> (x2'-1))"
+
+        proof -
+          from F3 and C have F5: "step0 (sx, lx, rx) tm = (s', CR1, CR2)" by auto
+
+          then have "step0 (sx, lx, rx @ Bk \<up> x2') tm = (s', CR1, CR2 @ Bk \<up> x2') \<or>
+                     step0 (sx, lx, rx @ Bk \<up> x2') tm = (s', CR1, CR2 @ Bk \<up> (x2'-1))"
+            by (rule step_left_tape_Nil_imp_all_trailing_right)
+          then show "step0 (sx, lx, rx @ Bk \<up> x2') tm =  (s', CR1, CR2 @ Bk \<up> x2') \<or>
+                       step0 (sx, lx, rx @ Bk \<up> x2') tm = (s', CR1, CR2 @ Bk \<up> (x2'-1))"
+            by auto
+        qed
+
+        moreover from w_x1'_x2' and F1
+        have "steps0 (s, CL1, r @ Bk \<up> y) tm (Suc stp) = step0 (sx, lx, rx @ Bk \<up> x2') tm" by auto 
+
+        ultimately have F5: "y = x1' + x2' \<and>
+                         (steps0 (s, CL1, r @ Bk \<up> y) tm (Suc stp) = (s', CR1, CR2 @ Bk \<up> x2') \<or> 
+                          steps0 (s, CL1, r @ Bk \<up> y) tm (Suc stp) = (s', CR1, CR2 @ Bk \<up> (x2' - 1)))"
+          by auto
+        with w_x1'_x2' show ?thesis
+        proof (cases x2')
+          case 0
+          with F5 have  "y = x1' + 0 \<and>
+                         steps0 (s, CL1, r @ Bk \<up> y) tm (Suc stp) = (s', CR1, CR2 @ Bk \<up> 0)"
+            by (auto simp add:  split: if_splits)
+          with w_x1'_x2' show ?thesis
+            by (auto simp add:  split: if_splits)
+        next
+          case (Suc x2'')        
+          with w_x1'_x2' show ?thesis
+            using F5 add_Suc_right add_Suc_shift diff_Suc_1 by fastforce
+        qed
+      qed
+    qed
+  qed
+qed
+
+(* ---------------------------------------------------------------------------------- *)
+(* The grand lemmas about trailing blanks on the right tape                           *)
+(* ---------------------------------------------------------------------------------- *)
+
+lemma ex_steps_left_tape_Nil_imp_All_left_and_right:
+ "(\<exists>kr lr.         steps0 (1, ([]     , r          )) p stp = (0, Bk \<up> kr, r' @ Bk \<up> lr))
+  \<Longrightarrow>
+   \<forall>kl ll. \<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p stp = (0, Bk \<up> kr, r' @ Bk \<up> lr)"
+proof -
+  assume "(\<exists>kr lr.         steps0 (1, ([]     , r          )) p stp = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
+  then obtain kr lr where
+    w_kr_lr: "steps0 (1, ([]     , r          )) p stp = (0, Bk \<up> kr, r' @ Bk \<up> lr)" by blast
+
+  then have "steps0 (1, (Bk \<up> 0     , r          )) p stp = (0, Bk \<up> kr, r' @ Bk \<up> lr)"
+    by auto
+
+  then have "\<And>kl. \<exists>z3. z3 \<le> 0 + kl \<and> steps0 (1, Bk \<up> (0 + kl), r) p stp = (0,Bk \<up> (kr + z3), r' @ Bk \<up> lr)"
+    using steps_left_tape_EnlargeBkCtx
+    using plus_nat.add_0 w_kr_lr by blast
+
+  then have "\<And>kl. \<exists>z3. z3 \<le> kl \<and> steps0 (1, Bk \<up> kl, r) p stp = (0,Bk \<up> (kr + z3), r' @ Bk \<up> lr)"
+    by auto
+
+  then have F0: "\<And>kl.      \<exists>z4.    steps0 (1, Bk \<up> kl, r           ) p stp =  (0,Bk \<up> z4 , r' @ Bk \<up> lr)"
+    by auto
+
+  show ?thesis
+  proof 
+    fix kl
+    show " \<forall>ll. \<exists>kr lr. steps0 (1, Bk \<up> kl, r @ Bk \<up> ll) p stp = (0, Bk \<up> kr, r' @ Bk \<up> lr)"
+    proof
+      fix ll
+      show "\<exists>kr lr. steps0 (1, Bk \<up> kl, r @ Bk \<up> ll) p stp = (0, Bk \<up> kr, r' @ Bk \<up> lr)"
+
+      proof -
+        from F0 have "\<exists>z4.    steps0 (1, Bk \<up> kl, r           ) p stp =  (0,Bk \<up> z4 , r' @ Bk \<up> lr)"
+          by auto
+        then obtain z4 where w_z4: "steps0 (1, Bk \<up> kl, r           ) p stp =  (0,Bk \<up> z4 , r' @ Bk \<up> lr)" by blast
+
+        then have "\<exists>x1 x2. ll = x1 + x2 \<and>
+                steps0 (1, Bk \<up> kl , r @ Bk \<up> ll ) p stp = (0, Bk \<up> z4    , r' @ Bk \<up> lr @ Bk \<up> x2)"
+          using steps_left_tape_Nil_imp_all_trailing_right
+
+          using append_assoc by fastforce
+
+        then show "\<exists>kr lr. steps0 (1, Bk \<up> kl, r @ Bk \<up> ll) p stp = (0, Bk \<up> kr, r' @ Bk \<up> lr)"
+          by (metis replicate_add)
+      qed
+    qed
+  qed
+qed
+
+end
diff --git a/thys/Universal_Turing_Machine/CHANGELOG b/thys/Universal_Turing_Machine/CHANGELOG
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/CHANGELOG
@@ -0,0 +1,124 @@
+# -------------------------------
+# Release current (as of 08/2022)
+# -------------------------------
+
+- Renaming of concepts
+
+  * Constructors W0 and W1 of type action were renamed to WB and WO.
+
+    Rational:
+    The book by Boolos, Burgess and Jeffrey uses tape symbols 0 and 1 and
+    uses actions 0 and 1 for writing these symbols as well.
+
+    However, the formal definition in the AFP entry (release afp-2022-07-04)
+    models the tape symbols as
+
+      datatype cell = Bk | Oc
+
+    and actions as
+
+      datatype action = W0 | W1 | L | R | Nop
+
+    This is quite confusing, since action W0 will result in a Bk
+    and action W1 will result in a Oc on the tape. Moreover, we use
+    the notation for <0> and <1> for the encoding of numerals.
+
+      <0> is translated into [Oc]
+      <1> is translated into [Oc, Oc]
+
+    In the current release, we therefore use
+
+      datatype action = WB | WO | L | R | Nop
+
+  * Renaming of tm_wf into composable_tm
+  
+    Rational:
+    The release afp-2022-07-04 defined the notion tm_wf of well-formed
+    instruction lists for Turing Machines. Sequential composition of
+    TMs is of no use, if the first machine is not 'well-formed'.
+
+    However, there is nothing wrong with TMs that are not 'well-formed'.
+    They are simply not composable with other machines.
+    Moreover, every non-well-formed TM can be recoded into some
+    well-formed TM with the same behaviour with respect to computations.
+    See function mk_composable0 in theory ComposableTMs.
+
+    Therefore, we considered tm_wf as beeing a miss-nomer and
+    therefore renamed tm_wf into composable_tm, which
+    seems to be more appropriate.
+ 
+  * Renaming of tm_comp into seq_tm
+
+    Rational:
+    In the future we plan to add more composition operators, e.g.
+    for branching and loops. This makes tm_comp a miss-nomer, too.
+
+  * Renaming of 'halts' into TMC_has_num_res
+
+    Rational:
+    In the new theory Turing_HaltingConditions we formalize several
+    notions of 'halting':
+
+      reaches_final
+      TMC_has_num_res
+      TMC_has_num_list_res
+      TMC_yields_num_res
+      TMC_yields_num_list_res
+
+    which are used for the definitions of Turing Decidability,
+    Turing Computability and Turing Reducibility.
+
+  * General consolidation of naming for TMs.
+
+    Wherever possible we use a leading tm_ for names of TMs.
+    E.g. tm_weak_copy, tm_strong_copy, tm_onestroke)
+
+- Restructuring of theories
+
+    "Turing"
+    "Uncomputable"
+
+  Rational:
+  Due to major additions by Franz Regensburger in the current release
+  it was necessary to split these theories into several smaller parts,
+  which simplified the introduction of additional theory files. The
+  dependency graph of theories is much more fine grained, now.
+  See the session graph in the browser.
+
+  Note about the new structure and where parts of the old theories
+  were moved:
+
+    Theory "Turing"
+      parts were moved to the new theories
+
+      "BlanksDoNotMatter"
+      "ComposableTMs"
+      "ComposedTMs"
+      "Numerals"
+
+    Theory "Uncomputable"
+      parts were moved to 
+
+      "Numerals"
+      "Turing_HaltingConditions"
+      "DitherTM"
+      "CopyTM"
+      "TuringUnComputable_H2_original"
+      "UTM"
+
+    and augmented by e.g.
+      "TuringDecidable"
+      "TuringReducible"
+      "HaltingProblems_K_H"
+      "TuringUnComputable_H2"
+      "TuringComputable"
+
+   The remainig theory files of the afp-2022-07-04 were kept as is,
+   apart from additional comments and changes due to the enhancement
+   of the LaTeX section structure.
+
+# -------------------------------
+# Release afp-2022-07-04
+# -------------------------------
+(base line for the change log)
+
diff --git a/thys/Universal_Turing_Machine/ComposableTMs.thy b/thys/Universal_Turing_Machine/ComposableTMs.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/ComposableTMs.thy
@@ -0,0 +1,1503 @@
+(* Title: thys/ComposableTMs.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+ 
+   Modifications and comments by Franz Regensburger (FABR) 02/2022
+
+   * added function mk_composable0 that generates composable TMs from non-composable TMs
+     such that the overall behaviour of the TM is preserved.
+
+     This is important for the proof of the existence of uncomputable functions
+     respectively undecidable sets and relations.
+ *)
+
+theory ComposableTMs
+  imports Turing
+begin
+
+section \<open>Making Turing Machines composable\<close>
+
+(* Well-formedness of Turing machine programs
+ *
+ * For certain inputs programs tm with \<not>(composable_tm tm) may reach
+ * the final state with a standard tape!
+ *
+ * These machines are no junk. They are simply not composable via |+|
+ *)
+
+abbreviation "is_even n \<equiv> (n::nat) mod 2 = 0"
+abbreviation "is_odd n \<equiv> (n::nat) mod 2 \<noteq> 0"
+
+fun 
+  composable_tm :: "tprog \<Rightarrow> bool"
+  where
+    "composable_tm (p, off) = (length p \<ge> 2 \<and> is_even (length p) \<and> 
+                    (\<forall>(a, s) \<in> set p. s \<le> length p div 2 + off \<and> s \<ge> off))"
+
+abbreviation
+  "composable_tm0 p \<equiv> composable_tm (p, 0)"
+
+lemma step_in_range: 
+  assumes h1: "\<not> is_final (step0 c A)"
+    and h2: "composable_tm (A, 0)"
+  shows "fst (step0 c A) \<le> length A div 2"
+  using h1 h2
+  apply(cases c;cases "fst c";cases "hd (snd (snd c))")
+  by(auto simp add: Let_def case_prod_beta')
+
+lemma steps_in_range: 
+  assumes h1: "\<not> is_final (steps0 (1, tap) A stp)"
+    and h2: "composable_tm (A, 0)"
+  shows "fst (steps0 (1, tap) A stp) \<le> length A div 2"
+  using h1
+proof(induct stp)
+  case 0
+  then show "fst (steps0 (1, tap) A 0) \<le> length A div 2" using h2
+    by (auto)
+next
+  case (Suc stp)
+  have ih: "\<not> is_final (steps0 (1, tap) A stp) \<Longrightarrow> fst (steps0 (1, tap) A stp) \<le> length A div 2" by fact
+  have h: "\<not> is_final (steps0 (1, tap) A (Suc stp))" by fact
+  from ih h h2 show "fst (steps0 (1, tap) A (Suc stp)) \<le> length A div 2"
+    by (metis step_in_range step_red)
+qed
+
+(* ------------------------------------------------------------------------ *)
+(* New by FABR                                                              *)
+(* ------------------------------------------------------------------------ *)
+
+subsection \<open>Definitin of function fix\_jumps and mk\_composable0\<close>
+
+fun fix_jumps  :: "nat \<Rightarrow> tprog0 \<Rightarrow> tprog0" where
+  "fix_jumps smax [] = []" |
+  "fix_jumps smax (ins#inss) = (if (snd ins) \<le> smax
+                                then ins # fix_jumps smax inss
+                                else ((fst ins),0)#fix_jumps smax inss)"
+
+fun mk_composable0 :: "tprog0 \<Rightarrow> tprog0" where
+  "mk_composable0 []   = [(Nop,0),(Nop,0)]" |
+  "mk_composable0 [i1] = fix_jumps 1 [i1,(Nop,0)]" |
+  "mk_composable0 (i1#i2#ins) = (let l = 2 + length ins
+                        in if is_even l
+                           then fix_jumps (l div 2)       (i1#i2#ins)
+                           else fix_jumps ((l div 2) + 1) ((i1#i2#ins)@[(Nop,0)]))"
+
+
+subsection \<open>Properties of function fix\_jumps\<close>
+
+lemma fix_jumps_len: "length (fix_jumps smax insl) = length insl"
+  by (induct insl) auto
+
+lemma fix_jumps_le_smax: "\<forall>x \<in> set (fix_jumps smax tm). (snd x) \<le> smax"
+proof (rule filter_id_conv[THEN iffD1])
+  show "filter (\<lambda>x. snd x \<le> smax) (fix_jumps smax tm) = fix_jumps smax tm"
+    by (induct tm)(auto)
+qed
+
+lemma fix_jumps_nth_no_fix:
+  assumes "n < length tm" and "tm!n = ins" and "(snd ins) \<le> smax"
+  shows "(fix_jumps smax tm)!n = ins"
+proof -
+  have "n < length tm \<and> tm!n = ins \<and> (snd ins) \<le> smax \<longrightarrow> (fix_jumps smax tm)!n = ins"
+  proof (induct tm arbitrary: n ins)
+    case Nil
+    then show ?case by auto
+  next
+    fix a tm n ins
+    assume IV: "\<And>n' ins'. n' < length tm \<and> tm ! n' = ins' \<and> snd ins' \<le> smax \<longrightarrow> fix_jumps smax tm ! n' = ins'"
+    show "n < length (a # tm) \<and> (a # tm) ! n = ins \<and> snd ins \<le> smax \<longrightarrow> fix_jumps smax (a # tm) ! n = ins"
+    proof (cases n)
+      case 0
+      then show ?thesis by auto
+    next
+      fix nat
+      assume "n = Suc nat"
+      show "n < length (a # tm) \<and> (a # tm) ! n = ins \<and> snd ins \<le> smax \<longrightarrow> fix_jumps smax (a # tm) ! n = ins"
+      proof
+        assume A: "n < length (a # tm) \<and> (a # tm) ! n = ins \<and> snd ins \<le> smax"
+        show "fix_jumps smax (a # tm) ! n = ins"
+        proof (cases "(snd a) \<le> smax")
+          case True
+          then have "fix_jumps smax (a # tm) ! (Suc nat) =  (a # (fix_jumps smax tm)) ! Suc nat" by auto
+          also have "... = (fix_jumps smax tm) !nat" by auto
+          finally have "fix_jumps smax (a # tm) ! Suc nat = (fix_jumps smax tm) !nat" by auto
+          also with \<open>n = Suc nat\<close> A and IV have "... = ins" by auto
+          finally have "fix_jumps smax (a # tm) ! Suc nat = ins" by auto
+          with \<open>n = Suc nat\<close> show "fix_jumps smax (a # tm) ! n = ins" by auto
+        next
+          case False
+          then have "fix_jumps smax (a # tm) ! (Suc nat) =  (((fst a),0) # (fix_jumps smax tm)) ! Suc nat" by auto
+          also have "... = (fix_jumps smax tm) !nat" by auto
+          finally have "fix_jumps smax (a # tm) ! Suc nat = (fix_jumps smax tm) !nat" by auto
+          also with \<open>n = Suc nat\<close> A and IV have "... = ins" by auto
+          finally have "fix_jumps smax (a # tm) ! Suc nat = ins" by auto
+          with \<open>n = Suc nat\<close> show "fix_jumps smax (a # tm) ! n = ins" by auto
+        qed
+      qed
+    qed
+  qed
+  with assms show ?thesis by auto
+qed
+
+lemma fix_jumps_nth_fix:
+  assumes "n < length tm" and "tm!n = ins" and "\<not>(snd ins) \<le> smax"
+  shows "(fix_jumps smax tm)!n = ((fst ins),0)"
+proof -
+  have "n < length tm \<and> tm!n = ins \<and> \<not>(snd ins) \<le> smax \<longrightarrow> (fix_jumps smax tm)!n = ((fst ins),0)"
+  proof (induct tm arbitrary: n ins)
+    case Nil
+    then show ?case by auto
+  next
+    fix a tm n ins
+    assume IV: "\<And>n' ins'. n' < length tm \<and> tm ! n' = ins' \<and> \<not>(snd ins') \<le> smax \<longrightarrow> fix_jumps smax tm ! n' = (fst ins', 0)"
+    show "n < length (a # tm) \<and> (a # tm) ! n = ins \<and> \<not> snd ins \<le> smax \<longrightarrow> fix_jumps smax (a # tm) ! n = (fst ins, 0)"
+    proof (cases n)
+      case 0
+      then show ?thesis by auto
+    next
+      fix nat
+      assume "n = Suc nat"
+      show "n < length (a # tm) \<and> (a # tm) ! n = ins \<and> \<not> snd ins \<le> smax \<longrightarrow> fix_jumps smax (a # tm) ! n = (fst ins, 0)"
+      proof
+        assume A: "n < length (a # tm) \<and> (a # tm) ! n = ins \<and> \<not> snd ins \<le> smax"
+        show "fix_jumps smax (a # tm) ! n = (fst ins, 0)"
+        proof (cases "(snd a) \<le> smax")
+          case True
+          then have "fix_jumps smax (a # tm) ! (Suc nat) =  (a # (fix_jumps smax tm)) ! Suc nat" by auto
+          also have "... = (fix_jumps smax tm) !nat" by auto
+          finally have "fix_jumps smax (a # tm) ! Suc nat = (fix_jumps smax tm) !nat" by auto
+          also with \<open>n = Suc nat\<close> A and IV have "... = (fst ins, 0)" by auto
+          finally have "fix_jumps smax (a # tm) ! Suc nat = (fst ins, 0)" by auto
+          with \<open>n = Suc nat\<close> show "fix_jumps smax (a # tm) ! n = (fst ins, 0)" by auto
+        next
+          case False
+          then have "fix_jumps smax (a # tm) ! (Suc nat) =  (((fst a),0) # (fix_jumps smax tm)) ! Suc nat" by auto
+          also have "... = (fix_jumps smax tm) !nat" by auto
+          finally have "fix_jumps smax (a # tm) ! Suc nat = (fix_jumps smax tm) !nat" by auto
+          also with \<open>n = Suc nat\<close> A and IV have "... = (fst ins, 0)" by auto
+          finally have "fix_jumps smax (a # tm) ! Suc nat = (fst ins, 0)" by auto
+          with \<open>n = Suc nat\<close> show "fix_jumps smax (a # tm) ! n = (fst ins, 0)" by auto
+        qed
+      qed
+    qed
+  qed
+  with assms show ?thesis by auto
+qed
+
+subsection \<open>Functions fix\_jumps and mk\_composable0 generate composable Turing Machines.\<close>
+
+lemma composable_tm0_fix_jumps_pre:
+  assumes "length tm \<ge> 2" and "is_even (length tm)"
+  shows "length (fix_jumps (length tm div 2) tm) \<ge> 2 \<and>
+          is_even (length (fix_jumps (length tm div 2) tm)) \<and> 
+          (\<forall>x \<in> set (fix_jumps (length tm div 2) tm).
+             (snd x) \<le> length (fix_jumps (length tm div 2) tm) div 2 + 0 \<and> (snd x) \<ge> 0)"
+proof
+  show "2 \<le> length (fix_jumps (length tm div 2) tm)"
+    using assms by (auto simp add: fix_jumps_len)
+next
+  show "is_even (length (fix_jumps (length tm div 2) tm)) \<and>
+        (\<forall>x\<in>set (fix_jumps (length tm div 2) tm). snd x \<le> length (fix_jumps (length tm div 2) tm) div 2 + 0 \<and> 0 \<le> snd x)"
+  proof
+    show "is_even (length (fix_jumps (length tm div 2) tm))"
+      using assms by (auto simp add: fix_jumps_len)
+  next
+    show "\<forall>x\<in>set (fix_jumps (length tm div 2) tm). snd x \<le> length (fix_jumps (length tm div 2) tm) div 2 + 0 \<and> 0 \<le> snd x"
+      by (auto simp add: fix_jumps_le_smax fix_jumps_len)
+  qed
+qed
+
+lemma composable_tm0_fix_jumps:
+  assumes "length tm \<ge> 2" and "is_even (length tm)"
+  shows "composable_tm0 (fix_jumps (length tm div 2) tm)"
+proof -
+  from assms have "length (fix_jumps (length tm div 2) tm) \<ge> 2 \<and>
+                   is_even (length (fix_jumps (length tm div 2) tm)) \<and> 
+                   (\<forall>x \<in> set (fix_jumps (length tm div 2) tm).
+                      (snd x) \<le> length (fix_jumps (length tm div 2) tm) div 2 + 0 \<and> (snd x) \<ge> 0)"
+    by (rule composable_tm0_fix_jumps_pre)
+  then show ?thesis by auto
+qed
+
+
+lemma fix_jumps_composable0_eq:
+  assumes "composable_tm0 tm"
+  shows "(fix_jumps (length tm div 2) tm) = tm"
+proof -
+  from assms have major: "\<forall>(a, s) \<in> set tm. s \<le> length tm div 2" by auto
+  then show "(fix_jumps (length tm div 2) tm) = tm"
+    by  (induct rule: fix_jumps.induct)(auto)
+qed
+
+lemma composable_tm0_mk_composable0: "composable_tm0 (mk_composable0 tm)"
+proof (rule mk_composable0.cases)
+  assume "tm = []"
+  then show "composable_tm0 (mk_composable0 tm)"
+    by (auto simp add: composable_tm0_fix_jumps)
+next
+  fix i1
+  assume "tm = [i1]"
+  then show "composable_tm0 (mk_composable0 tm)"
+    by (auto simp add: composable_tm0_fix_jumps)
+next
+  fix i1 i2 ins
+  assume A: "tm = i1 # i2 # ins"
+  then show "composable_tm0 (mk_composable0 tm)"
+  proof (cases "is_even (2 + length ins)")
+    case True
+    then have "is_even (2 + length ins)" .
+    then have "mk_composable0 (i1 # i2 # ins) = fix_jumps ((2 + length ins) div 2) (i1#i2#ins)"
+      by auto
+    also have "... = fix_jumps (length (i1#i2#ins) div 2) (i1#i2#ins)"
+      by auto
+    finally have "mk_composable0 (i1 # i2 # ins) = fix_jumps (length (i1#i2#ins) div 2) (i1#i2#ins)"
+      by auto
+    moreover have "composable_tm0 (fix_jumps (length (i1#i2#ins) div 2) (i1#i2#ins))"
+    proof (rule composable_tm0_fix_jumps)
+      show "2 \<le> length (i1 # i2 # ins)" by auto
+    next
+      from \<open>is_even (2 + length ins)\<close> show "is_even (length (i1 # i2 # ins))" 
+        by (auto)
+    qed
+    ultimately show "composable_tm0 (mk_composable0 tm)" using A by auto
+  next
+    case False
+    then have "(2 + length ins) mod 2 \<noteq> 0" .
+    then have "mk_composable0 (i1 # i2 # ins) = fix_jumps (((2 + length ins) div 2) +1) ((i1#i2#ins)@[(Nop,0)])"
+      by auto
+    also have "... = fix_jumps ((length (i1#i2#ins) div 2) +1) ((i1#i2#ins)@[(Nop,0)])"
+      by auto
+    also have "... = fix_jumps (length (i1#i2#ins@[(Nop,0)]) div 2) ((i1#i2#ins)@[(Nop,0)])"
+    proof -
+      from \<open>(2 + length ins) mod 2 \<noteq> 0\<close>
+      have "length ins mod 2 \<noteq> 0" by arith
+      then have "length (i1 # i2 # ins ) mod 2  \<noteq> 0" by auto
+
+      have "(length (i1 # i2 # ins ) div 2) + 1 = length (i1 # i2 # ins @ [(Nop, 0)]) div 2"
+      proof -
+        from \<open>length (i1 # i2 # ins ) mod 2  \<noteq> 0\<close>
+        have "(length (i1 # i2 # ins ) div 2) + 1 = (length (i1 # i2 # ins) +1) div 2"
+          by (rule odd_div2_plus_1_eq)
+        also have "... = length (i1 # i2 # ins @ [(Nop, 0)]) div 2" by auto
+        finally show ?thesis by auto
+      qed
+
+      then show "fix_jumps (length (i1 # i2 # ins) div 2 + 1) ((i1 # i2 # ins) @ [(Nop, 0)]) =
+                 fix_jumps (length (i1 # i2 # ins @ [(Nop, 0)]) div 2) ((i1 # i2 # ins) @ [(Nop, 0)])"
+        by auto
+    qed
+    finally have "mk_composable0 (i1 # i2 # ins) =
+                   fix_jumps (length (i1 # i2 # ins @ [(Nop, 0)]) div 2) ((i1 # i2 # ins) @ [(Nop, 0)])"
+      by auto
+
+    moreover have "composable_tm0 (fix_jumps (length (i1 # i2 # ins @ [(Nop, 0)]) div 2) (i1 # i2 # ins @ [(Nop, 0)]))"
+    proof (rule composable_tm0_fix_jumps)
+      show " 2 \<le> length (i1 # i2 # ins @ [(Nop, 0)])" by auto
+    next
+      show "is_even (length (i1 # i2 # ins @ [(Nop, 0)]))"
+      proof -
+        from \<open>(2 + length ins) mod 2 \<noteq> 0\<close> have "length (i1 # i2 # ins) mod 2  \<noteq> 0" by auto
+        then have "is_even (length (i1 # i2 # ins) +1)" by arith
+        moreover have "length (i1 # i2 # ins) +1 = length (i1 # i2 # ins @ [(Nop, 0)])" by auto
+        ultimately show "is_even (length (i1 # i2 # ins @ [(Nop, 0)]))" by auto
+      qed
+    qed
+    ultimately show "composable_tm0 (mk_composable0 tm)" using A by auto
+  qed
+qed
+
+subsection \<open>Functions mk\_composable0 is the identity on composable Turing Machines\<close>
+
+lemma mk_composable0_eq:
+  assumes "composable_tm0 tm"
+  shows "mk_composable0 tm = tm"
+proof -
+  from assms have major: "length tm \<ge> 2 \<and> is_even (length tm)" by auto
+  show "mk_composable0 tm = tm"
+  proof (rule mk_composable0.cases)
+    assume "tm = []"
+    with major have False by auto
+    then show "mk_composable0 tm = tm" by auto
+  next
+    fix i1
+    assume "tm = [i1]"
+    with major have False by auto
+    then show "mk_composable0 tm = tm" by auto
+  next
+    fix i1 i2 ins
+    assume A: "tm = i1 # i2 # ins"
+    then show " mk_composable0 tm = tm"
+    proof (cases "is_even (2 + length ins)")
+      case True
+      then have "is_even (2 + length ins)" .
+      then have "mk_composable0 (i1 # i2 # ins) = fix_jumps ((2 + length ins) div 2) (i1#i2#ins)"
+        by auto
+      also have "... = fix_jumps (length (i1#i2#ins) div 2) (i1#i2#ins)"
+        by auto
+      finally have "mk_composable0 (i1 # i2 # ins) = fix_jumps (length (i1#i2#ins) div 2) (i1#i2#ins)"
+        by auto
+      also have "fix_jumps (length (i1#i2#ins) div 2) (i1#i2#ins) = (i1#i2#ins)"
+      proof (rule fix_jumps_composable0_eq)
+        from assms and A show "composable_tm0 (i1 # i2 # ins)"
+          by auto
+      qed
+      finally have "mk_composable0 (i1 # i2 # ins) = i1 # i2 # ins" by auto
+      with A show "mk_composable0 tm = tm" by auto
+    next
+      case False
+      then have "(2 + length ins) mod 2 \<noteq> 0" by auto
+      then have "length (i1 # i2 # ins) mod 2 \<noteq> 0" by auto
+      with A have "length tm   mod 2 \<noteq> 0" by auto
+      with assms have False by auto
+      then show ?thesis by auto
+    qed
+  qed
+qed
+
+(* ----------------------------------------------- *)
+(* About the length of (mk_composable0 tm)                 *)
+(* ----------------------------------------------- *)
+
+subsection \<open>About the length of mk\_composable0 tm\<close>
+
+lemma length_mk_composable0_nil: "length (mk_composable0 []) = 2"
+  by auto
+
+lemma length_mk_composable0_singleton: "length (mk_composable0 [i1]) = 2"
+  by auto
+
+lemma length_mk_composable0_gt2_even: "is_even (length (i1 # i2 # ins)) \<Longrightarrow> length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)"
+proof -
+  assume "is_even (length (i1 # i2 # ins))"
+  then have "length (mk_composable0 (i1 # i2 # ins)) = length (fix_jumps ((length (i1 # i2 # ins)) div 2) (i1#i2#ins))" by auto
+  also have "... = length (i1#i2#ins)" by (auto simp add: fix_jumps_len)
+  finally show "length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)" by auto
+qed
+
+lemma length_mk_composable0_gt2_odd: "\<not>is_even (length (i1 # i2 # ins)) \<Longrightarrow> length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)+1"
+proof -
+  assume "\<not>is_even (length (i1 # i2 # ins))"
+  then have "length (mk_composable0 (i1 # i2 # ins)) = length (fix_jumps (((length (i1 # i2 # ins)) div 2)+1) ((i1#i2#ins)@[(Nop,0)]))" by auto
+  also have "... = length ((i1#i2#ins)@[(Nop,0)])" by (auto simp add: fix_jumps_len)
+  finally show "length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins) + 1" by auto
+qed
+
+lemma length_mk_composable0_even: "\<lbrakk>0 < length tm ; is_even (length tm) \<rbrakk> \<Longrightarrow> length (mk_composable0 tm) = length tm"
+proof (rule mk_composable0.cases[of tm])
+  assume "0 < length tm"
+    and  "is_even (length tm)"
+    and "tm = []"
+  then show ?thesis by auto
+next
+  fix i1
+  assume "0 < length tm" and "is_even (length tm)" and "tm = [i1]"
+  then show ?thesis by auto
+next
+  fix i1 i2 ins
+  assume "0 < length tm" and "is_even (length tm)" and "tm = i1 # i2 # ins"
+  then show ?thesis
+  proof (cases "is_even (2 + length ins)")
+    case True
+    then have "is_even (2 + length ins)" .
+    then have "mk_composable0 (i1 # i2 # ins) = fix_jumps ((2 + length ins) div 2) (i1#i2#ins)" by auto
+    moreover have "length (fix_jumps ((2 + length ins) div 2) (i1#i2#ins)) = length (i1#i2#ins)"
+      by (rule fix_jumps_len)
+    ultimately have "length (mk_composable0 (i1 # i2 # ins)) =  length (i1#i2#ins)" by auto
+    with \<open>tm = i1 # i2 # ins\<close> show ?thesis by auto
+  next
+    case False
+    with \<open>is_even (length tm)\<close> and  \<open>tm = i1 # i2 # ins\<close> have False by auto
+    then show ?thesis by auto
+  qed
+qed
+
+lemma length_mk_composable0_odd: "\<lbrakk>0 < length tm ; \<not>is_even (length tm) \<rbrakk> \<Longrightarrow> length (mk_composable0 tm) = 1 + length tm"
+proof (rule mk_composable0.cases[of tm])
+  assume "0 < length tm"
+    and  "\<not> is_even (length tm)"
+    and "tm = []"
+  then show ?thesis by auto
+next
+  fix i1
+  assume "0 < length tm" and "\<not>is_even (length tm)" and "tm = [i1]"
+  then show ?thesis by auto
+next
+  fix i1 i2 ins
+  assume "0 < length tm" and "\<not>is_even (length tm)" and "tm = i1 # i2 # ins"
+  then show ?thesis
+  proof (cases "is_even (2 + length ins)")
+    case True
+    with \<open>\<not>is_even (length tm)\<close> and \<open>tm = i1 # i2 # ins\<close> have False by auto
+    then show ?thesis by auto
+  next
+    case False
+    then have "\<not>is_even (2 + length ins)" by auto
+    then have "mk_composable0 (i1 # i2 # ins) = fix_jumps (((2 + length ins) div 2)+1 ) ((i1#i2#ins)@[(Nop,0)])"
+      by auto
+    moreover have "length (fix_jumps ( ((2 + length ins) div 2)+1 ) ((i1#i2#ins)@[(Nop,0)])) = length ((i1#i2#ins)@[(Nop,0)])"
+      by (rule fix_jumps_len)
+    ultimately have "length (mk_composable0 (i1 # i2 # ins)) =  1 + length (i1#i2#ins)" by auto
+    with \<open>tm = i1 # i2 # ins\<close> show ?thesis by auto
+  qed
+qed
+
+lemma length_tm_le_mk_composable0: "length tm \<le> length (mk_composable0 tm)"
+proof (cases "length tm")
+  case 0
+  then show ?thesis by auto
+next
+  case (Suc nat)
+  then have A: "length tm = Suc nat" .
+  show ?thesis
+  proof (cases "is_even (length tm)")
+    case True
+    with A show ?thesis by (auto simp add: length_mk_composable0_even)
+  next
+    case False
+    with A show ?thesis by (auto simp add: length_mk_composable0_odd)
+  qed
+qed
+
+
+subsection \<open>Properties of function fetch with respect to function mk\_composable0\<close>
+
+(* ----------------------------------------------- *)
+(* Fetching instructions from  (mk_composable0 tm)         *)
+(* ----------------------------------------------- *)
+
+lemma fetch_mk_composable0_Bk_too_short_Suc:
+  assumes "b = Bk" and "length tm \<le> 2*s"
+  shows "fetch (mk_composable0 tm) (Suc s) b = (Nop, 0::nat)"
+proof (rule mk_composable0.cases[of tm])
+  assume "tm = []"
+  then have "length (mk_composable0 tm) = 2" by auto
+  with \<open>tm = []\<close> have "(mk_composable0 tm) = [(Nop,0),(Nop,0)]" by auto
+  show "fetch (mk_composable0 tm) (Suc s) b = (Nop, 0)"
+  proof (cases s)
+    assume "s=0"
+    with \<open>length (mk_composable0 tm) = 2\<close> 
+    have "fetch (mk_composable0 tm) (Suc s) Bk = ((mk_composable0 tm) ! (2*s))"
+      by (auto)
+    also with \<open>s=0\<close> and  \<open>(mk_composable0 tm) = [(Nop,0),(Nop,0)]\<close> have "... = (Nop, 0::nat)" by auto
+    finally have "fetch (mk_composable0 tm) (Suc s) Bk = (Nop, 0::nat)" by auto
+    with \<open>b = Bk\<close> show ?thesis by auto
+  next
+    case (Suc nat)
+    then have "s = Suc nat" .
+    with \<open>length (mk_composable0 tm) = 2\<close> have "length (mk_composable0 tm) \<le> 2*s" by auto
+    with \<open>b = Bk\<close> show ?thesis by (auto)
+  qed
+next
+  fix i1
+  assume "tm = [i1]"
+  then have "mk_composable0 tm = fix_jumps 1 [i1,(Nop,0)]" by auto
+  moreover have "length (fix_jumps 1 [i1,(Nop,0)]) = length [i1] +1" using fix_jumps_len by auto
+  ultimately  have "length (mk_composable0 tm) = 2" using \<open>tm = [i1]\<close> by auto
+  show "fetch (mk_composable0 tm) (Suc s) b = (Nop, 0)"
+  proof (cases s)
+    case 0
+    with \<open>tm = [i1]\<close> and \<open>length tm \<le> 2*s\<close> have False by auto
+    then show ?thesis by auto
+  next
+    case (Suc nat)
+    then have "s = Suc nat" .
+    with \<open>length (mk_composable0 tm) = 2\<close> have "length (mk_composable0 tm) \<le> 2*s" by arith
+    with \<open>b = Bk\<close> show ?thesis by (auto)
+  qed
+next
+  fix i1 i2 ins
+  assume "tm = i1 # i2 # ins"
+  show "fetch (mk_composable0 tm) (Suc s) b = (Nop, 0)"
+  proof (cases "is_even (2 + length ins)")
+    case True
+    then have "is_even (2 + length ins)" .
+    with \<open>tm = i1 # i2 # ins\<close> have "mk_composable0 tm = fix_jumps ((2 + length ins) div 2) tm" by auto
+    moreover have "length(fix_jumps ((2 + length ins) div 2) tm) = length tm" using fix_jumps_len by auto
+    ultimately have "length (mk_composable0 tm) = length tm" by auto  
+    with \<open>length tm \<le> 2*s\<close> have "length (mk_composable0 tm) \<le> 2*s" by auto
+    with \<open>b = Bk\<close> show ?thesis by auto
+  next
+    case False
+    then have "\<not>is_even (2 + length ins)" .
+    with \<open>tm = i1 # i2 # ins\<close>
+    have "mk_composable0 tm = fix_jumps (((2 + length ins) div 2)+1) (tm@[(Nop,0)])" by auto
+    moreover
+    have "length(fix_jumps (((2 + length ins) div 2)+1) (tm@[(Nop,0)])) = length (tm@[(Nop,0)])" using fix_jumps_len by auto
+    ultimately have "length (mk_composable0 tm) = length tm +1" by auto  
+    moreover from \<open>\<not>is_even (2 + length ins)\<close> and  \<open>tm = i1 # i2 # ins\<close> have "\<not>is_even (length tm)" by auto
+    with \<open>length tm \<le> 2*s\<close> have "length tm +1 \<le> 2*s" by arith
+    with \<open>length (mk_composable0 tm) = length tm +1\<close> have "length (mk_composable0 tm) \<le> 2*s" by auto
+    with \<open>b = Bk\<close> show ?thesis by auto
+  qed
+qed
+
+
+lemma fetch_mk_composable0_Oc_too_short_Suc:
+  assumes "b = Oc" and "length tm \<le> 2*s+1"
+  shows "fetch (mk_composable0 tm) (Suc s) b = (Nop, 0::nat)"
+proof (rule mk_composable0.cases[of tm])
+  assume "tm = []"
+  then have "length (mk_composable0 tm) = 2" by auto
+  with \<open>tm = []\<close> have "(mk_composable0 tm) = [(Nop,0),(Nop,0)]" by auto
+  show "fetch (mk_composable0 tm) (Suc s) b = (Nop, 0)"
+  proof (cases s)
+    assume "s=0"
+    with \<open>length (mk_composable0 tm) = 2\<close> 
+    have "fetch (mk_composable0 tm) (Suc s) Oc = ((mk_composable0 tm) ! (2*s+1))"
+      by (auto)
+    also with \<open>s=0\<close> and  \<open>(mk_composable0 tm) = [(Nop,0),(Nop,0)]\<close> have "... = (Nop, 0::nat)" by auto
+    finally have "fetch (mk_composable0 tm) (Suc s) Oc = (Nop, 0::nat)" by auto
+    with \<open>b = Oc\<close> show ?thesis by auto
+  next
+    case (Suc nat)
+    then have "s = Suc nat" .
+    with \<open>length (mk_composable0 tm) = 2\<close> have "length (mk_composable0 tm) \<le> 2*s" by auto
+    with \<open>b = Oc\<close> show ?thesis by (auto)
+  qed
+next
+  fix i1
+  assume "tm = [i1]"
+  then have "mk_composable0 tm = fix_jumps 1 [i1,(Nop,0)]" by auto
+  moreover have "length (fix_jumps 1 [i1,(Nop,0)]) = length [i1] +1" using fix_jumps_len by auto
+  ultimately  have "length (mk_composable0 tm) = 2" using \<open>tm = [i1]\<close> by auto
+  show "fetch (mk_composable0 tm) (Suc s) b = (Nop, 0)"
+  proof (cases s)
+    case 0
+    then have "s=0" .
+    with \<open>length (mk_composable0 tm) = 2\<close> have "fetch (mk_composable0 tm) (Suc s) Oc = ((mk_composable0 tm) ! 1)"
+      by (auto)
+    also with \<open>mk_composable0 tm = fix_jumps 1 [i1,(Nop,0)]\<close> have "... = ((fix_jumps 1 [i1,(Nop,0)]) ! 1)"
+      by auto
+    also have "... = (Nop, 0)" by (cases "(snd i1) \<le> 1")(auto)
+    finally have "fetch (mk_composable0 tm) (Suc s) Oc = (Nop, 0)" by auto
+    with \<open>b = Oc\<close> show ?thesis by auto
+  next
+    case (Suc nat)
+    then have "s = Suc nat" .
+    with \<open>length (mk_composable0 tm) = 2\<close> have "length (mk_composable0 tm) \<le> 2*s+1" by arith
+    with \<open>b = Oc\<close> show ?thesis by (auto)
+  qed
+next
+  fix i1 i2 ins
+  assume "tm = i1 # i2 # ins"
+  show "fetch (mk_composable0 tm) (Suc s) b = (Nop, 0)"
+  proof (cases "is_even (2 + length ins)")
+    case True
+    then have "is_even (2 + length ins)" .
+    with \<open>tm = i1 # i2 # ins\<close> have "mk_composable0 tm = fix_jumps ((2 + length ins) div 2) tm" by auto
+    moreover have "length(fix_jumps ((2 + length ins) div 2) tm) = length tm" using fix_jumps_len by auto
+    ultimately have "length (mk_composable0 tm) = length tm" by auto  
+    with \<open>length tm \<le> 2*s+1\<close> have "length (mk_composable0 tm) \<le> 2*s+1" by auto
+    with \<open>b = Oc\<close> show ?thesis by auto
+  next
+    case False
+    then have "\<not>is_even (2 + length ins)" .
+    with \<open>tm = i1 # i2 # ins\<close>
+    have F1: "mk_composable0 tm = fix_jumps (((2 + length ins) div 2)+1) (tm@[(Nop,0)])" by auto
+    moreover
+    have "length(fix_jumps (((2 + length ins) div 2)+1) (tm@[(Nop,0)])) = length (tm@[(Nop,0)])"
+      using fix_jumps_len by auto
+    ultimately have "length (mk_composable0 tm) = length tm +1" by auto
+
+    moreover from \<open>\<not>is_even (2 + length ins)\<close> and  \<open>tm = i1 # i2 # ins\<close>
+    have "\<not>is_even (length tm)" by auto
+
+    from \<open>length tm \<le> 2*s+1\<close> have  "(length tm) = (2*s+1) \<or> (length tm) < 2*s+1" by auto
+    then show ?thesis
+    proof
+      assume "length tm = 2 * s + 1"
+      from \<open>length tm = 2 * s + 1\<close> and \<open>length (mk_composable0 tm) = length tm +1\<close> have "length (mk_composable0 tm) = 2*s + 2" by auto
+      from \<open>length tm = 2 * s + 1\<close> and \<open>length (mk_composable0 tm) = length tm +1\<close> have "length (mk_composable0 tm) > 2*s+1" by arith
+      with \<open>b = Oc\<close> have "fetch (mk_composable0 tm) (Suc s) b = ((mk_composable0 tm) ! (2*s+1))" by (auto )
+      also with \<open>length (mk_composable0 tm) = 2 * s + 2\<close> have "... = (mk_composable0 tm) ! (length (mk_composable0 tm)-1)" by auto
+      also with F1 have "... = (fix_jumps (((2 + length ins) div 2)+1) (tm@[(Nop,0)])) ! (length (mk_composable0 tm)-1)" by auto
+      also have "... = (Nop, 0)"
+      proof (rule fix_jumps_nth_no_fix)
+        show "snd (Nop, 0) \<le> (2 + length ins) div 2 + 1" by auto
+      next
+        from \<open>length (mk_composable0 tm) = length tm +1\<close> show "length (mk_composable0 tm) - 1 < length (tm @ [(Nop, 0)])" by auto
+      next 
+        from  \<open>length (mk_composable0 tm) = length tm +1\<close> show "(tm @ [(Nop, 0)]) ! (length (mk_composable0 tm) - 1) = (Nop, 0)" by auto
+      qed
+      finally show "fetch (mk_composable0 tm) (Suc s) b =  (Nop, 0)" by auto
+    next
+      assume "length tm < 2 * s + 1 "
+      with \<open>\<not>is_even (length tm)\<close> have "length tm +1 \<le> 2 * s + 1" by auto
+      with \<open>length (mk_composable0 tm) = length tm +1\<close> have "length (mk_composable0 tm)  \<le> 2 * s + 1" by auto
+      with \<open>b = Oc\<close> show "fetch (mk_composable0 tm) (Suc s) b = (Nop, 0::nat)"
+        by (auto)
+    qed
+  qed
+qed
+
+lemma nth_append': "n < length xs \<Longrightarrow> (xs @ ys) ! n = xs ! n" by (auto simp add: nth_append)
+
+lemma fetch_mk_composable0_Bk_Suc_no_fix:
+  assumes "b = Bk"
+    and "2*s < length tm"
+    and "fetch tm (Suc s) b = (a, s')"
+    and "s' \<le> length (mk_composable0 tm) div 2"
+  shows "fetch (mk_composable0 tm) (Suc s) b = fetch tm (Suc s) b"
+proof (rule mk_composable0.cases[of tm])
+  assume "tm = []"
+  with \<open>length tm > 2*s\<close> show ?thesis by auto
+next
+  fix i1
+  assume "tm = [i1]"
+  have "fetch (mk_composable0 tm) (Suc s) b = (mk_composable0 tm)!(2*s)"
+    using \<open>tm = [i1]\<close> assms by auto
+  also have "(mk_composable0 tm)!(2*s) = (a, s')"
+  proof -
+    from \<open>tm = [i1]\<close> have "length (mk_composable0 tm) = 2" by auto
+    have "(mk_composable0 [i1])!(2*s) = (fix_jumps 1 [i1,(Nop,0)])!(2*s)" by auto
+    also have "... = (a, s')"
+    proof (rule fix_jumps_nth_no_fix)
+      from assms and  \<open>tm = [i1]\<close> show "2 * s < length [i1, (Nop, 0)]" by auto
+    next
+      from assms and  \<open>tm = [i1]\<close> show "[i1, (Nop, 0)] ! (2 * s) = (a, s')" by auto
+    next
+      from assms and  \<open>tm = [i1]\<close> and \<open>length (mk_composable0 tm) = 2\<close> show "snd (a, s') \<le> 1" by auto
+    qed
+    finally have "(mk_composable0 [i1])!(2*s) = (a, s')" by auto
+    with  \<open>tm = [i1]\<close> show ?thesis by auto
+  qed
+  finally have "fetch (mk_composable0 tm) (Suc s) b = (a, s')" by auto
+  with assms show ?thesis by auto
+next
+  fix i1 i2 ins
+  assume "tm = i1 # i2 # ins"
+  have "fetch (mk_composable0 tm) (Suc s) b = (mk_composable0 tm)!(2*s)"
+  proof -
+    have "\<not> length (mk_composable0 tm) \<le> 2 * Suc s - 2"
+      by (metis (no_types) add_diff_cancel_left' assms(2) le_trans length_tm_le_mk_composable0 mult_Suc_right not_less)
+    then show ?thesis
+      by (simp add: assms(1))
+  qed
+    
+    also have "(mk_composable0 tm)!(2*s) = (a, s')"
+  proof (cases "is_even (length tm)")
+    case True
+    then have "is_even (length tm)" .
+    with \<open>tm = i1 # i2 # ins\<close> have  "is_even (length (i1 # i2 # ins))" by auto
+    then have "length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)" by (rule length_mk_composable0_gt2_even)
+
+    from \<open>is_even (length (i1 # i2 # ins))\<close>
+    have "(mk_composable0 (i1 # i2 # ins))!(2*s) = (fix_jumps ((length (i1 # i2 # ins)) div 2) (i1#i2#ins))!(2*s)" by auto
+    also have "... = (a, s')"
+    proof (rule fix_jumps_nth_no_fix)
+      from assms and  \<open>tm = i1 # i2 # ins\<close> show "2 * s < length (i1 # i2 # ins)" by auto
+    next
+      from assms and  \<open>tm = i1 # i2 # ins\<close> show "(i1 # i2 # ins) ! (2 * s) = (a, s')" by auto
+    next
+      from assms and  \<open>tm = i1 # i2 # ins\<close> and \<open>length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)\<close>
+      show "snd (a, s') \<le> length (i1 # i2 # ins) div 2" by auto
+    qed
+    finally have "(mk_composable0 (i1 # i2 # ins))!(2*s) = (a, s')" by auto
+    with \<open>tm = i1 # i2 # ins\<close> show ?thesis by auto
+  next
+    case False
+    then have "\<not>is_even (length tm)" .
+    with \<open>tm = i1 # i2 # ins\<close> have  "\<not>is_even (length (i1 # i2 # ins))" by auto
+    then have "length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins) +1" by (rule length_mk_composable0_gt2_odd)
+
+    from \<open>\<not>is_even (length (i1 # i2 # ins))\<close>
+    have "(mk_composable0 (i1 # i2 # ins))!(2*s) = (fix_jumps (((length (i1 # i2 # ins)) div 2)+1) ((i1#i2#ins)@[(Nop,0)]))!(2*s)" by auto
+    also have "... = (a, s')"
+    proof (rule fix_jumps_nth_no_fix)
+      from assms and \<open>tm = i1 # i2 # ins\<close> show "2 * s < length ((i1 # i2 # ins) @ [(Nop, 0)])" by auto
+    next
+      have "((i1 # i2 # ins)@ [(Nop, 0)]) ! (2 * s) = ((i1 # i2 # ins)) ! (2 * s)"
+      proof (rule nth_append')
+        from assms and \<open>tm = i1 # i2 # ins\<close> show "2 * s < length (i1 # i2 # ins)" by auto
+      qed
+      also from assms and \<open>tm = i1 # i2 # ins\<close> have "((i1 # i2 # ins)) ! (2 * s) = (a, s')" by auto
+      finally show "((i1 # i2 # ins)@ [(Nop, 0)]) ! (2 * s) = (a, s')" by auto
+    next
+      from assms and  \<open>tm = i1 # i2 # ins\<close> and \<open>length (mk_composable0 (i1 # i2 # ins)) = length ((i1#i2#ins)) + 1\<close>
+      show "snd (a, s') \<le> length (i1 # i2 # ins) div 2 + 1" by auto 
+    qed
+    finally have "(mk_composable0 (i1 # i2 # ins))!(2*s) = (a, s')" by auto
+    with \<open>tm = i1 # i2 # ins\<close> show ?thesis by auto
+  qed
+  finally have "fetch (mk_composable0 tm) (Suc s) b = (a, s')" by auto
+  with assms show ?thesis by auto
+qed
+
+lemma fetch_mk_composable0_Bk_Suc_fix:
+assumes "b = Bk"
+    and "2*s < length tm"
+    and "fetch tm (Suc s) b = (a, s')"
+    and "length (mk_composable0 tm) div 2 < s'"
+shows "fetch (mk_composable0 tm) (Suc s) b = (a, 0)"
+proof (rule mk_composable0.cases[of tm])
+  assume "tm = []"
+  with \<open>length tm > 2*s\<close> show ?thesis by auto
+next
+  fix i1
+  assume "tm = [i1]"
+  have "fetch (mk_composable0 tm) (Suc s) b = (mk_composable0 tm)!(2*s)"
+    using \<open>tm = [i1]\<close> assms(1) assms(2) by auto
+  also have "(mk_composable0 tm)!(2*s) = (a, 0)"
+  proof -
+    from \<open>tm = [i1]\<close> have "length (mk_composable0 tm) = 2" by auto
+    have "(mk_composable0 [i1])!(2*s) = (fix_jumps 1 [i1,(Nop,0)])!(2*s)" by auto
+    also have "... = (fst(a,s'), 0)"
+    proof (rule fix_jumps_nth_fix)
+      from assms and  \<open>tm = [i1]\<close> show "2 * s < length [i1, (Nop, 0)]" by auto
+    next
+      from assms and  \<open>tm = [i1]\<close> show "[i1, (Nop, 0)] ! (2 * s) = (a, s')" by auto
+    next
+      from assms and  \<open>tm = [i1]\<close> and \<open>length (mk_composable0 tm) = 2\<close> show "\<not>snd (a, s') \<le> 1" by auto
+    qed
+    finally have "(mk_composable0 [i1])!(2*s) = (a, 0)" by auto
+    with  \<open>tm = [i1]\<close> show ?thesis by auto
+  qed
+  finally have "fetch (mk_composable0 tm) (Suc s) b = (a, 0)" by auto
+  with assms show ?thesis by auto
+next
+  fix i1 i2 ins
+  assume "tm = i1 # i2 # ins"
+  from assms have "fetch tm (Suc s) b = (tm ! (2*s))"
+    by (auto)
+  have "fetch (mk_composable0 tm) (Suc s) b = (mk_composable0 tm)!(2*s)"
+    using assms(1) assms(3) assms(4) le_trans length_tm_le_mk_composable0
+    by fastforce
+  also have "(mk_composable0 tm)!(2*s) = (a, 0)"
+  proof (cases "is_even (length tm)")
+    case True
+    then have "is_even (length tm)" .
+    with \<open>tm = i1 # i2 # ins\<close> have  "is_even (length (i1 # i2 # ins))" by auto
+    then have "length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)" by (rule length_mk_composable0_gt2_even)
+
+    from \<open>is_even (length (i1 # i2 # ins))\<close>
+    have "(mk_composable0 (i1 # i2 # ins))!(2*s) = (fix_jumps ((length (i1 # i2 # ins)) div 2) (i1#i2#ins))!(2*s)" by auto
+    also have "... = (fst(a,s'),0)"
+
+    proof (rule fix_jumps_nth_fix)
+      from assms and  \<open>tm = i1 # i2 # ins\<close> show "2 * s < length (i1 # i2 # ins)" by auto
+    next
+      from assms and  \<open>tm = i1 # i2 # ins\<close> show "(i1 # i2 # ins) ! (2 * s) = (a, s')" by auto
+    next
+      from assms and  \<open>tm = i1 # i2 # ins\<close> and \<open>length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)\<close>
+      show "\<not>snd (a, s') \<le> length (i1 # i2 # ins) div 2" by auto
+    qed
+    finally have "(mk_composable0 (i1 # i2 # ins))!(2*s) = (fst(a,s'),0)" by auto
+    then have "(mk_composable0 (i1 # i2 # ins))!(2*s) = (a,0)" by auto
+    with \<open>tm = i1 # i2 # ins\<close> show ?thesis by auto
+  next
+    case False
+    then have "\<not>is_even (length tm)" .
+    with \<open>tm = i1 # i2 # ins\<close> have  "\<not>is_even (length (i1 # i2 # ins))" by auto
+    then have "length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins) +1" by (rule length_mk_composable0_gt2_odd)
+    from \<open>\<not>is_even (length (i1 # i2 # ins))\<close>
+    have "(mk_composable0 (i1 # i2 # ins))!(2*s) = (fix_jumps (((length (i1 # i2 # ins)) div 2)+1) ((i1#i2#ins)@[(Nop,0)]))!(2*s)" by auto
+    also have "... = (fst(a,s'), 0)"
+    proof (rule fix_jumps_nth_fix)
+      from assms and \<open>tm = i1 # i2 # ins\<close> show "2 * s < length ((i1 # i2 # ins) @ [(Nop, 0)])" by auto
+    next
+      have "((i1 # i2 # ins)@ [(Nop, 0)]) ! (2 * s) = ((i1 # i2 # ins)) ! (2 * s)"
+      proof (rule nth_append')
+        from assms and \<open>tm = i1 # i2 # ins\<close> show "2 * s < length (i1 # i2 # ins)" by auto
+      qed
+      also from assms and \<open>tm = i1 # i2 # ins\<close> have "((i1 # i2 # ins)) ! (2 * s) = (a, s')" by auto
+      finally show "((i1 # i2 # ins)@ [(Nop, 0)]) ! (2 * s) = (a, s')" by auto
+    next
+      from assms and \<open>tm = i1 # i2 # ins\<close> and \<open>length (mk_composable0 (i1 # i2 # ins)) = length ((i1#i2#ins)) + 1\<close>
+      have "s' > (length (i1 # i2 # ins) + 1) div 2" by auto
+      with \<open>\<not>is_even (length (i1 # i2 # ins))\<close> have "s' > length (i1 # i2 # ins) div 2 + 1" by arith
+      then show "\<not> snd (a, s') \<le> length (i1 # i2 # ins) div 2 + 1" by auto 
+    qed
+    finally have "(mk_composable0 (i1 # i2 # ins))!(2*s) = (a, 0)" by auto
+    with \<open>tm = i1 # i2 # ins\<close> show ?thesis by auto
+  qed
+  finally have "fetch (mk_composable0 tm) (Suc s) b = (a, 0)" by auto
+  with assms show ?thesis by auto
+qed
+
+lemma fetch_mk_composable0_Oc_Suc_no_fix:
+  assumes "b = Oc"
+    and "2*s+1 < length tm"
+    and "fetch tm (Suc s) b = (a, s')"
+
+    and "s' \<le> length (mk_composable0 tm) div 2"
+  shows "fetch (mk_composable0 tm) (Suc s) b = fetch tm (Suc s) b"
+proof (rule mk_composable0.cases[of tm])
+  assume "tm = []"
+  with \<open>2*s+1 < length tm\<close> show ?thesis by auto
+next
+  fix i1
+  assume "tm = [i1]"
+  have "fetch (mk_composable0 tm) (Suc s) b = (mk_composable0 tm)!(2*s+1)"
+    using \<open>tm = [i1]\<close> assms(2) by auto
+  also have "(mk_composable0 tm)!(2*s+1) = (a, s')"
+  proof -
+    from \<open>tm = [i1]\<close> have "length (mk_composable0 tm) = 2" by auto
+    have "(mk_composable0 [i1])!(2*s+1) = (fix_jumps 1 [i1,(Nop,0)])!(2*s+1)" by auto
+    also have "... = (a, s')"
+    proof (rule fix_jumps_nth_no_fix)
+      from assms and  \<open>tm = [i1]\<close> show "2 * s  +1 < length [i1, (Nop, 0)]" by auto
+    next
+      from assms and  \<open>tm = [i1]\<close> show "[i1, (Nop, 0)] ! (2 * s +1) = (a, s')" by auto
+    next
+      from assms and  \<open>tm = [i1]\<close> and \<open>length (mk_composable0 tm) = 2\<close> show "snd (a, s') \<le> 1" by auto
+    qed
+    finally have "(mk_composable0 [i1])!(2*s+1) = (a, s')" by auto
+    with  \<open>tm = [i1]\<close> show ?thesis by auto
+  qed
+  finally have "fetch (mk_composable0 tm) (Suc s) b = (a, s')" by auto
+  with assms show ?thesis by auto
+next
+  fix i1 i2 ins
+  assume "tm = i1 # i2 # ins"
+  have "fetch (mk_composable0 tm) (Suc s) b = (mk_composable0 tm)!(2*s+1)"
+  proof -
+    have "\<not> length (mk_composable0 tm) \<le> 2 * s + 1"
+      by (meson assms(2) le_trans length_tm_le_mk_composable0 not_less)
+    then show ?thesis
+      by (simp add: assms(1))
+  qed
+  also have "(mk_composable0 tm)!(2*s+1) = (a, s')"
+  proof (cases "is_even (length tm)")
+    case True
+    then have "is_even (length tm)" .
+    with \<open>tm = i1 # i2 # ins\<close> have  "is_even (length (i1 # i2 # ins))" by auto
+    then have "length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)" by (rule length_mk_composable0_gt2_even)
+
+    from \<open>is_even (length (i1 # i2 # ins))\<close>
+    have "(mk_composable0 (i1 # i2 # ins))!(2*s+1) = (fix_jumps ((length (i1 # i2 # ins)) div 2) (i1#i2#ins))!(2*s+1)" by auto
+    also have "... = (a, s')"
+    proof (rule fix_jumps_nth_no_fix)
+      from assms and  \<open>tm = i1 # i2 # ins\<close> show "2 * s+1 < length (i1 # i2 # ins)" by auto
+    next
+      from assms and  \<open>tm = i1 # i2 # ins\<close> show "(i1 # i2 # ins) ! (2 * s+1) = (a, s')" by auto
+    next
+      from assms and  \<open>tm = i1 # i2 # ins\<close> and \<open>length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)\<close>
+      show "snd (a, s') \<le> length (i1 # i2 # ins) div 2" by auto
+    qed
+    finally have "(mk_composable0 (i1 # i2 # ins))!(2*s+1) = (a, s')" by auto
+    with \<open>tm = i1 # i2 # ins\<close> show ?thesis by auto
+  next
+    case False
+    then have "\<not>is_even (length tm)" .
+    with \<open>tm = i1 # i2 # ins\<close> have  "\<not>is_even (length (i1 # i2 # ins))" by auto
+    then have "length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins) +1" by (rule length_mk_composable0_gt2_odd)
+
+    from \<open>\<not>is_even (length (i1 # i2 # ins))\<close>
+    have "(mk_composable0 (i1 # i2 # ins))!(2*s+1) = (fix_jumps (((length (i1 # i2 # ins)) div 2)+1) ((i1#i2#ins)@[(Nop,0)]))!(2*s+1)" by auto
+    also have "... = (a, s')"
+    proof (rule fix_jumps_nth_no_fix)
+      from assms and \<open>tm = i1 # i2 # ins\<close> show "2 * s +1< length ((i1 # i2 # ins) @ [(Nop, 0)])" by auto
+    next
+      have "((i1 # i2 # ins)@ [(Nop, 0)]) ! (2 * s+1) = ((i1 # i2 # ins)) ! (2 * s+1)"
+      proof (rule nth_append')
+        from assms and \<open>tm = i1 # i2 # ins\<close> show "2 * s+1 < length (i1 # i2 # ins)" by auto
+      qed
+      also from assms and \<open>tm = i1 # i2 # ins\<close> have "((i1 # i2 # ins)) ! (2 * s+1) = (a, s')" by auto
+      finally show "((i1 # i2 # ins)@ [(Nop, 0)]) ! (2 * s+1) = (a, s')" by auto
+    next
+      from assms and  \<open>tm = i1 # i2 # ins\<close> and \<open>length (mk_composable0 (i1 # i2 # ins)) = length ((i1#i2#ins)) + 1\<close>
+      show "snd (a, s') \<le> length (i1 # i2 # ins) div 2 + 1" by auto 
+    qed
+    finally have "(mk_composable0 (i1 # i2 # ins))!(2*s+1) = (a, s')" by auto
+    with \<open>tm = i1 # i2 # ins\<close> show ?thesis by auto
+  qed
+  finally have "fetch (mk_composable0 tm) (Suc s) b = (a, s')" by auto
+  with assms show ?thesis by auto
+qed
+
+
+lemma fetch_mk_composable0_Oc_Suc_fix:
+assumes "b = Oc"
+    and "2*s+1 < length tm"
+    and "fetch tm (Suc s) b = (a, s')"
+
+    and "length (mk_composable0 tm) div 2 < s'"
+shows "fetch (mk_composable0 tm) (Suc s) b = (a, 0)"
+proof (rule mk_composable0.cases[of tm])
+  assume "tm = []"
+  with \<open>length tm > 2*s+1\<close> show ?thesis by auto
+next
+  fix i1
+  assume "tm = [i1]"
+  have "fetch (mk_composable0 tm) (Suc s) b = (mk_composable0 tm)!(2*s+1)"
+    using \<open>tm = [i1]\<close> assms(2) by auto
+  also have "(mk_composable0 tm)!(2*s+1) = (a, 0)"
+  proof -
+    from \<open>tm = [i1]\<close> have "length (mk_composable0 tm) = 2" by auto
+    have "(mk_composable0 [i1])!(2*s+1) = (fix_jumps 1 [i1,(Nop,0)])!(2*s+1)" by auto
+    also have "... = (fst(a,s'), 0)"
+    proof (rule fix_jumps_nth_fix)
+      from assms and  \<open>tm = [i1]\<close> show "2 * s+1 < length [i1, (Nop, 0)]" by auto
+    next
+      from assms and  \<open>tm = [i1]\<close> show "[i1, (Nop, 0)] ! (2 * s+1) = (a, s')" by auto
+    next
+      from assms and  \<open>tm = [i1]\<close> and \<open>length (mk_composable0 tm) = 2\<close> show "\<not>snd (a, s') \<le> 1" by auto
+    qed
+    finally have "(mk_composable0 [i1])!(2*s+1) = (a, 0)" by auto
+    with  \<open>tm = [i1]\<close> show ?thesis by auto
+  qed
+  finally have "fetch (mk_composable0 tm) (Suc s) b = (a, 0)" by auto
+  with assms show ?thesis by auto
+next
+  fix i1 i2 ins
+  assume "tm = i1 # i2 # ins"
+  from assms have "fetch tm (Suc s) b = (tm ! (2*s+1))"
+    by (auto)
+  have "fetch (mk_composable0 tm) (Suc s) b = (mk_composable0 tm)!(2*s+1)"
+  proof -
+    have "\<not> length (mk_composable0 tm) \<le> 2 * s + 1"
+      by (meson assms(2) le_trans length_tm_le_mk_composable0 not_less)
+    then show ?thesis
+      by (simp add: assms(1))
+  qed
+  also have "(mk_composable0 tm)!(2*s+1) = (a, 0)"
+  proof (cases "is_even (length tm)")
+    case True
+    then have "is_even (length tm)" .
+    with \<open>tm = i1 # i2 # ins\<close> have  "is_even (length (i1 # i2 # ins))" by auto
+    then have "length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)" by (rule length_mk_composable0_gt2_even)
+
+    from \<open>is_even (length (i1 # i2 # ins))\<close>
+    have "(mk_composable0 (i1 # i2 # ins))!(2*s+1) = (fix_jumps ((length (i1 # i2 # ins)) div 2) (i1#i2#ins))!(2*s+1)" by auto
+    also have "... = (fst(a,s'),0)"
+
+    proof (rule fix_jumps_nth_fix)
+      from assms and  \<open>tm = i1 # i2 # ins\<close> show "2 * s +1 < length (i1 # i2 # ins)" by auto
+    next
+      from assms and  \<open>tm = i1 # i2 # ins\<close> show "(i1 # i2 # ins) ! (2 * s +1) = (a, s')" by auto
+    next
+      from assms and  \<open>tm = i1 # i2 # ins\<close> and \<open>length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins)\<close>
+      show "\<not>snd (a, s') \<le> length (i1 # i2 # ins) div 2" by auto
+    qed
+    finally have "(mk_composable0 (i1 # i2 # ins))!(2*s+1) = (fst(a,s'),0)" by auto
+    then have "(mk_composable0 (i1 # i2 # ins))!(2*s+1) = (a,0)" by auto
+    with \<open>tm = i1 # i2 # ins\<close> show ?thesis by auto
+  next
+    case False
+    then have "\<not>is_even (length tm)" .
+    with \<open>tm = i1 # i2 # ins\<close> have  "\<not>is_even (length (i1 # i2 # ins))" by auto
+    then have "length (mk_composable0 (i1 # i2 # ins)) = length (i1#i2#ins) +1" by (rule length_mk_composable0_gt2_odd)
+    from \<open>\<not>is_even (length (i1 # i2 # ins))\<close>
+    have "(mk_composable0 (i1 # i2 # ins))!(2*s+1) = (fix_jumps (((length (i1 # i2 # ins)) div 2)+1) ((i1#i2#ins)@[(Nop,0)]))!(2*s+1)" by auto
+    also have "... = (fst(a,s'), 0)"
+    proof (rule fix_jumps_nth_fix)
+      from assms and \<open>tm = i1 # i2 # ins\<close> show "2 * s+1 < length ((i1 # i2 # ins) @ [(Nop, 0)])" by auto
+    next
+      have "((i1 # i2 # ins)@ [(Nop, 0)]) ! (2 * s +1) = ((i1 # i2 # ins)) ! (2 * s +1)"
+      proof (rule nth_append')
+        from assms and \<open>tm = i1 # i2 # ins\<close> show "2 * s +1 < length (i1 # i2 # ins)" by auto
+      qed
+      also from assms and \<open>tm = i1 # i2 # ins\<close> have "((i1 # i2 # ins)) ! (2 * s +1) = (a, s')" by auto
+      finally show "((i1 # i2 # ins)@ [(Nop, 0)]) ! (2 * s +1) = (a, s')" by auto
+    next
+      from assms and \<open>tm = i1 # i2 # ins\<close> and \<open>length (mk_composable0 (i1 # i2 # ins)) = length ((i1#i2#ins)) + 1\<close>
+      have "s' > (length (i1 # i2 # ins) + 1) div 2" by auto
+      with \<open>\<not>is_even (length (i1 # i2 # ins))\<close> have "s' > length (i1 # i2 # ins) div 2 + 1" by arith
+      then show "\<not> snd (a, s') \<le> length (i1 # i2 # ins) div 2 + 1" by auto 
+    qed
+    finally have "(mk_composable0 (i1 # i2 # ins))!(2*s+1) = (a, 0)" by auto
+    with \<open>tm = i1 # i2 # ins\<close> show ?thesis by auto
+  qed
+  finally have "fetch (mk_composable0 tm) (Suc s) b = (a, 0)" by auto
+  with assms show ?thesis by auto
+qed
+
+
+subsection \<open>Properties of function step0 with respect to function mk\_composable0\<close>
+
+lemma length_mk_composable0_div2_lt_imp_length_tm_le_times2:
+  assumes "length (mk_composable0 tm) div 2 < s'"
+    and "s' = Suc s2"
+  shows "length tm \<le> 2 * s2"
+proof (cases "length tm")
+  case 0
+  then show ?thesis by auto
+next
+  case (Suc nat)
+  then have "length tm = Suc nat" .
+  then show ?thesis
+  proof (cases  "is_even (length tm)")
+    case True
+    then have "is_even (length tm)" .
+
+    from  \<open>length (mk_composable0 tm) div 2 < s'\<close>
+      and \<open>s' = Suc s2\<close> have "length (mk_composable0 tm) div 2 < Suc s2" by auto
+    moreover from \<open>is_even (length tm)\<close> and \<open>length tm = Suc nat\<close>
+    have "length (mk_composable0 tm) = length tm"
+      by (auto simp add: length_mk_composable0_even)
+    ultimately have "length tm div 2 < Suc s2" by auto
+    with \<open>is_even (length tm)\<close> show ?thesis by (auto simp add: even_le_div2_imp_le_times_2)
+  next
+    case False
+    then have "\<not> is_even (length tm)" .
+    from  \<open>length (mk_composable0 tm) div 2 < s'\<close> and \<open>s' = Suc s2\<close>
+    have "length (mk_composable0 tm) div 2 < Suc s2" by auto
+    moreover from \<open>\<not>is_even (length tm)\<close>
+      and \<open>length tm = Suc nat\<close> have "length (mk_composable0 tm) = length tm +1"
+      by (auto simp add: length_mk_composable0_odd)
+    ultimately have "(length tm +1) div 2 < Suc s2" by auto
+    with \<open>\<not>is_even (length tm)\<close> show ?thesis by (auto simp add: odd_le_div2_imp_le_times_2)
+  qed
+qed
+
+lemma jump_out_of_pgm_is_final_next_step:
+  assumes "step0 (s, l, r) tm = (s', update a1 (l, r))"
+    and "s' = Suc s2" and "length (mk_composable0 tm) div 2 < s'"
+  shows "step0 (step0 (s, l, r) tm) tm = (0, snd (step0 (s, l, r) tm))"
+proof -
+  from \<open>length (mk_composable0 tm) div 2 < s'\<close> and \<open>s' = Suc s2\<close> have "length tm \<le> 2 * s2"
+    by (rule length_mk_composable0_div2_lt_imp_length_tm_le_times2)
+  with assms have  "step0 (step0 (s, l, r) tm) tm = step0 (s', update a1 (l, r)) tm" by auto
+  also have "... = (0::nat, update a1 (l, r))"
+  proof (cases "update a1 (l, r)")
+    fix l2 r2
+    assume "update a1 (l, r) = (l2, r2)"
+    then show ?thesis 
+    proof (cases "read r2")
+      case Bk
+      then have "read r2 = Bk" .
+      moreover with \<open>length tm \<le> 2 * s2\<close> and \<open>s' = Suc s2\<close> fetch.simps
+      have "fetch tm s' Bk = (Nop, 0::nat)" by auto
+      ultimately show ?thesis by (auto simp add: \<open>update a1 (l, r) = (l2, r2)\<close> )
+    next
+      case Oc
+      then have "read r2 = Oc" .
+      moreover with \<open>length tm \<le> 2 * s2\<close> and \<open>s' = Suc s2\<close> fetch.simps
+      have "fetch tm s' Oc = (Nop, 0::nat)" by auto
+      ultimately show ?thesis by (auto simp add: \<open>update a1 (l, r) = (l2, r2)\<close> )
+    qed
+  qed
+  finally have "step0 (step0 (s, l, r) tm) tm = (0, update a1 (l, r)) " by auto
+
+  with \<open>step0 (s, l, r) tm = (s', update a1 (l, r))\<close> show ?thesis by auto
+qed
+
+
+
+lemma step0_mk_composable0_after_one_step:
+  assumes "step0 (s, (l, r)) tm \<noteq> step0 (s, l, r) (mk_composable0 tm)"
+  shows "step0 (step0 (s, (l, r)) tm) tm = (0, snd((step0 (s, (l, r)) tm))) \<and>
+         step0 (s, l, r) (mk_composable0 tm)     = (0, snd((step0 (s, (l, r)) tm)))"
+proof (cases "(read r)"; cases s)
+  assume "read r = Bk" and "s = 0"
+  show "step0 (step0 (s, l, r) tm) tm = (0, snd (step0 (s, l, r) tm)) \<and> step0 (s, l, r) (mk_composable0 tm) = (0, snd (step0 (s, l, r) tm))"
+  proof (cases "length tm \<le> 2*s")
+    case True
+    with \<open>s = 0\<close> show ?thesis by auto
+  next  
+    case False
+    then have "2 * s < length tm" by auto
+    with \<open>s = 0\<close> show ?thesis by auto
+  qed
+next
+  assume "read r = Oc" and "s = 0"
+  show "step0 (step0 (s, l, r) tm) tm = (0, snd (step0 (s, l, r) tm)) \<and> step0 (s, l, r) (mk_composable0 tm) = (0, snd (step0 (s, l, r) tm))"
+  proof (cases "length tm \<le> 2*s")
+    case True
+    then have "length tm \<le> 2 * s" .
+    with \<open>s = 0\<close> show ?thesis by auto
+  next  
+    case False
+    then have "2 * s < length tm" by auto
+    with \<open>s = 0\<close> show ?thesis by auto
+  qed
+next
+  fix s1
+  assume "read r = Bk" and "s = Suc s1"
+  show ?thesis
+  proof (cases "length tm \<le> 2*s1")  (* both programs will fetch a Nop *)
+    assume "length tm \<le> 2 * s1"
+    with \<open>read r = Bk\<close> and \<open>s = Suc s1\<close> have "fetch tm (Suc s1) (read r) = (Nop, 0::nat)"
+      by (auto)
+    moreover have "fetch (mk_composable0 tm) (Suc s1) (read r) = (Nop, 0::nat)"
+      by (rule fetch_mk_composable0_Bk_too_short_Suc)(auto simp add: \<open>read r = Bk\<close> \<open>length tm \<le> 2 * s1\<close>)
+    ultimately have "fetch tm (Suc s1) (read r) = fetch (mk_composable0 tm) (Suc s1) (read r)" by auto
+    with \<open>(read r) = Bk\<close> and \<open>s = Suc s1\<close> have "step0 (s, l, r) tm = step0 (s, l, r) (mk_composable0 tm)" by auto
+    with assms have False by auto
+    then show ?thesis by auto
+  next
+    assume "\<not> length tm \<le> 2 * s1"    (* a case hard to prove *)
+      (* both programs will fetch some action in state s = Suc s1, which is explicitly specified in tm already*)
+    then have  "2*s1 < length tm" by auto
+    show "step0 (step0 (s, l, r) tm) tm = (0, snd (step0 (s, l, r) tm)) \<and>
+          step0 (s, l, r) (mk_composable0 tm) = (0, snd (step0 (s, l, r) tm))"
+    proof (cases "fetch tm (Suc s1) (read r)")
+      fix a1 s'
+      assume "fetch tm (Suc s1) (read r) = (a1, s')"
+      show ?thesis
+      proof (cases "s' \<le> length (mk_composable0 tm) div 2")
+        assume "s' \<le> length (mk_composable0 tm) div 2"
+
+        from \<open>fetch tm (Suc s1) (read r) = (a1, s')\<close>
+          and \<open>2*s1 < length tm\<close>
+          and \<open>(read r) = Bk\<close>
+          and \<open>s' \<le> length (mk_composable0 tm) div 2\<close>
+        have "fetch (mk_composable0 tm) (Suc s1) (read r) = fetch tm (Suc s1) (read r)"
+          using fetch_mk_composable0_Bk_Suc_no_fix by auto
+
+        with \<open>(read r) = Bk\<close> and \<open>s = Suc s1\<close> have "step0 (s, l, r) tm = step0 (s, l, r) (mk_composable0 tm)" by auto
+        with assms have False by auto
+        then show ?thesis by auto
+      next
+        assume "\<not> s' \<le> length (mk_composable0 tm) div 2"
+        then have "length (mk_composable0 tm) div 2 < s'" by auto
+        then show ?thesis
+        proof (cases s')
+          assume "s' = 0"
+          with \<open>length (mk_composable0 tm) div 2 < s'\<close> have False by auto
+          then show ?thesis by auto
+        next
+          fix s2
+          assume "s' = Suc s2"
+
+          from \<open>(read r) = Bk\<close> and \<open>s = Suc s1\<close> and \<open>fetch tm (Suc s1) (read r) = (a1, s')\<close>
+          have "step0 (s, l, r) tm = (s', update a1 (l, r))" by auto
+
+          from this and \<open>s' = Suc s2\<close> and \<open>length (mk_composable0 tm) div 2 < s'\<close>
+          have "step0 (step0 (s, l, r) tm) tm = (0, snd (step0 (s, l, r) tm))"
+            by (rule jump_out_of_pgm_is_final_next_step)
+          moreover have "step0 (s, l, r) (mk_composable0 tm) = (0, snd (step0 (s, l, r) tm))"
+          proof -
+            from \<open>fetch tm (Suc s1) (read r) = (a1, s')\<close>
+              and \<open>2*s1 < length tm\<close>
+              and \<open>(read r) = Bk\<close>
+              and \<open>length (mk_composable0 tm) div 2 < s'\<close>
+            have "fetch (mk_composable0 tm) (Suc s1) (read r) = (a1, 0)" using fetch_mk_composable0_Bk_Suc_fix by auto
+            with  \<open>(read r) = Bk\<close> and \<open>s = Suc s1\<close> and \<open>fetch tm (Suc s1) (read r) = (a1, s')\<close>
+            show ?thesis by auto
+          qed
+          ultimately  show ?thesis by auto
+        qed
+      qed
+    qed
+  qed
+next
+  fix s1
+  assume "read r = Oc" and "s = Suc s1"
+  show ?thesis
+
+  proof (cases "length tm \<le> 2*s1+1")  (* both programs will fetch a Nop *)
+    assume "length tm \<le> 2 * s1+1"
+    with \<open>read r = Oc\<close> and \<open>s = Suc s1\<close> have "fetch tm (Suc s1) (read r) = (Nop, 0::nat)"
+      by (auto)
+    moreover have "fetch (mk_composable0 tm) (Suc s1) (read r) = (Nop, 0::nat)"
+    proof (rule fetch_mk_composable0_Oc_too_short_Suc)
+      from \<open>(read r) = Oc\<close> show "(read r) = Oc" .
+    next
+      from \<open>length tm \<le> 2 * s1+1\<close> show "length tm \<le> 2 * s1+1" .
+    qed
+    ultimately have "fetch tm (Suc s1) (read r) = fetch (mk_composable0 tm) (Suc s1) (read r)" by auto
+    with \<open>(read r) = Oc\<close> and \<open>s = Suc s1\<close> have "step0 (s, l, r) tm = step0 (s, l, r) (mk_composable0 tm)" by auto
+    with assms have False by auto
+    then show ?thesis by auto
+  next
+    assume "\<not> length tm \<le> 2 * s1+1"  (* a case hard to prove *)
+      (* both programs will fetch some action in state s = Suc s1, which is explicitly specified in tm already*)
+    then have  "2*s1+1 < length tm" by auto
+    show "step0 (step0 (s, l, r) tm) tm = (0, snd (step0 (s, l, r) tm)) \<and>
+          step0 (s, l, r) (mk_composable0 tm) = (0, snd (step0 (s, l, r) tm))"
+    proof (cases "fetch tm (Suc s1) (read r)")
+      fix a1 s'
+      assume "fetch tm (Suc s1) (read r) = (a1, s')"
+      show ?thesis
+      proof (cases "s' \<le> length (mk_composable0 tm) div 2")
+        assume "s' \<le> length (mk_composable0 tm) div 2"
+
+        from \<open>fetch tm (Suc s1) (read r) = (a1, s')\<close>
+          and \<open>2*s1+1 < length tm\<close>
+          and \<open>(read r) = Oc\<close>
+          and \<open>s' \<le> length (mk_composable0 tm) div 2\<close>
+        have "fetch (mk_composable0 tm) (Suc s1) (read r) = fetch tm (Suc s1) (read r)"
+          using fetch_mk_composable0_Oc_Suc_no_fix by auto
+
+        with \<open>(read r) = Oc\<close> and \<open>s = Suc s1\<close> have "step0 (s, l, r) tm = step0 (s, l, r) (mk_composable0 tm)" by auto
+        with assms have False by auto
+        then show ?thesis by auto
+
+      next
+        assume "\<not> s' \<le> length (mk_composable0 tm) div 2"
+        then have "length (mk_composable0 tm) div 2 < s'" by auto
+        then show ?thesis
+        proof (cases s')
+          assume "s' = 0"
+          with \<open>length (mk_composable0 tm) div 2 < s'\<close> have False by auto
+          then show ?thesis by auto
+        next
+          fix s2
+          assume "s' = Suc s2"
+
+          from \<open>(read r) = Oc\<close> and \<open>s = Suc s1\<close> and \<open>fetch tm (Suc s1) (read r) = (a1, s')\<close>
+          have "step0 (s, l, r) tm = (s', update a1 (l, r))" by auto
+
+          from this and \<open>s' = Suc s2\<close> and \<open>length (mk_composable0 tm) div 2 < s'\<close>
+          have "step0 (step0 (s, l, r) tm) tm = (0, snd (step0 (s, l, r) tm))"
+            by (rule jump_out_of_pgm_is_final_next_step)
+          moreover have "step0 (s, l, r) (mk_composable0 tm) = (0, snd (step0 (s, l, r) tm))"
+          proof -
+            from \<open>fetch tm (Suc s1) (read r) = (a1, s')\<close>
+              and \<open>2*s1+1 < length tm\<close>
+              and \<open>(read r) = Oc\<close>
+              and \<open>length (mk_composable0 tm) div 2 < s'\<close>
+            have "fetch (mk_composable0 tm) (Suc s1) (read r) = (a1, 0)" using fetch_mk_composable0_Oc_Suc_fix by auto
+            with  \<open>(read r) = Oc\<close> and \<open>s = Suc s1\<close> and \<open>fetch tm (Suc s1) (read r) = (a1, s')\<close>
+            show ?thesis by auto
+          qed
+          ultimately  show ?thesis by auto
+        qed
+      qed
+    qed
+  qed
+qed
+
+lemma step0_mk_composable0_eq_after_two_steps:
+  assumes "step0 (s, (l, r)) tm \<noteq> step0 (s, l, r) (mk_composable0 tm)"
+  shows "step0 (step0 (s, (l, r)) tm) tm = (0, snd((step0 (s, (l, r)) tm))) \<and>
+         step0 (step0 (s, (l, r)) (mk_composable0 tm)) (mk_composable0 tm) = step0 (step0 (s, (l, r)) tm) tm"
+proof -
+  from assms have A: "step0 (step0 (s, (l, r)) tm) tm = (0, snd((step0 (s, (l, r)) tm))) \<and>
+         step0 (s, l, r) (mk_composable0 tm)     = (0, snd((step0 (s, (l, r)) tm)))"
+    by (rule step0_mk_composable0_after_one_step)
+  from A have A1: "step0 (step0 (s, (l, r)) tm) tm = (0, snd((step0 (s, (l, r)) tm)))" by auto
+  from A have A2: "step0 (s, l, r) (mk_composable0 tm) = (0, snd((step0 (s, (l, r)) tm)))" by auto
+
+  show ?thesis
+  proof (cases "snd((step0 (s, (l, r)) tm))")
+    case (Pair a b)
+    assume "snd (step0 (s, l, r) tm) = (a, b)"
+    show ?thesis
+    proof -
+      from \<open>snd (step0 (s, l, r) tm) = (a, b)\<close> and \<open>step0 (s, l, r) (mk_composable0 tm) = (0, snd((step0 (s, (l, r)) tm)))\<close>
+      have "step0 (s, l, r) (mk_composable0 tm) = (0, (a,b))" by auto
+
+      then have "step0 (step0 (s, (l, r)) (mk_composable0 tm)) (mk_composable0 tm) = step0 (0, (a,b))  (mk_composable0 tm)" by auto
+      also have "... = (0, (a,b))" by auto
+      finally have "step0 (step0 (s, (l, r)) (mk_composable0 tm)) (mk_composable0 tm) = (0, (a,b))" by auto
+
+      moreover from A1 and  \<open>snd (step0 (s, l, r) tm) = (a, b)\<close>
+      have "step0 (step0 (s, (l, r)) tm) tm = (0, (a,b))" by auto
+
+      ultimately have "step0 (step0 (s, (l, r)) (mk_composable0 tm)) (mk_composable0 tm) = step0 (step0 (s, (l, r)) tm) tm" by auto
+      with A1 show ?thesis by auto
+    qed
+  qed
+qed
+
+(* ------------------------------------------------------------------ *)
+
+subsection \<open>Properties of function steps0 with respect to function mk\_composable0\<close>
+
+lemma "steps0 (s, (l, r)) tm 0 = steps0 (s, l, r) (mk_composable0 tm) 0"
+  by auto
+
+lemma mk_composable0_tm_at_most_one_diff_pre:
+  assumes "steps0 (s, (l, r)) tm stp \<noteq> steps0 (s, l, r) (mk_composable0 tm) stp"
+  shows "0<stp \<and> (\<exists>k. k<stp 
+            \<and> (\<forall>i \<le> k. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i)
+            \<and> (\<forall>j > k+1.
+                    steps0 (s, l, r) tm (j) = (0, snd(steps0 (s, l, r) tm (k+1))) \<and> 
+                    steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j))"
+proof -
+  have "\<exists>k<stp. (\<forall>i\<le>k. \<not> steps0 (s, l, r) tm i \<noteq> steps0 (s, l, r) (mk_composable0 tm) i) \<and> steps0 (s, l, r) tm (Suc k) \<noteq> steps0 (s, l, r) (mk_composable0 tm) (Suc k)"
+  proof (rule ex_least_nat_less)
+    show "\<not> steps0 (s, l, r) tm 0 \<noteq> steps0 (s, l, r) (mk_composable0 tm) 0" by auto
+  next
+    from assms show "steps0 (s, l, r) tm stp \<noteq> steps0 (s, l, r) (mk_composable0 tm) stp" by auto
+  qed
+  then obtain k where w_k: "k < stp \<and> (\<forall>i\<le>k. \<not> steps0 (s, l, r) tm i \<noteq> steps0 (s, l, r) (mk_composable0 tm) i) \<and> steps0 (s, l, r) tm (Suc k) \<noteq> steps0 (s, l, r) (mk_composable0 tm) (Suc k)" by blast
+  from w_k have F1: "k < stp" by auto
+  from w_k have F2: "\<And>i. i\<le>k \<Longrightarrow> \<not> steps0 (s, l, r) tm i \<noteq> steps0 (s, l, r) (mk_composable0 tm) i" by auto
+  from w_k have F3: "steps0 (s, l, r) tm (k + 1) \<noteq> steps0 (s, l, r) (mk_composable0 tm) (k + 1)" by auto
+
+  from F3 have F3': "(steps0 (s, l, r) tm (Suc k)) \<noteq> (steps0 (s, l, r) (mk_composable0 tm) (Suc k))" by auto
+
+  have "\<not>(steps0 (s, l, r) tm k \<noteq> steps0 (s, l, r) (mk_composable0 tm) k)" using F2 by auto
+  then have F4: "steps0 (s, l, r) tm k = steps0 (s, l, r) (mk_composable0 tm) k" by auto
+
+  have X1: "steps0 (s, l, r) (mk_composable0 tm) (Suc k) = step0 (steps0 (s, l, r) (mk_composable0 tm) k) (mk_composable0 tm)" by (rule step_red)
+  have X2: "steps0 (s, l, r) tm (Suc k) = step0 (steps0 (s, l, r) tm k) tm" by (rule step_red)
+
+  from X1 and X2 and F3'
+  have "step0 (steps0 (s, l, r) tm k) tm \<noteq> step0 (steps0 (s, l, r) (mk_composable0 tm) k) (mk_composable0 tm)" by auto
+
+  then have "\<exists> sk lk rk. steps0 (s, l, r) tm k = (sk, lk, rk) \<and>
+                         steps0 (s, l, r) (mk_composable0 tm) k = (sk, lk, rk) \<and>
+                         step0 (sk, (lk, rk)) tm \<noteq> step0 (sk, lk, rk) (mk_composable0 tm)"
+  proof (cases "steps0 (s, l, r) tm k")
+    case (fields s' l' r')
+    then have "steps0 (s, l, r) tm k = (s', l', r')" .
+    moreover with \<open>step0 (steps0 (s, l, r) tm k) tm \<noteq> step0 (steps0 (s, l, r) (mk_composable0 tm) k) (mk_composable0 tm)\<close> and F4
+    have "step0 (s', (l', r')) tm \<noteq> step0 (s', l', r') (mk_composable0 tm)" by auto
+
+    moreover from \<open>steps0 (s, l, r) tm k = (s', l', r')\<close> and F4
+    have "steps0 (s, l, r) (mk_composable0 tm) k = (s', l', r')" by auto
+    ultimately have "steps0 (s, l, r) tm k = (s', l', r') \<and> steps0 (s, l, r) (mk_composable0 tm) k = (s', l', r') \<and>
+                     step0 (s', (l', r')) tm \<noteq> step0 (s', l', r') (mk_composable0 tm)" by auto
+
+    then show ?thesis by blast
+  qed
+
+  then obtain sk lk rk where
+    w_sk_lk_rk: "steps0 (s, l, r) tm k = (sk, lk, rk) \<and>
+                 steps0 (s, l, r) (mk_composable0 tm) k = (sk, lk, rk) \<and>
+                 step0 (sk, (lk, rk)) tm \<noteq> step0 (sk, lk, rk) (mk_composable0 tm)" by blast
+
+  have Y1: "step0 (step0 (sk, (lk, rk)) tm) tm = (0, snd((step0 (sk, (lk, rk)) tm))) \<and>
+         step0 (step0 (sk, (lk, rk)) (mk_composable0 tm)) (mk_composable0 tm) = step0 (step0 (sk, (lk, rk)) tm) tm"
+  proof (rule  step0_mk_composable0_eq_after_two_steps)
+    from w_sk_lk_rk show "step0 (sk, lk, rk) tm \<noteq> step0 (sk, lk, rk) (mk_composable0 tm)" by auto
+  qed
+
+  from Y1 and w_sk_lk_rk
+  have "step0 (step0 (steps0 (s, l, r) tm k) tm) tm = (0, snd((step0 (steps0 (s, l, r) tm k) tm)))" by auto
+
+  from Y1 and w_sk_lk_rk
+  have "step0 (step0 (steps0 (s, l, r) (mk_composable0 tm) k) (mk_composable0 tm)) (mk_composable0 tm) = step0 (step0 (steps0 (s, l, r) tm k) tm) tm" by auto
+
+  have "steps0 (s, l, r) (mk_composable0 tm) (k+2) = step0 (step0 (steps0 (s, l, r) (mk_composable0 tm) k) (mk_composable0 tm)) (mk_composable0 tm)"
+    by (auto simp add: step_red[symmetric])
+
+  have "steps0 (s, l, r) tm (k+2) = step0 (step0 (steps0 (s, l, r) tm k) tm) tm"
+    by (auto simp add: step_red[symmetric])
+
+  from \<open>step0 (step0 (steps0 (s, l, r) tm k) tm) tm = (0, snd((step0 (steps0 (s, l, r) tm k) tm)))\<close>
+    and \<open>steps0 (s, l, r) tm (k+2) = step0 (step0 (steps0 (s, l, r) tm k) tm) tm\<close>
+  have "steps0 (s, l, r) tm (k+2) = (0, snd((step0 (steps0 (s, l, r) tm k) tm)))" by auto
+  then have N1: "steps0 (s, l, r) tm (k+2) = (0, snd(steps0 (s, l, r) tm (k+1)))" by (auto simp add: step_red[symmetric])
+
+  from \<open>step0 (step0 (steps0 (s, l, r) (mk_composable0 tm) k) (mk_composable0 tm)) (mk_composable0 tm) = step0 (step0 (steps0 (s, l, r) tm k) tm) tm\<close>
+  have N2: "steps0 (s, l, r) (mk_composable0 tm) (k+2) = steps0 (s, l, r) tm (k+2)" by (auto simp add: step_red[symmetric])
+
+  have N4: "\<forall>j > k+1.
+         steps0 (s, l, r) tm (j) = (0, snd(steps0 (s, l, r) tm (k+1))) \<and> 
+         steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j"
+  proof
+    fix j
+    show "k + 1 < j \<longrightarrow> steps0 (s, l, r) tm j = (0, snd (steps0 (s, l, r) tm (k+1))) \<and> steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j"
+    proof (induct j)
+      case 0
+      then show ?case by auto
+    next
+      fix  j
+      assume IV: "k + 1 < j \<longrightarrow> steps0 (s, l, r) tm j = (0, snd (steps0 (s, l, r) tm (k+1))) \<and> steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j"
+      show "k + 1 < Suc j \<longrightarrow> steps0 (s, l, r) tm (Suc j) = (0, snd (steps0 (s, l, r) tm (k+1))) \<and> steps0 (s, l, r) (mk_composable0 tm) (Suc j) = steps0 (s, l, r) tm (Suc j)"
+      proof
+        assume "k + 1 < Suc j"
+        then have "k + 1 \<le> j" by arith
+        then have "k + 1 = j \<or> k+1 < j" by arith 
+        then show "steps0 (s, l, r) tm (Suc j) = (0, snd (steps0 (s, l, r) tm (k+1))) \<and> steps0 (s, l, r) (mk_composable0 tm) (Suc j) = steps0 (s, l, r) tm (Suc j)"
+        proof
+          assume "k + 1 = j"
+          with N1 and N2 show "steps0 (s, l, r) tm (Suc j) = (0, snd (steps0 (s, l, r) tm (k+1))) \<and>
+                               steps0 (s, l, r) (mk_composable0 tm) (Suc j) = steps0 (s, l, r) tm (Suc j)"
+            by force
+        next
+          assume "k + 1 < j"
+          with IV
+          have Y4: "steps0 (s, l, r) tm j = (0, snd (steps0 (s, l, r) tm (k+1))) \<and> steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j" by auto
+          show "steps0 (s, l, r) tm (Suc j) = (0, snd (steps0 (s, l, r) tm (k+1))) \<and> steps0 (s, l, r) (mk_composable0 tm) (Suc j) = steps0 (s, l, r) tm (Suc j)"
+          proof (cases " snd (steps0 (s, l, r) tm (k+1))")
+            case (Pair a b)
+            then have "snd (steps0 (s, l, r) tm (k + 1)) = (a, b)" .
+            with Y4 have "steps0 (s, l, r) tm j = (0,a,b) \<and> steps0 (s, l, r) (mk_composable0 tm) j = (0,a,b)" by auto
+            then have "steps0 (s, l, r) tm (j+1) = (0,a,b) \<and> steps0 (s, l, r) (mk_composable0 tm) (j+1) = (0,a,b)"
+            proof
+              assume "steps0 (s, l, r) tm j = (0, a, b)" and "steps0 (s, l, r) (mk_composable0 tm) j = (0, a, b)"
+              show "steps0 (s, l, r) tm (j + 1) = (0, a, b) \<and> steps0 (s, l, r) (mk_composable0 tm) (j + 1) = (0, a, b)"
+              proof
+                from \<open>steps0 (s, l, r) tm j = (0, a, b)\<close> show "steps0 (s, l, r) tm (j + 1) = (0, a, b)" by (rule stable_config_after_final_add_2)
+              next
+                from \<open>steps0 (s, l, r) (mk_composable0 tm) j = (0, a, b)\<close> show "steps0 (s, l, r) (mk_composable0 tm) (j + 1) = (0, a, b)" by (rule stable_config_after_final_add_2)
+              qed
+            qed       
+            then have "steps0 (s, l, r) tm (Suc j) = (0, a, b) \<and> steps0 (s, l, r) (mk_composable0 tm) (Suc j) = (0, a, b)" by auto
+            with \<open>snd (steps0 (s, l, r) tm (k + 1)) = (a, b)\<close> show ?thesis by auto
+          qed
+        qed
+      qed
+    qed
+  qed
+
+  from F1 and F2 and N4 show ?thesis
+    by (metis neq0_conv not_less_zero)
+qed
+
+(* ----------------- *)
+
+lemma mk_composable0_tm_at_most_one_diff:
+  assumes "steps0 (s, l, r) (mk_composable0 tm) stp \<noteq> steps0 (s, (l, r)) tm stp"
+  shows "0<stp \<and>  
+         (\<forall>i < stp. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i) \<and>
+         (\<forall>j > stp. steps0 (s, l, r) tm (j) = (0, snd(steps0 (s, l, r) tm stp)) \<and> 
+                    steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j)"
+proof -
+  from assms have "steps0 (s, (l, r)) tm stp \<noteq> steps0 (s, l, r) (mk_composable0 tm) stp" by auto
+  then have A:
+    "0<stp \<and> (\<exists>k. k<stp 
+            \<and> (\<forall>i \<le> k. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i)
+            \<and> (\<forall>j > k+1.
+                    steps0 (s, l, r) tm (j) = (0, snd(steps0 (s, l, r) tm (k+1))) \<and> 
+                    steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j))"
+    by (rule mk_composable0_tm_at_most_one_diff_pre)
+  then have F1: "0<stp" by auto
+  from A have "(\<exists>k. k<stp 
+            \<and> (\<forall>i \<le> k. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i)
+            \<and> (\<forall>j > k+1.
+                    steps0 (s, l, r) tm (j) = (0, snd(steps0 (s, l, r) tm (k+1))) \<and> 
+                    steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j))" by auto
+  then obtain k where w_k:
+    "k<stp 
+            \<and> (\<forall>i \<le> k. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i)
+            \<and> (\<forall>j > k+1.
+                    steps0 (s, l, r) tm (j) = (0, snd(steps0 (s, l, r) tm (k+1))) \<and> 
+                    steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j)" by blast
+  then have "stp = k+1 \<or> k+1 < stp" by arith
+  then show ?thesis
+  proof
+    assume "stp = k+1"
+    show ?thesis
+    proof
+      from F1 show "0 < stp" by auto
+    next
+      from \<open>stp = k+1\<close> and w_k
+      show  "(\<forall>i<stp. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i) \<and>
+    (\<forall>j>stp. steps0 (s, l, r) tm j = (0, snd (steps0 (s, l, r) tm stp)) \<and> steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j)" by auto
+    qed
+  next
+    assume "k+1 < stp"
+    with w_k and assms have False by auto
+    then show ?thesis by auto
+  qed
+qed
+
+
+lemma mk_composable0_tm_at_most_one_diff':
+  assumes "steps0 (s, l, r) (mk_composable0 tm) stp \<noteq> steps0 (s, (l, r)) tm stp"
+  shows "0 < stp \<and> (\<exists>fl fr. snd(steps0 (s, l, r) tm stp) = (fl, fr) \<and>      
+                   (\<forall>i < stp. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i) \<and>
+                   (\<forall>j > stp. steps0 (s, l, r)  tm         j = (0, fl, fr) \<and> 
+                              steps0 (s, l, r) (mk_composable0 tm) j = (0, fl, fr) ))"
+proof -
+  from assms have major: "0 < stp \<and>  
+         (\<forall>i < stp. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i) \<and>
+         (\<forall>j > stp. steps0 (s, l, r) tm (j) = (0, snd(steps0 (s, l, r) tm stp)) \<and> 
+                    steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j)"
+    by (rule mk_composable0_tm_at_most_one_diff)
+  from major have F1: "0 < stp" by auto
+  from major have F2: "(\<forall>i < stp. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i) \<and>
+                       (\<forall>j > stp. steps0 (s, l, r) tm (j) = (0, snd(steps0 (s, l, r) tm stp)) \<and> 
+                                  steps0 (s, l, r) (mk_composable0 tm) j = steps0 (s, l, r) tm j)" by auto
+  then have "snd(steps0 (s, l, r) tm stp) = (fst(snd(steps0 (s, l, r) tm stp)), snd(snd(steps0 (s, l, r) tm stp)) )" by auto
+  with F2 have "snd(steps0 (s, l, r) tm stp) = (fst(snd(steps0 (s, l, r) tm stp)), snd(snd(steps0 (s, l, r) tm stp)) ) \<and>
+                       (\<forall>i < stp. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i) \<and>
+                       (\<forall>j > stp. steps0 (s, l, r) tm j = (0, (fst(snd(steps0 (s, l, r) tm stp)), snd(snd(steps0 (s, l, r) tm stp)) )) \<and>
+                                  steps0 (s, l, r) (mk_composable0 tm) j = (0, (fst(snd(steps0 (s, l, r) tm stp)), snd(snd(steps0 (s, l, r) tm stp)) )))"
+    by auto
+  then have  "(\<exists>fl fr.  snd(steps0 (s, l, r) tm stp) = (fl, fr) \<and>
+                       (\<forall>i < stp. steps0 (s, l, r) (mk_composable0 tm) i = steps0 (s, l, r) tm i) \<and>
+                       (\<forall>j > stp. steps0 (s, l, r) tm j = (0, fl, fr) \<and>
+                                  steps0 (s, l, r) (mk_composable0 tm) j = (0, fl, fr)))" by blast
+  with F1 show ?thesis by auto
+qed
+
+end
+
diff --git a/thys/Universal_Turing_Machine/ComposableTMs_aux.thy b/thys/Universal_Turing_Machine/ComposableTMs_aux.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/ComposableTMs_aux.thy
@@ -0,0 +1,113 @@
+(* Title: thys/ComposableTMs_aux.thy
+   Author: Franz Regensburger (FABR) 02/2022
+ *)
+
+theory ComposableTMs_aux
+  imports ComposableTMs
+begin
+
+(* --------------------------------------------------- *)
+(* Exhaustion-/Case-Lemmas for actions and instr lists *)
+(* Currently none of these lemmas is in use            *)
+(* --------------------------------------------------- *)
+
+lemma nat_cases_0_1_gt1 (* [case_names Zero One GtOne, cases type: nat] *) :
+  assumes "(n::nat) = (0::nat) \<Longrightarrow> P"
+    and "(n::nat) = (1::nat) \<Longrightarrow> P"
+    and "2 \<le> (n::nat) \<Longrightarrow> P"
+  shows P
+proof -
+  have "n= 0 \<or> n = 1 \<or> (\<exists>m. n = Suc (Suc m))"
+    by (induct n) auto
+  with assms  show P by auto
+qed
+
+lemma list_len_1_is_singleton: "length l = 1 \<Longrightarrow> (\<exists>x. l = [x])"
+  by (induct l) auto
+
+lemma action_exhaust2: "actn = WB \<or> actn = WO \<or> actn = L \<or> actn = R \<or> actn = Nop"
+  by (rule Turing.action.exhaust) auto
+
+lemma instr_exhaust: "\<exists>nxt. ins = (WB, nxt)  \<or> ins = (WO, nxt) \<or> ins = (L, nxt) \<or> ins = (R, nxt) \<or> ins = (Nop, nxt)"
+proof (cases ins)
+  case (Pair a b)
+  then have "ins = (a, b)" .
+  show ?thesis
+  proof (rule Turing.action.exhaust)
+    assume "a = WB"
+    with \<open>ins = (a, b)\<close> have "ins = (WB, b) \<or> ins = (WO, b) \<or> ins = (L, b) \<or> ins = (R, b) \<or> ins = (Nop, b)" by auto
+    then show ?thesis by auto
+  next
+    assume "a = WO"
+    with \<open>ins = (a, b)\<close> have "ins = (WB, b) \<or> ins = (WO, b) \<or> ins = (L, b) \<or> ins = (R, b) \<or> ins = (Nop, b)" by auto
+    then show ?thesis by auto
+  next
+    assume "a = L"
+    with \<open>ins = (a, b)\<close> have "ins = (WB, b) \<or> ins = (WO, b) \<or> ins = (L, b) \<or> ins = (R, b) \<or> ins = (Nop, b)" by auto
+    then show ?thesis by auto
+  next
+    assume "a = R"
+    with \<open>ins = (a, b)\<close> have "ins = (WB, b) \<or> ins = (WO, b) \<or> ins = (L, b) \<or> ins = (R, b) \<or> ins = (Nop, b)" by auto
+    then show ?thesis by auto
+  next
+    assume "a = Nop"
+    with \<open>ins = (a, b)\<close> have "ins = (WB, b) \<or> ins = (WO, b) \<or> ins = (L, b) \<or> ins = (R, b) \<or> ins = (Nop, b)" by auto
+    then show ?thesis by auto
+  qed
+qed
+
+(* Attention:
+    Secifiying  instr_cases  [case_names WB WO L R Nop, cases type: nat] :
+    breaks proofs
+      seq_tm_exec_after_first
+    in Turingomp.thy 
+*)
+lemma instr_cases (* [case_names WB WO L R Nop, cases type: nat] *) :
+  assumes "\<And>nxt. ins = (WB, nxt) \<Longrightarrow> P"
+    and "\<And>nxt. ins = (WO, nxt) \<Longrightarrow> P"
+    and "\<And>nxt. ins = (L, nxt) \<Longrightarrow> P"
+    and "\<And>nxt. ins = (R, nxt) \<Longrightarrow> P"
+    and "\<And>nxt. ins = (Nop, nxt) \<Longrightarrow> P"
+  shows P
+proof -
+  have "\<exists>nxt. ins = (WB, nxt)  \<or> ins = (WO, nxt) \<or> ins = (L, nxt) \<or> ins = (R, nxt) \<or> ins = (Nop, nxt)"
+    by (rule instr_exhaust)
+  then obtain nxt where w_nxt: "ins = (WB, nxt)  \<or> ins = (WO, nxt) \<or> ins = (L, nxt) \<or> ins = (R, nxt) \<or> ins = (Nop, nxt)" by blast
+  with assms show P by auto
+qed
+
+lemma sigleton_tm_exhaust: "length (tm::instr list) = 1 \<Longrightarrow> \<exists>nxt. tm = [(WB, nxt)]  \<or> tm = [(WO, nxt)] \<or> tm = [(L, nxt)] \<or> tm = [(R, nxt)] \<or> tm = [(Nop, nxt)]"
+proof -
+  assume "length (tm::instr list) = 1"
+  then have "(\<exists>instr. tm = [instr])" by (rule list_len_1_is_singleton)
+  then obtain instr where w_instr: "tm = [instr]" by blast
+  have "\<exists>nxt. instr = (WB, nxt) \<or> instr = (WO, nxt) \<or> instr = (L, nxt) \<or> instr = (R, nxt) \<or> instr = (Nop, nxt)" by (rule instr_exhaust)
+  then obtain nxt where w_nxt: "instr = (WB, nxt) \<or> instr = (WO, nxt) \<or> instr = (L, nxt) \<or> instr = (R, nxt) \<or> instr = (Nop, nxt)" by blast
+  with w_instr show ?thesis by auto
+qed
+
+lemma split_action_all: "(\<forall>nxt. P nxt) \<longleftrightarrow> (\<forall>nxt. P (WB, nxt)) \<and> (\<forall>nxt. P (WO, nxt)) \<and> (\<forall>nxt. P (L, nxt)) \<and> (\<forall>nxt. P (R, nxt)) \<and> (\<forall>nxt. P (Nop, nxt))"
+  by (auto intro: action.induct)
+
+(* Attention:
+    Secifiying  tm_instr_cases [consumes 1, case_names WB WO L R Nop, cases type: nat] :
+    breaks proofs
+      modify_tprog_fetch_odd
+    in UF.thy 
+*)
+lemma tm_instr_cases (* [consumes 1, case_names WB WO L R Nop, cases type: nat] *):
+  assumes  "length (tm::instr list) = 1"
+    and "\<And>nxt. tm = [(WB, nxt)] \<Longrightarrow> P"
+    and "\<And>nxt. tm = [(WO, nxt)] \<Longrightarrow> P"
+    and "\<And>nxt. tm = [(L, nxt)] \<Longrightarrow> P"
+    and "\<And>nxt. tm = [(R, nxt)] \<Longrightarrow> P"
+    and "\<And>nxt. tm = [(Nop, nxt)] \<Longrightarrow> P"
+  shows P
+proof -
+  from \<open>length tm = 1\<close> have "\<exists>nxt. tm = [(WB, nxt)]  \<or> tm = [(WO, nxt)] \<or> tm = [(L, nxt)] \<or> tm = [(R, nxt)] \<or> tm = [(Nop, nxt)]"
+    by (rule sigleton_tm_exhaust)
+  then obtain nxt where w_nxt: "tm = [(WB, nxt)]  \<or> tm = [(WO, nxt)] \<or> tm = [(L, nxt)] \<or> tm = [(R, nxt)] \<or> tm = [(Nop, nxt)]" by blast
+  with assms show P by auto
+qed
+
+end
diff --git a/thys/Universal_Turing_Machine/ComposedTMs.thy b/thys/Universal_Turing_Machine/ComposedTMs.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/ComposedTMs.thy
@@ -0,0 +1,199 @@
+(* Title: thys/ComposedTMs.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+ 
+   Minor modifications, comments by Franz Regensburger (FABR) 02/2022
+ *)
+
+theory ComposedTMs
+  imports ComposableTMs
+begin
+
+section \<open>Composition of Turing Machines\<close>
+
+fun 
+  shift :: "instr list \<Rightarrow> nat \<Rightarrow> instr list"
+  where
+    "shift p n = (map (\<lambda> (a, s). (a, (if s = 0 then 0 else s + n))) p)"
+
+fun 
+  adjust :: "instr list \<Rightarrow> nat \<Rightarrow> instr list"
+  where
+    "adjust p e = map (\<lambda> (a, s). (a, if s = 0 then e else s)) p"
+
+abbreviation
+  "adjust0 p \<equiv> adjust p (Suc (length p div 2))"
+
+lemma length_shift [simp]: 
+  shows "length (shift p n) = length p"
+  by simp
+
+lemma length_adjust [simp]: 
+  shows "length (adjust p n) = length p"
+  by (induct p) (auto)
+
+
+(* composition of two Turing machines *)
+fun
+  seq_tm :: "instr list \<Rightarrow> instr list \<Rightarrow> instr list" (infixl "|+|" 60)
+  where
+    "seq_tm p1 p2 = ((adjust0 p1) @ (shift p2 (length p1 div 2)))"
+
+lemma seq_tm_length:
+  shows "length (A |+| B) = length A + length B"
+  by auto
+
+lemma seq_tm_composable[intro]: 
+  "\<lbrakk>composable_tm (A, 0); composable_tm (B, 0)\<rbrakk> \<Longrightarrow> composable_tm (A |+| B, 0)"
+  by (fastforce)
+
+lemma seq_tm_step: 
+  assumes unfinal: "\<not> is_final (step0 c A)"
+  shows "step0 c (A |+| B) = step0 c A"
+proof -
+  obtain s l r where eq: "c = (s, l, r)" by (metis is_final.cases) 
+  have "\<not> is_final (step0 (s, l, r) A)" using unfinal eq by simp
+  then have "case (fetch A s (read r)) of (a, s) \<Rightarrow> s \<noteq> 0"
+    by (auto simp add: is_final_eq)
+  then have "fetch (A |+| B) s (read r) = fetch A s (read r)"
+    apply (cases "read r";cases s)
+    by (auto simp: seq_tm_length nth_append)
+  then show "step0 c (A |+| B) = step0 c A" by (simp add: eq) 
+qed
+
+lemma seq_tm_steps:  
+  assumes "\<not> is_final (steps0 c A n)" 
+  shows "steps0 c (A |+| B) n = steps0 c A n"
+  using assms
+proof(induct n)
+  case 0
+  then show "steps0 c (A |+| B) 0 = steps0 c A 0" by auto
+next 
+  case (Suc n)
+  have ih: "\<not> is_final (steps0 c A n) \<Longrightarrow> steps0 c (A |+| B) n = steps0 c A n" by fact
+  have fin: "\<not> is_final (steps0 c A (Suc n))" by fact
+  then have fin1: "\<not> is_final (step0 (steps0 c A n) A)" 
+    by (auto simp only: step_red)
+  then have fin2: "\<not> is_final (steps0 c A n)"
+    by (metis is_final_eq step_0 surj_pair) 
+
+  have "steps0 c (A |+| B) (Suc n) = step0 (steps0 c (A |+| B) n) (A |+| B)" 
+    by (simp only: step_red)
+  also have "... = step0 (steps0 c A n) (A |+| B)" by (simp only: ih[OF fin2])
+  also have "... = step0 (steps0 c A n) A" by (simp only: seq_tm_step[OF fin1])
+  finally show "steps0 c (A |+| B) (Suc n) = steps0 c A (Suc n)"
+    by (simp only: step_red)
+qed
+
+lemma seq_tm_fetch_in_A:
+  assumes h1: "fetch A s x = (a, 0)"
+    and h2: "s \<le> length A div 2" 
+    and h3: "s \<noteq> 0"
+  shows "fetch (A |+| B) s x = (a, Suc (length A div 2))"
+  using h1 h2 h3
+  apply(cases s;cases x)
+  by(auto simp: seq_tm_length nth_append)
+
+lemma seq_tm_exec_after_first:
+  assumes h1: "\<not> is_final c" 
+    and h2: "step0 c A = (0, tap)"
+    and h3: "fst c \<le> length A div 2"
+  shows "step0 c (A |+| B) = (Suc (length A div 2), tap)"
+  using h1 h2 h3
+  apply(case_tac c)
+  apply(auto simp del: seq_tm.simps)
+   apply(case_tac "fetch A a Bk")
+   apply(simp del: seq_tm.simps)
+   apply(subst seq_tm_fetch_in_A;force)
+  apply(case_tac "fetch A a (hd ca)")
+  apply(simp del: seq_tm.simps)
+  apply(subst seq_tm_fetch_in_A)
+     apply(auto)[4]
+  done
+
+(* if A goes into the final state, then A |+| B will go into the first state of B *)
+lemma seq_tm_next: 
+  assumes a_ht: "steps0 (1, tap) A n = (0, tap')"
+    and a_composable: "composable_tm (A, 0)"
+  obtains n' where "steps0 (1, tap) (A |+| B) n' = (Suc (length A div 2), tap')"
+proof -
+  assume a: "\<And>n. steps (1, tap) (A |+| B, 0) n = (Suc (length A div 2), tap') \<Longrightarrow> thesis"
+  obtain stp' where fin: "\<not> is_final (steps0 (1, tap) A stp')" and h: "steps0 (1, tap) A (Suc stp') = (0, tap')"
+    using before_final[OF a_ht] by blast
+  from fin have h1:"steps0 (1, tap) (A |+| B) stp' = steps0 (1, tap) A stp'"
+    by (rule seq_tm_steps)
+  from h have h2: "step0 (steps0 (1, tap) A stp') A = (0, tap')"
+    by (simp only: step_red)
+
+  have "steps0 (1, tap) (A |+| B) (Suc stp') = step0 (steps0 (1, tap) (A |+| B) stp') (A |+| B)" 
+    by (simp only: step_red)
+  also have "... = step0 (steps0 (1, tap) A stp') (A |+| B)" using h1 by simp
+  also have "... = (Suc (length A div 2), tap')" 
+    by (rule seq_tm_exec_after_first[OF fin h2 steps_in_range[OF fin a_composable]])
+  finally show thesis using a by blast
+qed
+
+lemma seq_tm_fetch_second_zero:
+  assumes h1: "fetch B s x = (a, 0)"
+    and hs: "composable_tm (A, 0)" "s \<noteq> 0"
+  shows "fetch (A |+| B) (s + (length A div 2)) x = (a, 0)"
+  using h1 hs
+  by(cases x; cases s; fastforce simp: seq_tm_length nth_append)
+
+lemma seq_tm_fetch_second_inst:
+  assumes h1: "fetch B sa x = (a, s)"
+    and hs: "composable_tm (A, 0)" "sa \<noteq> 0" "s \<noteq> 0"
+  shows "fetch (A |+| B) (sa + length A div 2) x = (a, s + length A div 2)"
+  using h1 hs
+  by(cases x; cases sa; fastforce simp: seq_tm_length nth_append)
+
+
+lemma seq_tm_second:
+  assumes a_composable: "composable_tm (A, 0)"
+    and steps: "steps0 (1, l, r) B stp = (s', l', r')"
+  shows "steps0 (Suc (length A div 2), l, r)  (A |+| B) stp 
+    = (if s' = 0 then 0 else s' + length A div 2, l', r')"
+  using steps
+proof(induct stp arbitrary: s' l' r')
+  case 0
+  then show ?case by simp
+next
+  case (Suc stp s' l' r')
+  obtain s'' l'' r'' where a: "steps0 (1, l, r) B stp = (s'', l'', r'')"
+    by (metis is_final.cases)
+  then have ih1: "s'' = 0 \<Longrightarrow> steps0 (Suc (length A div 2), l, r) (A |+| B) stp = (0, l'', r'')"
+    and ih2: "s'' \<noteq> 0 \<Longrightarrow> steps0 (Suc (length A div 2), l, r) (A |+| B) stp = (s'' + length A div 2, l'', r'')"
+    using Suc by (auto)
+  have h: "steps0 (1, l, r) B (Suc stp) = (s', l', r')" by fact
+
+  { assume "s'' = 0"
+    then have ?case using a h ih1 by (simp del: steps.simps) 
+  } moreover
+  { assume as: "s'' \<noteq> 0" "s' = 0"
+    from as a h 
+    have "step0 (s'', l'', r'') B = (0, l', r')" by (simp del: steps.simps)
+    with as have ?case
+      apply(cases "fetch B s'' (read r'')")
+      by (auto simp add: seq_tm_fetch_second_zero[OF _ a_composable] ih2[OF as(1)]
+          simp del: seq_tm.simps steps.simps)
+  } moreover
+  { assume as: "s'' \<noteq> 0" "s' \<noteq> 0"
+    from as a h
+    have "step0 (s'', l'', r'') B = (s', l', r')" by (simp del: steps.simps)
+    with as have ?case
+      apply(simp add: ih2[OF as(1)] del: seq_tm.simps steps.simps)
+      apply(case_tac "fetch B s'' (read r'')")
+      apply(auto simp add: seq_tm_fetch_second_inst[OF _ a_composable as] simp del: seq_tm.simps)
+      done
+  }
+  ultimately show ?case by blast
+qed
+
+lemma seq_tm_final:
+  assumes "composable_tm (A, 0)"  
+    and "steps0 (1, l, r) B stp = (0, l', r')"
+  shows "steps0 (Suc (length A div 2), l, r)  (A |+| B) stp = (0, l', r')"
+  using seq_tm_second[OF assms] by (simp)
+
+end
+
diff --git a/thys/Universal_Turing_Machine/CopyTM.thy b/thys/Universal_Turing_Machine/CopyTM.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/CopyTM.thy
@@ -0,0 +1,864 @@
+(* Title: thys/CopyTM.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+ 
+   Further contributions by Franz Regensburger (FABR) 02/2022:
+   * Re-ordering of sections
+   * Added comments
+
+   Editorial note FABR:
+   this file was part of the theory file Uncomputable.thy
+   in the original AFP entry. 
+
+ *)
+
+subsection \<open>A Turing machine that just duplicates its input if the input is a single numeral\<close>
+
+text \<open>The machine tm\_copy is almost identical to the machine tm\_weak\_copy that we
+presented in theory WeakCopyTM. They only differ in the first instruction of
+component tm\_copy\_end (compare tm\_copy\_end\_orig and tm\_copy\_end\_new in theory WeakCopyTM).
+
+As for machine tm\_dither, we keep the entire theory CopyTM for backwards compatibility with
+the original AFP entry.\<close>
+
+theory CopyTM
+  imports
+    Turing_Hoare
+    Turing_HaltingConditions
+begin
+
+(* Cleanup the global simpset for proofs of several theorems about tm_dither *)
+
+declare adjust.simps[simp del]
+
+definition 
+  tm_copy_begin :: "instr list"
+  where
+    "tm_copy_begin \<equiv> [(WB, 0), (R, 2), (R, 3), (R, 2),
+                 (WO, 3), (L, 4), (L, 4), (L, 0)]"
+
+definition 
+  tm_copy_loop :: "instr list"
+  where
+    "tm_copy_loop \<equiv> [(R, 0), (R, 2),  (R, 3), (WB, 2),
+                 (R, 3), (R, 4), (WO, 5), (R, 4),
+                 (L, 6), (L, 5), (L, 6), (L, 1)]"
+
+definition 
+  tm_copy_end :: "instr list"
+  where
+    "tm_copy_end \<equiv> [(L, 0), (R, 2), (WO, 3), (L, 4),
+                (R, 2), (R, 2), (L, 5), (WB, 4),
+                (R, 0), (L, 5)]"
+
+definition 
+  tm_copy :: "instr list"
+  where
+    "tm_copy \<equiv> (tm_copy_begin |+| tm_copy_loop) |+| tm_copy_end"
+
+(* tm_copy_begin *)
+
+fun 
+  inv_begin0 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_begin1 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_begin2 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_begin3 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_begin4 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_begin0 n (l, r) = ((n > 1 \<and> (l, r) = (Oc \<up> (n - 2), [Oc, Oc, Bk, Oc])) \<or>   
+                          (n = 1 \<and> (l, r) = ([], [Bk, Oc, Bk, Oc])))"
+  | "inv_begin1 n (l, r) = ((l, r) = ([], Oc \<up> n))"
+  | "inv_begin2 n (l, r) = (\<exists> i j. i > 0 \<and> i + j = n \<and> (l, r) = (Oc \<up> i, Oc \<up> j))"
+  | "inv_begin3 n (l, r) = (n > 0 \<and> (l, tl r) = (Bk # Oc \<up> n, []))"
+  | "inv_begin4 n (l, r) = (n > 0 \<and> (l, r) = (Oc \<up> n, [Bk, Oc]) \<or> (l, r) = (Oc \<up> (n - 1), [Oc, Bk, Oc]))"
+
+fun inv_begin :: "nat \<Rightarrow> config \<Rightarrow> bool"
+  where
+    "inv_begin n (s, tap) = 
+        (if s = 0 then inv_begin0 n tap else
+         if s = 1 then inv_begin1 n tap else
+         if s = 2 then inv_begin2 n tap else
+         if s = 3 then inv_begin3 n tap else
+         if s = 4 then inv_begin4 n tap 
+         else False)"
+
+lemma inv_begin_step_E: "\<lbrakk>0 < i; 0 < j\<rbrakk> \<Longrightarrow> 
+  \<exists>ia>0. ia + j - Suc 0 = i + j \<and> Oc # Oc \<up> i = Oc \<up> ia"
+  by (rule_tac x = "Suc i" in exI, simp)
+
+lemma inv_begin_step: 
+  assumes "inv_begin n cf"
+    and "n > 0"
+  shows "inv_begin n (step0 cf tm_copy_begin)"
+  using assms
+  unfolding tm_copy_begin_def
+  apply(cases cf)
+  apply(auto simp: numeral_eqs_upto_12 split: if_splits elim:inv_begin_step_E)
+  apply(cases "hd (snd (snd cf))";cases "(snd (snd cf))",auto)
+  done
+
+lemma inv_begin_steps: 
+  assumes "inv_begin n cf"
+    and "n > 0"
+  shows "inv_begin n (steps0 cf tm_copy_begin stp)"
+  apply(induct stp)
+   apply(simp add: assms)
+  apply(auto simp del: steps.simps)
+  apply(rule_tac inv_begin_step)
+   apply(simp_all add: assms)
+  done
+
+lemma begin_partial_correctness:
+  assumes "is_final (steps0 (1, [], Oc \<up> n) tm_copy_begin stp)"
+  shows "0 < n \<Longrightarrow> \<lbrace>inv_begin1 n\<rbrace> tm_copy_begin \<lbrace>inv_begin0 n\<rbrace>"
+proof(rule_tac Hoare_haltI)
+  fix l r
+  assume h: "0 < n" "inv_begin1 n (l, r)"
+  have "inv_begin n (steps0 (1, [], Oc \<up> n) tm_copy_begin stp)"
+    using h by (rule_tac inv_begin_steps) (simp_all)
+  then show
+    "\<exists>stp. is_final (steps0 (1, l, r) tm_copy_begin stp) \<and> 
+    inv_begin0 n holds_for steps (1, l, r) (tm_copy_begin, 0) stp"
+    using h assms
+    apply(rule_tac x = stp in exI)
+    apply(case_tac "(steps0 (1, [], Oc \<up> n) tm_copy_begin stp)", simp)
+    done
+qed
+
+fun measure_begin_state :: "config \<Rightarrow> nat"
+  where
+    "measure_begin_state (s, l, r) = (if s = 0 then 0 else 5 - s)"
+
+fun measure_begin_step :: "config \<Rightarrow> nat"
+  where
+    "measure_begin_step (s, l, r) = 
+        (if s = 2 then length r else
+         if s = 3 then (if r = [] \<or> r = [Bk] then 1 else 0) else
+         if s = 4 then length l 
+         else 0)"
+
+definition
+  "measure_begin = measures [measure_begin_state, measure_begin_step]"
+
+lemma wf_measure_begin:
+  shows "wf measure_begin" 
+  unfolding measure_begin_def 
+  by auto
+
+lemma measure_begin_induct [case_names Step]: 
+  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_begin\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
+  using wf_measure_begin
+  by (metis wf_iff_no_infinite_down_chain)
+
+lemma begin_halts: 
+  assumes h: "x > 0"
+  shows "\<exists> stp. is_final (steps0 (1, [], Oc \<up> x) tm_copy_begin stp)"
+proof (induct rule: measure_begin_induct) 
+  case (Step n)
+  have "\<not> is_final (steps0 (1, [], Oc \<up> x) tm_copy_begin n)" by fact
+  moreover
+  have "inv_begin x (steps0 (1, [], Oc \<up> x) tm_copy_begin n)"
+    by (rule_tac inv_begin_steps) (simp_all add:  h)
+  moreover
+  obtain s l r where eq: "(steps0 (1, [], Oc \<up> x) tm_copy_begin n) = (s, l, r)"
+    by (metis measure_begin_state.cases)
+  ultimately 
+  have "(step0 (s, l, r) tm_copy_begin, s, l, r) \<in> measure_begin"
+    apply(auto simp: measure_begin_def tm_copy_begin_def numeral_eqs_upto_12 split: if_splits)
+    apply(subgoal_tac "r = [Oc]")
+     apply(auto)
+    by (metis cell.exhaust list.exhaust list.sel(3))
+  then 
+  show "(steps0 (1, [], Oc \<up> x) tm_copy_begin (Suc n), steps0 (1, [], Oc \<up> x) tm_copy_begin n) \<in> measure_begin"
+    using eq by (simp only: step_red)
+qed
+
+lemma begin_correct: 
+  shows "0 < n \<Longrightarrow> \<lbrace>inv_begin1 n\<rbrace> tm_copy_begin \<lbrace>inv_begin0 n\<rbrace>"
+  using begin_partial_correctness begin_halts by blast
+
+
+(* Delete some theorems from the simpset *)
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+
+(* tm_copy_loop *)
+
+fun 
+  inv_loop1_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop1_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop5_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop5_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop6_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop6_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_loop1_loop n (l, r) = (\<exists> i j. i + j + 1 = n \<and> (l, r) = (Oc\<up>i, Oc#Oc#Bk\<up>j @ Oc\<up>j) \<and> j > 0)"
+  | "inv_loop1_exit n (l, r) = (0 < n \<and> (l, r) = ([], Bk#Oc#Bk\<up>n @ Oc\<up>n))"
+  | "inv_loop5_loop x (l, r) = 
+     (\<exists> i j k t. i + j = Suc x \<and> i > 0 \<and> j > 0 \<and> k + t = j \<and> t > 0 \<and> (l, r) = (Oc\<up>k@Bk\<up>j@Oc\<up>i, Oc\<up>t))"
+  | "inv_loop5_exit x (l, r) = 
+     (\<exists> i j. i + j = Suc x \<and> i > 0 \<and> j > 0 \<and> (l, r) = (Bk\<up>(j - 1)@Oc\<up>i, Bk # Oc\<up>j))"
+  | "inv_loop6_loop x (l, r) = 
+     (\<exists> i j k t. i + j = Suc x \<and> i > 0 \<and> k + t + 1 = j \<and> (l, r) = (Bk\<up>k @ Oc\<up>i, Bk\<up>(Suc t) @ Oc\<up>j))"
+  | "inv_loop6_exit x (l, r) = 
+     (\<exists> i j. i + j = x \<and> j > 0 \<and> (l, r) = (Oc\<up>i, Oc#Bk\<up>j @ Oc\<up>j))"
+
+fun 
+  inv_loop0 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop1 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop2 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop3 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop4 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop5 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop6 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_loop0 n (l, r) =  (0 < n \<and> (l, r) = ([Bk], Oc # Bk\<up>n @ Oc\<up>n))"
+  | "inv_loop1 n (l, r) = (inv_loop1_loop n (l, r) \<or> inv_loop1_exit n (l, r))"
+  | "inv_loop2 n (l, r) = (\<exists> i j any. i + j = n \<and> n > 0 \<and> i > 0 \<and> j > 0 \<and> (l, r) = (Oc\<up>i, any#Bk\<up>j@Oc\<up>j))"
+  | "inv_loop3 n (l, r) = 
+     (\<exists> i j k t. i + j = n \<and> i > 0 \<and> j > 0 \<and>  k + t = Suc j \<and> (l, r) = (Bk\<up>k@Oc\<up>i, Bk\<up>t@Oc\<up>j))"
+  | "inv_loop4 n (l, r) = 
+     (\<exists> i j k t. i + j = n \<and> i > 0 \<and> j > 0 \<and>  k + t = j \<and> (l, r) = (Oc\<up>k @ Bk\<up>(Suc j)@Oc\<up>i, Oc\<up>t))"
+  | "inv_loop5 n (l, r) = (inv_loop5_loop n (l, r) \<or> inv_loop5_exit n (l, r))"
+  | "inv_loop6 n (l, r) = (inv_loop6_loop n (l, r) \<or> inv_loop6_exit n (l, r))"
+
+fun inv_loop :: "nat \<Rightarrow> config \<Rightarrow> bool"
+  where
+    "inv_loop x (s, l, r) = 
+         (if s = 0 then inv_loop0 x (l, r)
+          else if s = 1 then inv_loop1 x (l, r)
+          else if s = 2 then inv_loop2 x (l, r)
+          else if s = 3 then inv_loop3 x (l, r)
+          else if s = 4 then inv_loop4 x (l, r)
+          else if s = 5 then inv_loop5 x (l, r)
+          else if s = 6 then inv_loop6 x (l, r)
+          else False)"
+
+declare inv_loop.simps[simp del] inv_loop1.simps[simp del]
+  inv_loop2.simps[simp del] inv_loop3.simps[simp del] 
+  inv_loop4.simps[simp del] inv_loop5.simps[simp del] 
+  inv_loop6.simps[simp del]
+
+lemma inv_loop3_Bk_empty_via_2[elim]: "\<lbrakk>0 < x; inv_loop2 x (b, [])\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, [])"
+  by (auto simp: inv_loop2.simps inv_loop3.simps)
+
+lemma inv_loop3_Bk_empty[elim]: "\<lbrakk>0 < x; inv_loop3 x (b, [])\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, [])"
+  by (auto simp: inv_loop3.simps)
+
+lemma inv_loop5_Oc_empty_via_4[elim]: "\<lbrakk>0 < x; inv_loop4 x (b, [])\<rbrakk> \<Longrightarrow> inv_loop5 x (b, [Oc])"
+  by(auto simp: inv_loop4.simps inv_loop5.simps;force)
+
+lemma inv_loop1_Bk[elim]: "\<lbrakk>0 < x; inv_loop1 x (b, Bk # list)\<rbrakk> \<Longrightarrow> list = Oc # Bk \<up> x @ Oc \<up> x"
+  by (auto simp: inv_loop1.simps)
+
+lemma inv_loop3_Bk_via_2[elim]: "\<lbrakk>0 < x; inv_loop2 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, list)"
+  by(auto simp: inv_loop2.simps inv_loop3.simps;force)
+
+lemma inv_loop3_Bk_move[elim]: "\<lbrakk>0 < x; inv_loop3 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, list)"
+  apply(auto simp: inv_loop3.simps)
+   apply (rename_tac i j k t)
+   apply(rule_tac [!] x = i in exI, 
+      rule_tac [!] x = j in exI, simp_all)
+   apply(case_tac [!] t, auto)
+  done
+
+lemma inv_loop5_Oc_via_4_Bk[elim]: "\<lbrakk>0 < x; inv_loop4 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_loop5 x (b, Oc # list)"
+  by (auto simp: inv_loop4.simps inv_loop5.simps)
+
+lemma inv_loop6_Bk_via_5[elim]: "\<lbrakk>0 < x; inv_loop5 x ([], Bk # list)\<rbrakk> \<Longrightarrow> inv_loop6 x ([], Bk # Bk # list)"
+  by (auto simp: inv_loop6.simps inv_loop5.simps)
+
+lemma inv_loop5_loop_no_Bk[simp]: "inv_loop5_loop x (b, Bk # list) = False"
+  by (auto simp: inv_loop5.simps)
+
+lemma inv_loop6_exit_no_Bk[simp]: "inv_loop6_exit x (b, Bk # list) = False"
+  by (auto simp: inv_loop6.simps)
+
+declare inv_loop5_loop.simps[simp del]  inv_loop5_exit.simps[simp del]
+  inv_loop6_loop.simps[simp del]  inv_loop6_exit.simps[simp del]
+
+lemma inv_loop6_loopBk_via_5[elim]:"\<lbrakk>0 < x; inv_loop5_exit x (b, Bk # list); b \<noteq> []; hd b = Bk\<rbrakk> 
+          \<Longrightarrow> inv_loop6_loop x (tl b, Bk # Bk # list)"
+  apply(simp only: inv_loop5_exit.simps inv_loop6_loop.simps )
+  apply(erule_tac exE)+
+  apply(rename_tac i j)
+  apply(rule_tac x = i in exI, 
+      rule_tac x = j in exI,
+      rule_tac x = "j - Suc (Suc 0)" in exI, 
+      rule_tac x = "Suc 0" in exI, auto)
+   apply(case_tac [!] j, simp_all)
+   apply(case_tac [!] "j-1", simp_all)
+  done
+
+lemma inv_loop6_loop_no_Oc_Bk[simp]: "inv_loop6_loop x (b, Oc # Bk # list) = False"
+  by (auto simp: inv_loop6_loop.simps)
+
+lemma inv_loop6_exit_Oc_Bk_via_5[elim]: "\<lbrakk>x > 0; inv_loop5_exit x (b, Bk # list); b \<noteq> []; hd b = Oc\<rbrakk> \<Longrightarrow> 
+  inv_loop6_exit x (tl b, Oc # Bk # list)"
+  apply(simp only: inv_loop5_exit.simps inv_loop6_exit.simps)
+  apply(erule_tac exE)+
+  apply(rule_tac x = "x - 1" in exI, rule_tac x = 1 in exI, simp)
+  apply(rename_tac i j)
+  apply(case_tac j;case_tac "j-1", auto)
+  done
+
+lemma inv_loop6_Bk_tail_via_5[elim]: "\<lbrakk>0 < x; inv_loop5 x (b, Bk # list); b \<noteq> []\<rbrakk> \<Longrightarrow> inv_loop6 x (tl b, hd b # Bk # list)"
+  apply(simp add: inv_loop5.simps inv_loop6.simps)
+  apply(cases "hd b", simp_all, auto)
+  done
+
+lemma inv_loop6_loop_Bk_Bk_drop[elim]: "\<lbrakk>0 < x; inv_loop6_loop x (b, Bk # list); b \<noteq> []; hd b = Bk\<rbrakk>
+              \<Longrightarrow> inv_loop6_loop x (tl b, Bk # Bk # list)"
+  apply(simp only: inv_loop6_loop.simps)
+  apply(erule_tac exE)+
+  apply(rename_tac i j k t)
+  apply(rule_tac x = i in exI, rule_tac x = j in exI, 
+      rule_tac x = "k - 1" in exI, rule_tac x = "Suc t" in exI, auto)
+   apply(case_tac [!] k, auto)
+  done
+
+lemma inv_loop6_exit_Oc_Bk_via_loop6[elim]: "\<lbrakk>0 < x; inv_loop6_loop x (b, Bk # list); b \<noteq> []; hd b = Oc\<rbrakk> 
+        \<Longrightarrow> inv_loop6_exit x (tl b, Oc # Bk # list)"
+  apply(simp only: inv_loop6_loop.simps inv_loop6_exit.simps)
+  apply(erule_tac exE)+
+  apply(rename_tac i j k t)
+  apply(rule_tac x = "i - 1" in exI, rule_tac x = j in exI, auto)
+   apply(case_tac [!] k, auto)
+  done
+
+lemma inv_loop6_Bk_tail[elim]: "\<lbrakk>0 < x; inv_loop6 x (b, Bk # list); b \<noteq> []\<rbrakk> \<Longrightarrow> inv_loop6 x (tl b, hd b # Bk # list)"
+  apply(simp add: inv_loop6.simps)
+  apply(case_tac "hd b", simp_all, auto)
+  done
+
+lemma inv_loop2_Oc_via_1[elim]: "\<lbrakk>0 < x; inv_loop1 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_loop2 x (Oc # b, list)"
+  apply(auto simp: inv_loop1.simps inv_loop2.simps,force)
+  done
+
+lemma inv_loop2_Bk_via_Oc[elim]: "\<lbrakk>0 < x; inv_loop2 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_loop2 x (b, Bk # list)"
+  by (auto simp: inv_loop2.simps)
+
+lemma inv_loop4_Oc_via_3[elim]: "\<lbrakk>0 < x; inv_loop3 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_loop4 x (Oc # b, list)"
+  apply(auto simp: inv_loop3.simps inv_loop4.simps)
+   apply(rename_tac i j)
+   apply(rule_tac [!] x = i in exI, auto)
+   apply(rule_tac [!] x = "Suc 0" in exI, rule_tac [!] x = "j - 1" in exI)
+   apply(case_tac [!] j, auto)
+  done
+
+lemma inv_loop4_Oc_move[elim]:
+  assumes "0 < x" "inv_loop4 x (b, Oc # list)"
+  shows "inv_loop4 x (Oc # b, list)"
+proof -
+  from assms[unfolded inv_loop4.simps] obtain i j k t where
+    "i + j = x"
+    "0 < i" "0 < j" "k + t = j" "(b, Oc # list) = (Oc \<up> k @ Bk \<up> Suc j @ Oc \<up> i, Oc \<up> t)"
+    by auto  
+  thus ?thesis unfolding inv_loop4.simps
+    apply(rule_tac [!] x = "i" in exI,rule_tac [!] x = "j" in exI)
+    apply(rule_tac [!] x = "Suc k" in exI,rule_tac [!] x = "t - 1" in exI)
+    by(cases t,auto)
+qed
+
+lemma inv_loop5_exit_no_Oc[simp]: "inv_loop5_exit x (b, Oc # list) = False"
+  by (auto simp: inv_loop5_exit.simps)
+
+lemma inv_loop5_exit_Bk_Oc_via_loop[elim]: " \<lbrakk>inv_loop5_loop x (b, Oc # list); b \<noteq> []; hd b = Bk\<rbrakk>
+  \<Longrightarrow> inv_loop5_exit x (tl b, Bk # Oc # list)"
+  apply(simp only: inv_loop5_loop.simps inv_loop5_exit.simps)
+  apply(erule_tac exE)+
+  apply(rename_tac i j k t)
+  apply(rule_tac x = i in exI)
+  apply(case_tac k, auto)
+  done
+
+lemma inv_loop5_loop_Oc_Oc_drop[elim]: "\<lbrakk>inv_loop5_loop x (b, Oc # list); b \<noteq> []; hd b = Oc\<rbrakk> 
+           \<Longrightarrow> inv_loop5_loop x (tl b, Oc # Oc # list)"
+  apply(simp only:  inv_loop5_loop.simps)
+  apply(erule_tac exE)+
+  apply(rename_tac i j k t)
+  apply(rule_tac x = i in exI, rule_tac x = j in exI)
+  apply(rule_tac x = "k - 1" in exI, rule_tac x = "Suc t" in exI)
+  apply(case_tac k, auto)
+  done
+
+lemma inv_loop5_Oc_tl[elim]: "\<lbrakk>inv_loop5 x (b, Oc # list); b \<noteq> []\<rbrakk> \<Longrightarrow> inv_loop5 x (tl b, hd b # Oc # list)"
+  apply(simp add: inv_loop5.simps)
+  apply(cases "hd b", simp_all, auto)
+  done
+
+lemma inv_loop1_Bk_Oc_via_6[elim]: "\<lbrakk>0 < x; inv_loop6 x ([], Oc # list)\<rbrakk> \<Longrightarrow> inv_loop1 x ([], Bk # Oc # list)"
+  by(auto simp: inv_loop6.simps inv_loop1.simps inv_loop6_loop.simps inv_loop6_exit.simps)
+
+lemma inv_loop1_Oc_via_6[elim]: "\<lbrakk>0 < x; inv_loop6 x (b, Oc # list); b \<noteq> []\<rbrakk> 
+           \<Longrightarrow> inv_loop1 x (tl b, hd b # Oc # list)"
+  by(auto simp: inv_loop6.simps inv_loop1.simps inv_loop6_loop.simps inv_loop6_exit.simps)
+
+
+lemma inv_loop_nonempty[simp]:
+  "inv_loop1 x (b, []) = False"
+  "inv_loop2 x ([], b) = False"
+  "inv_loop2 x (l', []) = False"
+  "inv_loop3 x (b, []) = False"
+  "inv_loop4 x ([], b) = False"
+  "inv_loop5 x ([], list) = False"
+  "inv_loop6 x ([], Bk # xs) = False"
+  by (auto simp: inv_loop1.simps inv_loop2.simps inv_loop3.simps inv_loop4.simps 
+      inv_loop5.simps inv_loop6.simps inv_loop5_exit.simps inv_loop5_loop.simps
+      inv_loop6_loop.simps)
+
+lemma inv_loop_nonemptyE[elim]:
+  "\<lbrakk>inv_loop5 x (b, [])\<rbrakk> \<Longrightarrow> RR" "inv_loop6 x (b, []) \<Longrightarrow> RR" 
+  "\<lbrakk>inv_loop1 x (b, Bk # list)\<rbrakk> \<Longrightarrow> b = []"
+  by (auto simp: inv_loop4.simps inv_loop5.simps inv_loop5_exit.simps inv_loop5_loop.simps
+      inv_loop6.simps inv_loop6_exit.simps inv_loop6_loop.simps inv_loop1.simps)
+
+lemma inv_loop6_Bk_Bk_drop[elim]: "\<lbrakk>inv_loop6 x ([], Bk # list)\<rbrakk> \<Longrightarrow> inv_loop6 x ([], Bk # Bk # list)"
+  by (simp)
+
+lemma inv_loop_step: 
+  "\<lbrakk>inv_loop x cf; x > 0\<rbrakk> \<Longrightarrow> inv_loop x (step cf (tm_copy_loop, 0))"
+  apply(cases cf, cases "snd (snd cf)"; cases "hd (snd (snd cf))")
+     apply(auto simp: inv_loop.simps step.simps tm_copy_loop_def numeral_eqs_upto_12 split: if_splits)
+  done
+
+lemma inv_loop_steps:
+  "\<lbrakk>inv_loop x cf; x > 0\<rbrakk> \<Longrightarrow> inv_loop x (steps cf (tm_copy_loop, 0) stp)"
+  apply(induct stp, simp add: steps.simps, simp)
+  apply(erule_tac inv_loop_step, simp)
+  done
+
+fun loop_stage :: "config \<Rightarrow> nat"
+  where
+    "loop_stage (s, l, r) = (if s = 0 then 0
+                           else (Suc (length (takeWhile (\<lambda>a. a = Oc) (rev l @ r)))))"
+
+fun loop_state :: "config \<Rightarrow> nat"
+  where
+    "loop_state (s, l, r) = (if s = 2 \<and> hd r = Oc then 0
+                           else if s = 1 then 1
+                           else 10 - s)"
+
+fun loop_step :: "config \<Rightarrow> nat"
+  where
+    "loop_step (s, l, r) = (if s = 3 then length r
+                          else if s = 4 then length r
+                          else if s = 5 then length l 
+                          else if s = 6 then length l
+                          else 0)"
+
+definition measure_loop :: "(config \<times> config) set"
+  where
+    "measure_loop = measures [loop_stage, loop_state, loop_step]"
+
+lemma wf_measure_loop: "wf measure_loop"
+  unfolding measure_loop_def
+  by (auto)
+
+lemma measure_loop_induct [case_names Step]: 
+  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_loop\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
+  using wf_measure_loop
+  by (metis wf_iff_no_infinite_down_chain)
+
+lemma inv_loop4_not_just_Oc[elim]: 
+  "\<lbrakk>inv_loop4 x (l', []);
+  length (takeWhile (\<lambda>a. a = Oc) (rev l' @ [Oc])) \<noteq> 
+  length (takeWhile (\<lambda>a. a = Oc) (rev l'))\<rbrakk>
+  \<Longrightarrow> RR"
+  "\<lbrakk>inv_loop4 x (l', Bk # list);
+   length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Oc # list)) \<noteq> 
+    length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Bk # list))\<rbrakk>
+    \<Longrightarrow> RR"
+   apply(auto simp: inv_loop4.simps)
+  apply(rename_tac i j)
+  apply(case_tac [!] j, simp_all add: List.takeWhile_tail)
+  done
+
+lemma takeWhile_replicate_append: 
+  "P a \<Longrightarrow> takeWhile P (a\<up>x @ ys) = a\<up>x @ takeWhile P ys"
+  by (induct x, auto)
+
+lemma takeWhile_replicate: 
+  "P a \<Longrightarrow> takeWhile P (a\<up>x) = a\<up>x"
+  by (induct x, auto)
+
+lemma inv_loop5_Bk_E[elim]: 
+  "\<lbrakk>inv_loop5 x (l', Bk # list); l' \<noteq> []; 
+   length (takeWhile (\<lambda>a. a = Oc) (rev (tl l') @ hd l' # Bk # list)) \<noteq>
+   length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Bk # list))\<rbrakk>
+   \<Longrightarrow> RR"
+  apply(cases "length list";cases "length list - 1"
+      ,auto simp: inv_loop5.simps inv_loop5_exit.simps
+      takeWhile_replicate_append takeWhile_replicate)
+   apply(cases "length list - 2"; force simp add: List.takeWhile_tail)+
+  done
+
+lemma inv_loop1_hd_Oc[elim]: "\<lbrakk>inv_loop1 x (l', Oc # list)\<rbrakk> \<Longrightarrow> hd list = Oc"
+  by (auto simp: inv_loop1.simps)
+
+lemma inv_loop6_not_just_Bk[dest!]: 
+  "\<lbrakk>length (takeWhile P (rev (tl l') @ hd l' # list)) \<noteq> 
+  length (takeWhile P (rev l' @ list))\<rbrakk>
+  \<Longrightarrow> l' = []"
+  apply(cases l', simp_all)
+  done
+
+lemma inv_loop2_OcE[elim]:
+  "\<lbrakk>inv_loop2 x (l', Oc # list); l' \<noteq> []\<rbrakk> \<Longrightarrow> 
+  length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Bk # list)) <
+  length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Oc # list))"
+  apply(auto simp: inv_loop2.simps takeWhile_tail takeWhile_replicate_append
+      takeWhile_replicate)
+  done
+
+lemma loop_halts: 
+  assumes h: "n > 0" "inv_loop n (1, l, r)"
+  shows "\<exists> stp. is_final (steps0 (1, l, r) tm_copy_loop stp)"
+proof (induct rule: measure_loop_induct) 
+  case (Step stp)
+  have "\<not> is_final (steps0 (1, l, r) tm_copy_loop stp)" by fact
+  moreover
+  have "inv_loop n (steps0 (1, l, r) tm_copy_loop stp)"
+    by (rule_tac inv_loop_steps) (simp_all only: h)
+  moreover
+  obtain s l' r' where eq: "(steps0 (1, l, r) tm_copy_loop stp) = (s, l', r')"
+    by (metis measure_begin_state.cases)
+  ultimately 
+  have "(step0 (s, l', r') tm_copy_loop, s, l', r') \<in> measure_loop"
+    using h(1)
+    apply(cases r';cases "hd r'")
+    apply(auto simp: inv_loop.simps step.simps tm_copy_loop_def numeral_eqs_upto_12 measure_loop_def split: if_splits)
+    done
+  then 
+  show "(steps0 (1, l, r) tm_copy_loop (Suc stp), steps0 (1, l, r) tm_copy_loop stp) \<in> measure_loop"
+    using eq by (simp only: step_red)
+qed
+
+lemma loop_correct:
+  assumes "0 < n"
+  shows "\<lbrace>inv_loop1 n\<rbrace> tm_copy_loop \<lbrace>inv_loop0 n\<rbrace>"
+  using assms
+proof(rule_tac Hoare_haltI)
+  fix l r
+  assume h: "0 < n" "inv_loop1 n (l, r)"
+  then obtain stp where k: "is_final (steps0 (1, l, r) tm_copy_loop stp)" 
+    using loop_halts
+    apply(simp add: inv_loop.simps)
+    apply(blast)
+    done
+  moreover
+  have "inv_loop n (steps0 (1, l, r) tm_copy_loop stp)"
+    using h 
+    by (rule_tac inv_loop_steps) (simp_all add: inv_loop.simps)
+  ultimately show
+    "\<exists>stp. is_final (steps0 (1, l, r) tm_copy_loop stp) \<and> 
+    inv_loop0 n holds_for steps0 (1, l, r) tm_copy_loop stp"
+    using h(1) 
+    apply(rule_tac x = stp in exI)
+    apply(case_tac "(steps0 (1, l, r) tm_copy_loop stp)")
+    apply(simp add: inv_loop.simps)
+    done
+qed
+
+(* tm_copy_end *)
+
+fun
+  inv_end5_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_end5_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool" 
+  where  
+    "inv_end5_loop x (l, r) = 
+     (\<exists> i j. i + j = x \<and> x > 0 \<and> j > 0 \<and> l = Oc\<up>i @ [Bk] \<and> r = Oc\<up>j @ Bk # Oc\<up>x)"
+  | "inv_end5_exit x (l, r) = (x > 0 \<and> l = [] \<and> r = Bk # Oc\<up>x @ Bk # Oc\<up>x)"
+
+fun 
+  inv_end0 :: "nat \<Rightarrow> tape \<Rightarrow>  bool" and
+  inv_end1 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_end2 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_end3 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_end4 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and 
+  inv_end5 :: "nat \<Rightarrow> tape \<Rightarrow> bool" 
+  where
+    "inv_end0 n (l, r) = (n > 0 \<and> (l, r) = ([Bk], Oc\<up>n @ Bk # Oc\<up>n))"
+  | "inv_end1 n (l, r) = (n > 0 \<and> (l, r) = ([Bk], Oc # Bk\<up>n @ Oc\<up>n))"
+  | "inv_end2 n (l, r) = (\<exists> i j. i + j = Suc n \<and> n > 0 \<and> l = Oc\<up>i @ [Bk] \<and> r = Bk\<up>j @ Oc\<up>n)"
+  | "inv_end3 n (l, r) =
+     (\<exists> i j. n > 0 \<and> i + j = n \<and> l = Oc\<up>i @ [Bk] \<and> r = Oc # Bk\<up>j@ Oc\<up>n)"
+  | "inv_end4 n (l, r) = (\<exists> any. n > 0 \<and> l = Oc\<up>n @ [Bk] \<and> r = any#Oc\<up>n)"
+  | "inv_end5 n (l, r) = (inv_end5_loop n (l, r) \<or> inv_end5_exit n (l, r))"
+
+fun 
+  inv_end :: "nat \<Rightarrow> config \<Rightarrow> bool"
+  where
+    "inv_end n (s, l, r) = (if s = 0 then inv_end0 n (l, r)
+                          else if s = 1 then inv_end1 n (l, r)
+                          else if s = 2 then inv_end2 n (l, r)
+                          else if s = 3 then inv_end3 n (l, r)
+                          else if s = 4 then inv_end4 n (l, r)
+                          else if s = 5 then inv_end5 n (l, r)
+                          else False)"
+
+declare inv_end.simps[simp del] inv_end1.simps[simp del]
+  inv_end0.simps[simp del] inv_end2.simps[simp del]
+  inv_end3.simps[simp del] inv_end4.simps[simp del]
+  inv_end5.simps[simp del]
+
+lemma inv_end_nonempty[simp]:
+  "inv_end1 x (b, []) = False"
+  "inv_end1 x ([], list) = False"
+  "inv_end2 x (b, []) = False"
+  "inv_end3 x (b, []) = False"
+  "inv_end4 x (b, []) = False"
+  "inv_end5 x (b, []) = False"
+  "inv_end5 x ([], Oc # list) = False"
+  by (auto simp: inv_end1.simps inv_end2.simps inv_end3.simps inv_end4.simps inv_end5.simps)
+
+lemma inv_end0_Bk_via_1[elim]: "\<lbrakk>0 < x; inv_end1 x (b, Bk # list); b \<noteq> []\<rbrakk>
+  \<Longrightarrow> inv_end0 x (tl b, hd b # Bk # list)"
+  by (auto simp: inv_end1.simps inv_end0.simps)
+
+lemma inv_end3_Oc_via_2[elim]: "\<lbrakk>0 < x; inv_end2 x (b, Bk # list)\<rbrakk> 
+  \<Longrightarrow> inv_end3 x (b, Oc # list)"
+  apply(auto simp: inv_end2.simps inv_end3.simps)
+  by (metis Cons_replicate_eq One_nat_def Suc_inject Suc_pred add_Suc_right cell.distinct(1)
+      empty_replicate list.sel(3) neq0_conv self_append_conv2 tl_append2 tl_replicate)
+
+lemma inv_end2_Bk_via_3[elim]: "\<lbrakk>0 < x; inv_end3 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_end2 x (Bk # b, list)"
+  by (auto simp: inv_end2.simps inv_end3.simps)
+
+lemma inv_end5_Bk_via_4[elim]: "\<lbrakk>0 < x; inv_end4 x ([], Bk # list)\<rbrakk> \<Longrightarrow> 
+  inv_end5 x ([], Bk # Bk # list)"
+  by (auto simp: inv_end4.simps inv_end5.simps)
+
+lemma inv_end5_Bk_tail_via_4[elim]: "\<lbrakk>0 < x; inv_end4 x (b, Bk # list); b \<noteq> []\<rbrakk> \<Longrightarrow> 
+  inv_end5 x (tl b, hd b # Bk # list)"
+  apply(auto simp: inv_end4.simps inv_end5.simps)
+  apply(rule_tac x = 1 in exI, simp)
+  done
+
+lemma inv_end0_Bk_via_5[elim]: "\<lbrakk>0 < x; inv_end5 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_end0 x (Bk # b, list)"
+  by(auto simp: inv_end5.simps inv_end0.simps gr0_conv_Suc)
+
+lemma inv_end2_Oc_via_1[elim]: "\<lbrakk>0 < x; inv_end1 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_end2 x (Oc # b, list)"
+  by (auto simp: inv_end1.simps inv_end2.simps)
+
+lemma inv_end4_Bk_Oc_via_2[elim]: "\<lbrakk>0 < x; inv_end2 x ([], Oc # list)\<rbrakk> \<Longrightarrow>
+               inv_end4 x ([], Bk # Oc # list)"
+  by (auto simp: inv_end2.simps inv_end4.simps)
+
+lemma inv_end4_Oc_via_2[elim]:  "\<lbrakk>0 < x; inv_end2 x (b, Oc # list); b \<noteq> []\<rbrakk> \<Longrightarrow>
+  inv_end4 x (tl b, hd b # Oc # list)"
+  by(auto simp: inv_end2.simps inv_end4.simps gr0_conv_Suc)
+
+lemma inv_end2_Oc_via_3[elim]: "\<lbrakk>0 < x; inv_end3 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_end2 x (Oc # b, list)"
+  by (auto simp: inv_end2.simps inv_end3.simps)
+
+lemma inv_end4_Bk_via_Oc[elim]: "\<lbrakk>0 < x; inv_end4 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_end4 x (b, Bk # list)"
+  by (auto simp: inv_end2.simps inv_end4.simps)
+
+lemma inv_end5_Bk_drop_Oc[elim]: "\<lbrakk>0 < x; inv_end5 x ([], Oc # list)\<rbrakk> \<Longrightarrow> inv_end5 x ([], Bk # Oc # list)"
+  by (auto simp: inv_end2.simps inv_end5.simps)
+
+declare inv_end5_loop.simps[simp del]
+  inv_end5_exit.simps[simp del]
+
+lemma inv_end5_exit_no_Oc[simp]: "inv_end5_exit x (b, Oc # list) = False"
+  by (auto simp: inv_end5_exit.simps)
+
+lemma inv_end5_loop_no_Bk_Oc[simp]: "inv_end5_loop x (tl b, Bk # Oc # list) = False"
+  by (auto simp: inv_end5_loop.simps)
+
+lemma inv_end5_exit_Bk_Oc_via_loop[elim]:
+  "\<lbrakk>0 < x; inv_end5_loop x (b, Oc # list); b \<noteq> []; hd b = Bk\<rbrakk> \<Longrightarrow>
+  inv_end5_exit x (tl b, Bk # Oc # list)"
+  apply(auto simp: inv_end5_loop.simps inv_end5_exit.simps)
+  using hd_replicate apply fastforce
+  by (metis cell.distinct(1) hd_append2 hd_replicate list.sel(3) self_append_conv2
+      split_head_repeat(2))
+
+lemma inv_end5_loop_Oc_Oc_drop[elim]: 
+  "\<lbrakk>0 < x; inv_end5_loop x (b, Oc # list); b \<noteq> []; hd b = Oc\<rbrakk> \<Longrightarrow>
+  inv_end5_loop x (tl b, Oc # Oc # list)"
+  apply(simp only: inv_end5_loop.simps inv_end5_exit.simps)
+  apply(erule_tac exE)+
+  apply(rename_tac i j)
+  apply(rule_tac x = "i - 1" in exI, 
+      rule_tac x = "Suc j" in exI, auto)
+   apply(case_tac [!] i, simp_all)
+  done
+
+lemma inv_end5_Oc_tail[elim]: "\<lbrakk>0 < x; inv_end5 x (b, Oc # list); b \<noteq> []\<rbrakk> \<Longrightarrow> 
+  inv_end5 x (tl b, hd b # Oc # list)"
+  apply(simp add: inv_end2.simps inv_end5.simps)
+  apply(case_tac "hd b", simp_all, auto)
+  done
+
+lemma inv_end_step:
+  "\<lbrakk>x > 0; inv_end x cf\<rbrakk> \<Longrightarrow> inv_end x (step cf (tm_copy_end, 0))"
+  apply(cases cf, cases "snd (snd cf)"; cases "hd (snd (snd cf))")
+     apply(auto simp: inv_end.simps step.simps tm_copy_end_def numeral_eqs_upto_12 split: if_splits)
+  done
+
+lemma inv_end_steps:
+  "\<lbrakk>x > 0; inv_end x cf\<rbrakk> \<Longrightarrow> inv_end x (steps cf (tm_copy_end, 0) stp)"
+  apply(induct stp, simp add:steps.simps, simp)
+  apply(erule_tac inv_end_step, simp)
+  done
+
+fun end_state :: "config \<Rightarrow> nat"
+  where
+    "end_state (s, l, r) = 
+       (if s = 0 then 0
+        else if s = 1 then 5
+        else if s = 2 \<or> s = 3 then 4
+        else if s = 4 then 3 
+        else if s = 5 then 2
+        else 0)"
+
+fun end_stage :: "config \<Rightarrow> nat"
+  where
+    "end_stage (s, l, r) = 
+          (if s = 2 \<or> s = 3 then (length r) else 0)"
+
+fun end_step :: "config \<Rightarrow> nat"
+  where
+    "end_step (s, l, r) = 
+         (if s = 4 then (if hd r = Oc then 1 else 0)
+          else if s = 5 then length l
+          else if s = 2 then 1
+          else if s = 3 then 0
+          else 0)"
+
+definition end_LE :: "(config \<times> config) set"
+  where
+    "end_LE = measures [end_state, end_stage, end_step]"
+
+lemma wf_end_le: "wf end_LE"
+  unfolding end_LE_def by auto
+
+lemma end_halt: 
+  "\<lbrakk>x > 0; inv_end x (Suc 0, l, r)\<rbrakk> \<Longrightarrow> 
+      \<exists> stp. is_final (steps (Suc 0, l, r) (tm_copy_end, 0) stp)"
+proof(rule halt_lemma[OF wf_end_le])
+  assume great: "0 < x"
+    and inv_start: "inv_end x (Suc 0, l, r)"
+  show "\<forall>n. \<not> is_final (steps (Suc 0, l, r) (tm_copy_end, 0) n) \<longrightarrow> 
+    (steps (Suc 0, l, r) (tm_copy_end, 0) (Suc n), steps (Suc 0, l, r) (tm_copy_end, 0) n) \<in> end_LE"
+  proof(rule_tac allI, rule_tac impI)
+    fix n
+    assume notfinal: "\<not> is_final (steps (Suc 0, l, r) (tm_copy_end, 0) n)"
+    obtain s' l' r' where d: "steps (Suc 0, l, r) (tm_copy_end, 0) n = (s', l', r')"
+      apply(case_tac "steps (Suc 0, l, r) (tm_copy_end, 0) n", auto)
+      done
+    hence "inv_end x (s', l', r') \<and> s' \<noteq> 0"
+      using great inv_start notfinal
+      apply(drule_tac stp = n in inv_end_steps, auto)
+      done
+    hence "(step (s', l', r') (tm_copy_end, 0), s', l', r') \<in> end_LE"
+      apply(cases r'; cases "hd r'")
+         apply(auto simp: inv_end.simps step.simps tm_copy_end_def numeral_eqs_upto_12 end_LE_def split: if_splits)
+      done
+    thus "(steps (Suc 0, l, r) (tm_copy_end, 0) (Suc n), 
+      steps (Suc 0, l, r) (tm_copy_end, 0) n) \<in> end_LE"
+      using d
+      by simp
+  qed
+qed
+
+lemma end_correct:
+  "n > 0 \<Longrightarrow> \<lbrace>inv_end1 n\<rbrace> tm_copy_end \<lbrace>inv_end0 n\<rbrace>"
+proof(rule_tac Hoare_haltI)
+  fix l r
+  assume h: "0 < n"
+    "inv_end1 n (l, r)"
+  then have "\<exists> stp. is_final (steps0 (1, l, r) tm_copy_end stp)"
+    by (simp add: end_halt inv_end.simps)
+  then obtain stp where "is_final (steps0 (1, l, r) tm_copy_end stp)" ..
+  moreover have "inv_end n (steps0 (1, l, r) tm_copy_end stp)"
+    apply(rule_tac inv_end_steps)
+    using h by(simp_all add: inv_end.simps)
+  ultimately show
+    "\<exists>stp. is_final (steps (1, l, r) (tm_copy_end, 0) stp) \<and> 
+    inv_end0 n holds_for steps (1, l, r) (tm_copy_end, 0) stp"        
+    using h
+    apply(rule_tac x = stp in exI)
+    apply(cases "(steps0 (1, l, r) tm_copy_end stp)") 
+    apply(simp add: inv_end.simps)
+    done
+qed
+
+(* tm_copy *)
+
+
+(* The tm_copy machine and all of its parts are composable
+ * (in the old terminologies: well-formed)
+ *)
+
+lemma [intro]:
+  "composable_tm (tm_copy_begin, 0)"
+  "composable_tm (tm_copy_loop, 0)"
+  "composable_tm (tm_copy_end, 0)"
+  by (auto simp: composable_tm.simps tm_copy_end_def tm_copy_loop_def tm_copy_begin_def)
+
+lemma composable_tm0_tm_copy[intro, simp]: "composable_tm0 tm_copy"
+  by (auto simp: tm_copy_def)
+
+lemma tm_copy_correct1: 
+  assumes "0 < x"
+  shows "\<lbrace>inv_begin1 x\<rbrace> tm_copy \<lbrace>inv_end0 x\<rbrace>"
+proof -
+  have "\<lbrace>inv_begin1 x\<rbrace> tm_copy_begin \<lbrace>inv_begin0 x\<rbrace>"
+    by (metis assms begin_correct) 
+  moreover 
+  have "inv_begin0 x \<mapsto> inv_loop1 x"
+    unfolding assert_imp_def
+    unfolding inv_begin0.simps inv_loop1.simps
+    unfolding inv_loop1_loop.simps inv_loop1_exit.simps
+    apply(auto simp add: numeral_eqs_upto_12 Cons_eq_append_conv)
+    by (rule_tac x = "Suc 0" in exI, auto)
+  ultimately have "\<lbrace>inv_begin1 x\<rbrace> tm_copy_begin \<lbrace>inv_loop1 x\<rbrace>"
+    by (rule_tac Hoare_consequence) (auto)
+  moreover
+  have "\<lbrace>inv_loop1 x\<rbrace> tm_copy_loop \<lbrace>inv_loop0 x\<rbrace>"
+    by (metis assms loop_correct) 
+  ultimately 
+  have "\<lbrace>inv_begin1 x\<rbrace> (tm_copy_begin |+| tm_copy_loop) \<lbrace>inv_loop0 x\<rbrace>"
+    by (rule_tac Hoare_plus_halt) (auto)
+  moreover 
+  have "\<lbrace>inv_end1 x\<rbrace> tm_copy_end \<lbrace>inv_end0 x\<rbrace>"
+    by (metis assms end_correct) 
+  moreover 
+  have "inv_loop0 x = inv_end1 x"
+    by(auto simp: inv_end1.simps inv_loop1.simps assert_imp_def)
+  ultimately 
+  show "\<lbrace>inv_begin1 x\<rbrace> tm_copy \<lbrace>inv_end0 x\<rbrace>"
+    unfolding tm_copy_def
+    by (rule_tac Hoare_plus_halt) (auto)
+qed
+
+abbreviation (input)
+  "pre_tm_copy n \<equiv> \<lambda>tap. tap = ([]::cell list, Oc \<up> (Suc n))"
+abbreviation (input)
+  "post_tm_copy n \<equiv> \<lambda>tap. tap= ([Bk], <(n, n::nat)>)"
+
+lemma tm_copy_correct:
+  shows "\<lbrace>pre_tm_copy n\<rbrace> tm_copy \<lbrace>post_tm_copy n\<rbrace>"
+proof -
+  have "\<lbrace>inv_begin1 (Suc n)\<rbrace> tm_copy \<lbrace>inv_end0 (Suc n)\<rbrace>"
+    by (rule tm_copy_correct1) (simp)
+  moreover
+  have "pre_tm_copy n = inv_begin1 (Suc n)"
+    by (auto)
+  moreover
+  have "inv_end0 (Suc n) = post_tm_copy n"
+    unfolding fun_eq_iff
+    by (auto simp add: inv_end0.simps tape_of_nat_def tape_of_prod_def)
+  ultimately
+  show "\<lbrace>pre_tm_copy n\<rbrace> tm_copy \<lbrace>post_tm_copy n\<rbrace>" 
+    by simp
+qed
+
+end
diff --git a/thys/Universal_Turing_Machine/DitherTM.thy b/thys/Universal_Turing_Machine/DitherTM.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/DitherTM.thy
@@ -0,0 +1,179 @@
+(* Title: thys/DitherTM.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+ 
+   Further contributions by Franz Regensburger (FABR) 02/2022 :
+   * Re-ordering of sections;
+     Now, the dithering machine is discussed before the tm_copy machine
+   * Added comments
+
+   Editorial note FABR:
+   this file was part of the theory file Uncomputable.thy
+   in the original AFP entry. 
+
+ *)
+
+section \<open>A Variation of the theme due to Boolos, Burgess and, Jeffrey\<close>
+
+text \<open>In sections \ref{sec_K1_H1} and \ref{sec_K1_v} we discussed two variants of the proof
+of the undecidability of the Sepcial Halting Problem. There, we used the Turing Machines
+ @{term "tm_semi_id_eq0"} and @{term "tm_semi_id_gt0"} for the construction a contradiction.
+
+The machine @{term "tm_semi_id_gt0"} is identical to the machine {\em dither}, which is discussed
+in length together with the Turing Machine {\em copy} in the book
+by Boolos, Burgess, and Jeffrey~\cite{Boolos07}.
+
+For backwards compatibility with the original AFP entry, we again present the formalization of
+the machines{\em dither} and {\em copy} here in this section.
+This allows for reuse of theory CopyTM, which in turn is referenced
+in the original proof about the existence of an uncomputable function in theory
+TuringUnComputable\_H2\_original.
+
+In addition we present an enhanced version in theory TuringUnComputable\_H2, which is in
+line with the principles of Conservative Extension.
+\<close>
+
+subsection \<open>The Dithering Turing Machine\<close>
+(*
+The machine tm_dither
+terminates on: Oc \<up> n  with result Oc \<up> n for 1 < n
+
+     loops on: []     which is the empty input
+     loops on: Oc \<up> 1 which is the numeral <0>
+
+*)
+
+text \<open>
+  If the input is empty or the numeral $<\!0\!>$,
+  the {\em Dithering} TM will loop forever,
+  otherwise it will terminate.
+\<close>
+
+theory DitherTM
+  imports Turing_Hoare
+begin
+
+(* Cleanup the global simpset for proofs of several theorems about tm_dither *)
+
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+
+definition tm_dither :: "instr list"
+  where
+    "tm_dither \<equiv> [(WB, 1), (R, 2), (L, 1), (L, 0)]"
+
+(* ------ Important properties used in subsequent theories ------ *)
+
+(* The dithering machine is well-formed *)
+
+lemma composable_tm0_tm_dither[intro, simp]: "composable_tm0 tm_dither"
+  by (auto simp: composable_tm.simps tm_dither_def)
+
+lemma tm_dither_loops_aux: 
+  "(steps0 (1, Bk \<up> m, [Oc]) tm_dither stp = (1, Bk \<up> m, [Oc])) \<or> 
+   (steps0 (1, Bk \<up> m, [Oc]) tm_dither stp = (2, Oc # Bk \<up> m, []))"
+  by (induct stp) (auto simp: steps.simps step.simps tm_dither_def numeral_eqs_upto_12)
+
+lemma tm_dither_loops_aux': 
+  "(steps0 (1, Bk \<up> m, [Oc] @ Bk \<up> n) tm_dither stp = (1, Bk \<up> m, [Oc] @ Bk \<up> n)) \<or> 
+   (steps0 (1, Bk \<up> m, [Oc] @ Bk \<up> n) tm_dither stp = (2, Oc # Bk \<up> m, Bk \<up> n))"
+  by (induct stp) (auto simp: steps.simps step.simps tm_dither_def numeral_eqs_upto_12)
+
+(* ------ Auxiliary properties for clarification           ------ *)
+
+text \<open>
+  If the input is @{term "Oc\<up>1"} the {\em Dithering} TM will loop forever,
+  for other non-blank inputs @{term "Oc\<up>(n+1)"} with @{term "1 < (n::nat)"} it will 
+  reach the final state in a standard configuration.
+
+  Please note that our short notation  @{term "<n::nat>"} means @{term "Oc\<up>(n+1)"}
+  where @{term "0 \<le> (n::nat)"}.
+\<close>
+
+lemma "<0::nat> = [Oc]" by (simp add: tape_of_nat_def)
+lemma "Oc\<up>(0+1) = [Oc]" by (simp)
+lemma "<n::nat> = Oc\<up>(n+1)" by (auto simp add: tape_of_nat_def)
+
+lemma "<1::nat> = [Oc, Oc]" by (simp add: tape_of_nat_def)
+
+subsubsection \<open>Dither in action.\<close>
+
+(* steps0 (1, [], [Oc]) tm_dither n loops forever for 0 \<le> n *)
+lemma "steps0 (1, [], [Oc]) tm_dither 0 = (1, [], [Oc])" by (simp add: step.simps steps.simps tm_dither_def)
+lemma "steps0 (1, [], [Oc]) tm_dither 1 = (2, [Oc], [])" by (simp add: step.simps steps.simps tm_dither_def)
+lemma "steps0 (1, [], [Oc]) tm_dither 2 = (1, [], [Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+lemma "steps0 (1, [], [Oc]) tm_dither 3 = (2, [Oc], [])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+lemma "steps0 (1, [], [Oc]) tm_dither 4 = (1, [], [Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+
+(* steps0 (1, [], [Oc, Oc]) tm_dither n  terminates after 2 steps with final configuration "(0, [], [Oc, Oc])" *)
+lemma "steps0 (1, [], [Oc, Oc]) tm_dither 0 = (1, [], [Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+lemma "steps0 (1, [], [Oc, Oc]) tm_dither 1 = (2, [Oc], [Oc])"   by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+lemma "steps0 (1, [], [Oc, Oc]) tm_dither 2 = (0, [], [Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+lemma "steps0 (1, [], [Oc, Oc]) tm_dither 3 = (0, [], [Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+
+(* steps0 (1, [], [Oc, Oc, Oc]) tm_dither n  terminates after 2 steps with final configuration "(0, [], [Oc, Oc, Oc])" *)
+lemma "steps0 (1, [], [Oc, Oc, Oc]) tm_dither 0 = (1, [], [Oc, Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+lemma "steps0 (1, [], [Oc, Oc, Oc]) tm_dither 1 = (2, [Oc], [Oc, Oc])"   by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+lemma "steps0 (1, [], [Oc, Oc, Oc]) tm_dither 2 = (0, [], [Oc, Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+lemma "steps0 (1, [], [Oc, Oc, Oc]) tm_dither 3 = (0, [], [Oc, Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_dither_def)
+
+subsubsection \<open>Proving properties of tm\_dither with Hoare rules\<close>
+
+text \<open>Using Hoare style rules is more elegant since they allow for compositional
+ reasoning. Therefore, its preferable to use them, if the program that we reason about
+ can be decomposed appropriately.\<close>
+
+(* Assertions and invariants of tm_dither *)
+abbreviation (input)
+  "tm_dither_halt_inv \<equiv> \<lambda>tap. \<exists>k. tap = (Bk \<up> k, <1::nat>)"
+
+abbreviation (input)
+  "tm_dither_unhalt_ass \<equiv> \<lambda>tap. \<exists>k. tap = (Bk \<up> k, <0::nat>)"
+
+lemma "<0::nat> = [Oc]" by (simp add: tape_of_nat_def)
+
+lemma tm_dither_loops: 
+  shows "\<lbrace>tm_dither_unhalt_ass\<rbrace> tm_dither \<up>"
+  apply(rule Hoare_unhaltI)
+  using tm_dither_loops_aux
+  apply(auto simp add: numeral_eqs_upto_12 tape_of_nat_def)
+  by (metis Suc_neq_Zero is_final_eq)
+
+lemma tm_dither_loops'':
+  shows "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk\<up>k, [Oc] @ Bk\<up> l)\<rbrace> tm_dither \<up>"
+  apply(rule Hoare_unhaltI)
+  using tm_dither_loops_aux'
+  apply(auto simp add: numeral_eqs_upto_12 tape_of_nat_def)
+  by (metis Zero_neq_Suc is_final_eq)
+
+
+lemma tm_dither_halts_aux:
+  shows "steps0 (1, Bk \<up> m, [Oc, Oc]) tm_dither 2 = (0, Bk \<up> m, [Oc, Oc])"
+  unfolding tm_dither_def
+  by (simp add: steps.simps step.simps numeral_eqs_upto_12)
+
+lemma tm_dither_halts_aux':
+  shows "steps0 (1, Bk \<up> m, [Oc, Oc]@Bk \<up> n) tm_dither 2 = (0, Bk \<up> m, [Oc, Oc]@Bk \<up> n)"
+  unfolding tm_dither_def
+  by (simp add: steps.simps step.simps numeral_eqs_upto_12)
+
+lemma tm_dither_halts: 
+  shows "\<lbrace>tm_dither_halt_inv\<rbrace> tm_dither \<lbrace>tm_dither_halt_inv\<rbrace>"
+  apply(rule Hoare_haltI)
+  using tm_dither_halts_aux
+  apply(auto simp add: tape_of_nat_def)
+  by (metis (lifting, mono_tags) holds_for.simps is_final_eq)
+
+lemma tm_dither_halts'':
+  shows "\<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk\<up> k, [Oc, Oc] @ Bk\<up> l)\<rbrace> tm_dither \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk\<up> k, [Oc, Oc] @ Bk\<up> l)\<rbrace>"
+  apply(rule Hoare_haltI)
+  using tm_dither_halts_aux'
+  apply(auto simp add: tape_of_nat_def)
+  by (metis (mono_tags, lifting) Suc_1 holds_for.simps is_finalI numeral_1_eq_Suc_0 numeral_One)
+
+end
diff --git a/thys/Universal_Turing_Machine/GeneratedCode.thy b/thys/Universal_Turing_Machine/GeneratedCode.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/GeneratedCode.thy
@@ -0,0 +1,92 @@
+(* Title: thys/GeneratedCode.thy
+   Author: Franz Regensburger (FABR) 03/2022
+ *)
+
+chapter \<open>Code extraction for interpreters and compilers\<close>
+
+theory GeneratedCode
+  imports HaltingProblems_K_H
+          Abacus_Hoare
+(*        "~~/src/HOL/Library/Code_Target_Numeral" (* see doc codegen.pdf *) *) 
+          "~~/src/HOL/Library/Code_Binary_Nat" (* see doc codegen.pdf *) 
+
+begin
+
+(* Force full access to datatype cell by using a dummy function
+ * This results in a modul export in Turing.hs
+ *  force     :   Cell(..)
+ *  instead of: Cell
+ *)
+
+fun 
+  dummy_cellId :: "cell \<Rightarrow> cell"
+  where
+"dummy_cellId Oc = Oc" |
+"dummy_cellId Bk = Bk"
+
+(* Dito for abc_inst; Force full access to datatype *)
+
+fun 
+  dummy_abc_inst_Id :: " abc_inst \<Rightarrow> bool"
+  where
+"dummy_abc_inst_Id (Inc n) = True" |
+"dummy_abc_inst_Id (Dec n s) = True" |
+"dummy_abc_inst_Id (Goto n) = True"
+
+(* Encoding of natural numbers as unary numerals *)
+
+fun tape_of_nat_imp :: "nat \<Rightarrow> cell list"
+  where
+  "tape_of_nat_imp n = <n>"
+
+fun tape_of_nat_list_imp :: "nat list \<Rightarrow> cell list"
+  where
+  "tape_of_nat_list_imp ns = <ns>"
+
+(* ------------------- EXPORT CODE ------------------- *)
+
+export_code  dummy_cellId
+             step steps
+             is_final
+             mk_composable0 shift adjust seq_tm
+
+             (* conversion of nat lists to numerals *)
+             tape_of_nat_list_imp tape_of_nat_imp
+
+             (* some Turing machines *)
+             tm_semi_id_eq0 tm_semi_id_gt0
+             tm_onestroke
+
+             tm_copy_begin_orig tm_copy_loop_orig tm_copy_end_new
+             tm_weak_copy
+
+             tm_skip_first_arg tm_erase_right_then_dblBk_left
+             tm_check_for_one_arg 
+
+             tm_strong_copy
+
+             (* interpreter for Abacus programs *)
+             dummy_abc_inst_Id
+             abc_step_l abc_steps_l
+             abc_lm_v abc_lm_s abc_fetch
+             abc_final abc_notfinal abc_out_of_prog
+
+             (* --- compiler for Abacus programs *)
+             layout_of start_of
+             tinc tdec tgoto ci tpairs_of
+             tm_of tms_of
+             mopup_n_tm app_mopup
+
+             (* --- SimpleGoedelEncoding --- *)
+             tm_to_nat_list tm_to_nat
+             nat_list_to_tm nat_to_tm
+
+             num_of_nat num_of_integer
+
+             list_encode list_decode prod_encode prod_decode
+             triangle
+
+
+  in Haskell file "HaskellCode/"
+
+end
diff --git a/thys/Universal_Turing_Machine/HaltingProblems_K_H.thy b/thys/Universal_Turing_Machine/HaltingProblems_K_H.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/HaltingProblems_K_H.thy
@@ -0,0 +1,567 @@
+(* Title: thys/HaltingProblems_K_H.thy
+   Author: Franz Regensburger (FABR) 02/2022
+ *)
+
+subsection \<open>Undecidability of Halting Problems\<close>
+
+theory HaltingProblems_K_H
+  imports
+    SimpleGoedelEncoding
+    SemiIdTM
+    TuringReducible
+
+begin
+
+(* -------------------------------------------------------------------------- *)
+
+(*
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+*)
+
+subsubsection \<open>A locale for variations of the Halting Problem\<close>
+
+text \<open>
+  The following locale assumes that there is an injective coding function \<open>t2c\<close>
+  from Turing machines to natural numbers. In this locale, we will show that the
+  Special Halting Problem K1 and the General Halting Problem H1 are not Turing decidable.
+\<close>
+
+locale hpk = 
+  fixes t2c :: "tprog0 \<Rightarrow> nat"
+  assumes
+    t2c_inj: "inj t2c"
+
+begin
+
+text \<open>The function @{term tm_to_nat} is a witness that the locale hpk is inhabited.\<close>
+
+interpretation tm_to_nat: hpk "tm_to_nat :: tprog0 \<Rightarrow> nat"
+proof unfold_locales
+  show "inj tm_to_nat" by (rule inj_tm_to_nat)
+qed
+
+text \<open>We define the function @{term c2t} as the unique inverse of the
+injective function  @{term t2c}.
+\<close>
+
+(* Note 1:
+ * It does not matter how we define c2t n if \<not>(\<exists>p. t2c p = n).
+ * We never need to know that value
+ * since we are only interested in the equation
+ *
+ *   "c2t (t2c p) = p"
+ *)
+
+(* Note 1:
+   * We use Hilbert' non-constructive operators for
+   *   definite   choice \<iota> (iota)     (THE in  Isabelle/HOL)
+   *   indefinite choice \<epsilon> (epsilon)  (SOME in Isabelle/HOL)
+   *)
+
+definition c2t :: "nat \<Rightarrow> instr list"
+  where
+    "c2t = (\<lambda>n. if (\<exists>p. t2c p = n)
+                 then (THE  p. t2c p = n)
+                 else (SOME p. True) )"
+
+lemma t2c_inj': "inj_on t2c {x. True}"
+  by (auto simp add: t2c_inj )
+
+lemma c2t_comp_t2c_eq: "c2t (t2c p) = p"
+proof -
+  have "\<forall>p\<in>{x. True}. c2t (t2c p) = p"
+  proof (rule encode_decode_A_eq[OF t2c_inj'])
+    show "c2t = (\<lambda>w. if \<exists>t\<in>{x. True}. t2c t = w then THE t. t \<in> {x. True} \<and> t2c t = w else SOME t. t \<in> {x. True})"
+      by (auto simp add: c2t_def)
+  qed
+  then show ?thesis by auto
+qed
+
+subsubsection \<open>Undecidability of the Special Halting Problem K1\<close>
+
+(* Just as a reminder:
+
+    definition TMC_has_num_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"
+
+      where
+        "TMC_has_num_res p ns \<equiv>
+         \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+
+
+    lemma TMC_yields_num_res_unfolded_into_Hoare_halt:
+
+      "TMC_yields_num_res tm ns n \<equiv>
+         \<lbrace>(\<lambda>tap. tap = ([], <ns>))\<rbrace> tm \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk\<up> l))\<rbrace>"
+
+*)
+
+definition K1 :: "(nat list) set"
+  where
+     "K1 \<equiv> {nl. (\<exists>n. nl = [n] \<and> TMC_has_num_res (c2t n) [n]) }"
+
+text \<open>Assuming the existence of a Turing Machine K1D1, which is able to decide the set K1,
+ we derive a contradiction using the machine @{term "tm_semi_id_eq0"}.
+ Thus, we show that the {\em Special Halting Problem K1} is not Turing decidable.
+\label{sec_K1_H1}
+ The proof uses a diagonal argument.
+\<close>
+
+(* some convenience lemmas will keep the main proof quit neat *)
+
+lemma mk_composable_decider_K1D1:
+  assumes "\<exists>K1D1'. (\<forall>nl.
+          (nl \<in> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (1::nat))
+       \<and>  (nl \<notin> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (0::nat) ))"
+
+  shows  "\<exists>K1D1'. (\<forall>nl. composable_tm0 K1D1' \<and>
+          (nl \<in> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (1::nat))
+       \<and>  (nl \<notin> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (0::nat) ))"
+proof -
+  from assms have
+    "\<exists>K1D1'. (\<forall>nl.
+          (nl \<in> K1 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc,Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K1 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>) )"
+    unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
+    by (simp add: tape_of_nat_def)
+
+    (* create a composable version of the potentially non-composable machine K1D1' *)
+
+  then obtain K1D1' where
+    "(\<forall>nl.
+          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
+    by blast
+
+  then have "composable_tm0 (mk_composable0 K1D1') \<and> (\<forall>nl.
+          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
+    using Hoare_halt_tm_impl_Hoare_halt_mk_composable0 composable_tm0_mk_composable0 by blast 
+
+  then have "composable_tm0 (mk_composable0 K1D1') \<and> (\<forall>nl.
+          (nl \<in> K1 \<longrightarrow> TMC_yields_num_res (mk_composable0 K1D1') nl (1::nat) )
+       \<and>  (nl \<notin> K1 \<longrightarrow> TMC_yields_num_res (mk_composable0 K1D1') nl (0::nat) ))"
+    unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
+    by (simp add: tape_of_nat_def)
+
+  then show ?thesis by auto
+qed
+
+lemma res_1_fed_into_tm_semi_id_eq0_loops:
+  assumes "composable_tm0 D"
+    and   "TMC_yields_num_res D nl (1::nat)"
+  shows   "TMC_loops (D |+| tm_semi_id_eq0) nl"
+  unfolding TMC_loops_def
+proof 
+  fix stp
+  show "\<not> is_final (steps0 (1, [], <nl::nat list>) (D |+| tm_semi_id_eq0) stp)"
+    using assms tm_semi_id_eq0_loops''        
+      Hoare_plus_unhalt Hoare_unhalt_def 
+      tape_of_nat_def tape_of_list_def
+      TMC_yields_num_res_unfolded_into_Hoare_halt
+    by simp
+qed
+
+lemma loops_imp_has_no_res: "TMC_loops tm [n] \<Longrightarrow> \<not> TMC_has_num_res tm [n]"
+proof -
+  assume "TMC_loops tm [n]"
+  then show "\<not> TMC_has_num_res tm [n]"
+    using TMC_has_num_res_iff TMC_loops_def
+    by blast
+qed
+
+lemma yields_res_imp_has_res: "TMC_yields_num_res tm [n] (m::nat) \<Longrightarrow> TMC_has_num_res tm [n]"
+proof -
+  assume "TMC_yields_num_res tm [n] (m::nat)"
+  then show "TMC_has_num_res tm [n]"
+    by (metis TMC_has_num_res_iff TMC_yields_num_res_def is_finalI)
+qed
+
+lemma res_0_fed_into_tm_semi_id_eq0_yields_0:
+  assumes "composable_tm0 D"
+    and   "TMC_yields_num_res D nl (0::nat)"
+  shows   "TMC_yields_num_res (D |+| tm_semi_id_eq0) nl 0"
+  unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
+  using assms Hoare_plus_halt tm_semi_id_eq0_halts''
+    tape_of_nat_def tape_of_list_def
+    TMC_yields_num_res_unfolded_into_Hoare_halt
+  by simp
+  
+(* here is the main lemma about the Halting problem K1 *)
+
+lemma existence_of_decider_K1D1_for_K1_imp_False:
+  assumes major: "\<exists>K1D1'. (\<forall>nl.
+            (nl \<in> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (1::nat))
+         \<and>  (nl \<notin> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (0::nat) ))"
+  shows False
+proof -
+  (* first, create a composable version of the potentially non-composable machine K1D1' *)
+
+  from major have
+    "\<exists>K1D1'. (\<forall>nl. composable_tm0 K1D1' \<and>
+            (nl \<in> K1 \<longrightarrow> TMC_yields_num_res K1D1' nl (1::nat))
+         \<and>  (nl \<notin> K1 \<longrightarrow> TMC_yields_num_res K1D1' nl (0::nat) ))"
+    by (rule mk_composable_decider_K1D1)
+
+  then obtain K1D1 where
+    w_K1D1: "\<forall>nl. composable_tm0 K1D1 \<and>
+            (nl \<in> K1 \<longrightarrow> TMC_yields_num_res K1D1 nl (1::nat))
+         \<and>  (nl \<notin> K1 \<longrightarrow> TMC_yields_num_res K1D1 nl (0::nat) )"
+    by blast
+
+  (* second, using our composable decider K1D1 we construct a machine tm_contra that will
+     contradict our major assumption using a diagonal argument *)
+
+  define tm_contra where "tm_contra = K1D1 |+| tm_semi_id_eq0"
+
+  (* third, we derive the crucial lemma "c2t (t2c tm_contra) = tm_contra" *)
+  have c2t_comp_t2c_eq_for_tm_contra: "c2t (t2c tm_contra) = tm_contra"
+    by (auto simp add: c2t_comp_t2c_eq)
+
+  (* now, we derive the contradiction *)
+  show False
+    (* using the classical axiom TND: A \<or> \<not>A,
+   * we proof by cases: [t2c tm_contra] \<in> K1 \<or> [t2c tm_contra] \<notin> K1 *)
+
+  proof (cases "[t2c tm_contra] \<in> K1")
+    case True
+    from \<open>[t2c tm_contra] \<in> K1\<close> and w_K1D1
+    have "TMC_yields_num_res K1D1 [t2c tm_contra] (1::nat)"
+      by auto
+
+    then have "TMC_loops tm_contra [t2c tm_contra]"
+      using res_1_fed_into_tm_semi_id_eq0_loops w_K1D1 tm_contra_def
+      by blast
+
+    then have "\<not>(TMC_has_num_res tm_contra [t2c tm_contra])"
+      using loops_imp_has_no_res by blast
+
+    then have "\<not>(TMC_has_num_res (c2t (t2c tm_contra))) [t2c tm_contra]"
+      by (auto simp add: c2t_comp_t2c_eq_for_tm_contra)
+
+    then have "[t2c tm_contra] \<notin> K1"
+      by (auto simp add: K1_def)
+
+    with  \<open>[t2c tm_contra] \<in> K1\<close> show False by auto
+
+  next
+    case False
+    from \<open>[t2c tm_contra] \<notin> K1\<close> and w_K1D1
+    have "TMC_yields_num_res K1D1 [t2c tm_contra] (0::nat)"
+      by auto
+
+    then have "TMC_yields_num_res tm_contra [t2c tm_contra] (0::nat)"
+      using res_0_fed_into_tm_semi_id_eq0_yields_0 w_K1D1 tm_contra_def
+      by auto
+
+    then have "TMC_has_num_res tm_contra [t2c tm_contra]"
+      using yields_res_imp_has_res by blast
+
+    then have "TMC_has_num_res (c2t (t2c tm_contra)) [t2c tm_contra]"
+      by (auto simp add: c2t_comp_t2c_eq_for_tm_contra)
+
+    then have "[t2c tm_contra] \<in> K1"
+      by (auto simp add: K1_def)
+
+    with \<open>[t2c tm_contra] \<notin> K1\<close> show False by auto
+  qed
+qed
+
+(* FABR NOTE:
+ 
+   We are not able to show a result like "\<not>(turing_decidable H2)"
+   
+   Reason:
+   Our notion of Turing decidability is based on: turing_decidable :: "(nat list) set \<Rightarrow> bool"
+
+   The lemma of theory TuringUnComputable_H2
+
+      lemma existence_of_decider_H2D0_for_H2_imp_False:
+        assumes "\<exists>H2D0'. (\<forall>nl (tm::instr list).
+                ((tm,nl) \<in> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> H2D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk\<up>l)\<rbrace>)
+             \<and>  ((tm,nl) \<notin> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> H2D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l)\<rbrace>) )"
+        shows False
+
+   is about pairs (tm,nl) :: ((instr list) \<times> (nat list)) set
+
+    definition H2 :: "((instr list) \<times> (nat list)) set"
+      where
+         "H2 \<equiv> {(tm,nl). TMC_has_num_res tm nl }"
+
+   We need to derive a variation of this result
+   where we use a set of lists [code tm, nl] :: (nat list) set
+   that fits into our setting.
+
+    definition H1 :: "(nat list) set"
+      where
+         "H1 \<equiv> {nl. (\<exists>n m. nl = [n,m] \<and> TMC_has_num_res (c2t n) [m]) }"
+
+*)
+
+subsubsection \<open>The Special Halting Problem K1 is reducible to the General Halting Problem H1\<close>
+
+text \<open>The proof is  by reduction of \<open>K1\<close> to \<open>H1\<close>.
+\<close>
+
+(* Convenience lemmas for the reduction of K1 to H1 *)
+
+definition H1 :: "(nat list) set"
+  where
+    "H1 \<equiv> {nl. (\<exists>n m. nl = [n,m] \<and> TMC_has_num_res (c2t n) [m]) }"
+
+lemma NilNotIn_K1: "[] \<notin> K1"
+  unfolding K1_def
+  using CollectD list.simps(3) by auto
+
+lemma NilNotIn_H1: "[] \<notin> H1"
+  unfolding H1_def
+  using CollectD list.simps(3) by auto
+
+lemma tm_strong_copy_total_correctness_Nil':
+  "length nl = 0 \<Longrightarrow> TMC_yields_num_list_res tm_strong_copy nl []"
+  unfolding TMC_yields_num_list_res_unfolded_into_Hoare_halt
+proof -
+  assume "length nl = 0"
+  then have "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_strong_copy \<lbrace>\<lambda>tap. tap = ([Bk,Bk,Bk,Bk],[]) \<rbrace>"
+    using tm_strong_copy_total_correctness_Nil by simp
+  then have F1: "\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_strong_copy \<lbrace>\<lambda>tap. tap = (Bk \<up> 4, <[]> @ Bk \<up> 0)\<rbrace>"
+    by (metis One_nat_def Suc_1 \<open>length nl = 0\<close>
+        append_Nil length_0_conv numeral_4_eq_4 numeral_eqs_upto_12(2)
+        replicate_0 replicate_Suc tape_of_list_empty)
+  show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace>
+              tm_strong_copy
+            \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[]::nat list> @ Bk \<up> l)\<rbrace>"
+  proof (rule Hoare_haltI)
+    fix l::"cell list"
+    fix r::"cell list"
+    assume "(l, r) = ([], <nl::nat list>)"
+    show "\<exists>n. is_final (steps0 (1, l, r) tm_strong_copy n) \<and>
+                 (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[]::nat list> @ Bk \<up> l)) holds_for steps0 (1, l, r) tm_strong_copy n"
+      by (smt F1 Hoare_haltE \<open>(l, r) = ([], <nl>)\<close> holds_for.elims(2) holds_for.simps)
+  qed
+qed
+
+lemma tm_strong_copy_total_correctness_len_eq_1':
+  "length nl = 1 \<Longrightarrow> TMC_yields_num_list_res tm_strong_copy nl [hd nl, hd nl]"
+  unfolding TMC_yields_num_list_res_unfolded_into_Hoare_halt
+proof -
+  assume "length nl = 1"
+  then show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
+                     tm_strong_copy
+                   \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd nl, hd nl]> @ Bk \<up> l) \<rbrace>"
+    using tm_strong_copy_total_correctness_len_eq_1 by simp
+qed
+
+lemma tm_strong_copy_total_correctness_len_gt_1':
+  "1 < length nl \<Longrightarrow> TMC_yields_num_list_res tm_strong_copy nl [hd nl]"
+  unfolding TMC_yields_num_list_res_unfolded_into_Hoare_halt
+proof -
+  assume "1 < length nl"
+  then have "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
+                     tm_strong_copy
+                   \<lbrace> \<lambda>tap. \<exists>l. tap = ([Bk,Bk], <[hd nl]> @ Bk \<up> l) \<rbrace>"
+    using tm_strong_copy_total_correctness_len_gt_1 by simp
+  then show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
+                     tm_strong_copy
+                   \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd nl]> @ Bk \<up> l) \<rbrace>"
+    by (smt Hoare_haltE Hoare_haltI One_nat_def Pair_inject Pair_inject holds_for.elims(2)
+        holds_for.simps is_final.elims(2) replicate.simps(1) replicate.simps(2))
+qed
+
+(* --- *)
+
+theorem turing_reducible_K1_H1: "turing_reducible K1 H1"
+  unfolding turing_reducible_unfolded_into_TMC_yields_condition
+proof -
+  have "\<forall>nl::nat list. \<exists>ml::nat list.
+              TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1 \<longleftrightarrow> ml \<in> H1)"
+  proof
+    fix nl::"nat list"
+    have "length nl = 0 \<or> length nl = 1 \<or> 1 < length nl"
+      by arith
+    then
+    show "\<exists>ml. TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1) = (ml \<in> H1)"
+    proof
+      assume "length nl = 0"
+      then have "TMC_yields_num_list_res tm_strong_copy nl []"
+        by (rule tm_strong_copy_total_correctness_Nil')
+      moreover have "(nl \<in> K1) = ([] \<in> H1)"
+        using NilNotIn_H1 NilNotIn_K1 \<open>length nl = 0\<close> length_0_conv by blast
+      ultimately
+      show "\<exists>ml. TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1) = (ml \<in> H1)" by blast
+    next
+      assume "length nl = 1 \<or> 1 < length nl"
+      then show "\<exists>ml. TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1) = (ml \<in> H1)"
+      proof
+        assume "1 < length nl"
+        then have "TMC_yields_num_list_res tm_strong_copy nl [hd nl]"
+          by (rule tm_strong_copy_total_correctness_len_gt_1')
+        moreover have "(nl \<in> K1) = ([hd nl] \<in> H1)"
+          using H1_def K1_def \<open>1 < length nl\<close> by auto
+        ultimately
+        show "\<exists>ml. TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1) = (ml \<in> H1)" by blast
+      next
+        assume "length nl = 1"
+        then have "TMC_yields_num_list_res tm_strong_copy nl [hd nl, hd nl]"
+          by (rule tm_strong_copy_total_correctness_len_eq_1')
+        moreover have "(nl \<in> K1) = ([hd nl, hd nl] \<in> H1)"
+          by (smt CollectD Cons_eq_append_conv H1_def K1_def One_nat_def \<open>length nl = 1\<close>
+              append_Cons diff_Suc_1 hd_Cons_tl length_0_conv length_tl list.inject
+              mem_Collect_eq not_Cons_self2  self_append_conv2 zero_neq_one)
+        ultimately
+        show "\<exists>ml. TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1) = (ml \<in> H1)" by blast
+      qed
+    qed
+  qed
+  then show "\<exists>tm. \<forall>nl. \<exists>ml. TMC_yields_num_list_res tm nl ml \<and> (nl \<in> K1) = (ml \<in> H1)"
+    by auto
+qed
+
+(* --------------------------------------------------------------------------------------------- *)
+
+subsubsection \<open>Corollaries about the undecidable sets K1 and H1\<close>
+
+corollary not_Turing_decidable_K1: "\<not>(turing_decidable K1)"
+proof
+  assume "turing_decidable K1"
+  then have "(\<exists>D. (\<forall>nl.
+            (nl \<in> K1 \<longrightarrow>TMC_yields_num_res D nl (1::nat))
+         \<and>  (nl \<notin> K1 \<longrightarrow>TMC_yields_num_res D nl (0::nat) )))"
+    by (auto simp add: turing_decidable_unfolded_into_TMC_yields_conditions
+        tape_of_nat_def)
+  with existence_of_decider_K1D1_for_K1_imp_False show False
+    by blast
+qed
+
+corollary not_Turing_decidable_H1: "\<not>turing_decidable H1"
+proof (rule turing_reducible_AB_and_non_decA_imp_non_decB)
+  show "turing_reducible K1 H1"
+    by (rule turing_reducible_K1_H1)
+next
+  show "\<not> turing_decidable K1"
+    by (rule not_Turing_decidable_K1)
+qed
+
+(* --------------------------------------------------------------------------------------------- *)
+
+subsubsection \<open>Proof variant: The special Halting Problem K1 is not Turing Decidable\<close>
+
+text\<open>Assuming the existence of a Turing Machine K1D0, which is able to decide the set K1,
+ we derive a contradiction using the machine @{term "tm_semi_id_gt0"}.
+ Thus, we show that the {\em Special Halting Problem K1} is not Turing decidable.
+ The proof uses a diagonal argument.
+\label{sec_K1_v}\<close>
+
+lemma existence_of_decider_K1D0_for_K1_imp_False:
+  assumes "\<exists>K1D0'. (\<forall>nl.
+          (nl \<in> K1 \<longrightarrow>TMC_yields_num_res K1D0' nl (0::nat))
+       \<and>  (nl \<notin> K1 \<longrightarrow>TMC_yields_num_res K1D0' nl (1::nat) ))"
+  shows False
+proof -
+  from assms have
+    "\<exists>K1D0'. (\<forall>nl.
+          (nl \<in> K1 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K1 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>) )"
+    unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
+    by (simp add: tape_of_nat_def)
+  then obtain K1D0' where
+    "(\<forall>nl.
+          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
+    by blast
+
+  (* first, create a composable version of the potentially non-composable machine K1D0' *)
+
+  then have "composable_tm0 (mk_composable0 K1D0') \<and> (\<forall>nl.
+          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>) 
+       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
+    using Hoare_halt_tm_impl_Hoare_halt_mk_composable0 composable_tm0_mk_composable0 by blast
+
+  then have "\<exists>K1D0. composable_tm0 K1D0 \<and> (\<forall>nl.
+          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
+    by blast
+
+  then obtain K1D0 where w_K1D0: "composable_tm0 K1D0 \<and> (\<forall>nl.
+          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
+    by blast
+
+  define tm_contra where "tm_contra = K1D0 |+| tm_semi_id_gt0"
+
+  (* second, we derive some theorems from our assumptions *)
+  then have c2t_comp_t2c_TM_eq_for_tm_contra: "c2t (t2c tm_contra) = tm_contra"
+    by (auto simp add: c2t_comp_t2c_eq)
+
+  (* now, we derive the contradiction *)
+  show False 
+  proof (cases "[t2c tm_contra] \<in> K1")
+    case True
+    from \<open>[t2c tm_contra] \<in> K1\<close> and w_K1D0 have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
+      by auto
+
+    then have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<up>"
+      unfolding tm_contra_def
+    proof (rule Hoare_plus_unhalt)
+      show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_gt0 \<up>"
+        by (rule tm_semi_id_gt0_loops'')
+    next
+      from w_K1D0 show "composable_tm0 K1D0" by auto
+    qed
+
+    then have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<up>"
+      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)
+
+    then have "\<not>\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"   
+      using Hoare_halt_impl_not_Hoare_unhalt by blast
+
+    then have "\<not>( TMC_has_num_res (c2t (t2c tm_contra)) [t2c tm_contra])"
+      by (auto simp add:  TMC_has_num_res_def)
+
+    then have "[t2c tm_contra] \<notin> K1"
+      by (auto simp add: K1_def)
+
+    with  \<open>[t2c tm_contra] \<in> K1\<close> show False by auto
+  next
+    case False
+    from \<open>[t2c tm_contra] \<notin> K1\<close> and w_K1D0 have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
+      by auto
+
+    then have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
+      unfolding tm_contra_def
+    proof (rule Hoare_plus_halt)
+      show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_gt0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
+        by (rule  tm_semi_id_gt0_halts'')
+    next
+      from w_K1D0 show "composable_tm0 K1D0" by auto
+    qed
+
+    then have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
+      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)
+
+    then have
+      " TMC_has_num_res (c2t (t2c tm_contra)) [t2c tm_contra]"
+      
+      by (auto simp add: Hoare_halt_with_OcOc_imp_std_tap tape_of_nat_def)
+
+    then have "[t2c tm_contra] \<in> K1"
+      by (auto simp add: K1_def)
+
+    with \<open>[t2c tm_contra] \<notin> K1\<close> show False by auto
+  qed
+qed
+
+end (* locale hpk *)
+
+end
diff --git a/thys/Universal_Turing_Machine/HaltingProblems_K_aux.thy b/thys/Universal_Turing_Machine/HaltingProblems_K_aux.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/HaltingProblems_K_aux.thy
@@ -0,0 +1,264 @@
+(* Title: thys/HaltingProblem_K_aux.thy
+   Author: Franz Regensburger (FABR) 02/2022
+ *)
+
+subsubsection \<open>K0: A Variant of the Special Halting Problem K1\<close>
+
+theory HaltingProblems_K_aux
+  imports
+    HaltingProblems_K_H
+
+begin
+
+(* -------------------------------------------------------------------------- *)
+
+(*
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+*)
+
+context hpk
+begin
+
+definition K0 :: "(nat list) set"
+  where
+     "K0 \<equiv> {nl. (\<exists>n. nl = [n] \<and> reaches_final (c2t n) [n]) }"
+
+
+text\<open>Assuming the existence of a Turing Machine K0D0, which is able to decide the set K0,
+ we derive a contradiction using the machine @{term "tm_semi_id_gt0"}.
+ Thus, we show that the {\em Special Halting Problem K0} is not Turing decidable.
+ The proof uses a diagonal argument.
+\<close>
+
+lemma existence_of_decider_K0D0_for_K0_imp_False:
+  assumes "\<exists>K0D0'. (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow>TMC_yields_num_res K0D0' nl (0::nat))
+       \<and>  (nl \<notin> K0 \<longrightarrow>TMC_yields_num_res K0D0' nl (1::nat) ))"
+  shows False
+proof -
+  from assms have
+    "\<exists>K0D0'. (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K0 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>) )"
+    unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
+    by (simp add: tape_of_nat_def)
+  then obtain K0D0' where
+    "(\<forall>nl.
+          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>) )"
+    by blast
+
+(* first, create a composable version of the potentially non-composable machine K0D0' *)
+
+  then have "composable_tm0 (mk_composable0 K0D0') \<and> (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K0D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
+    using Hoare_halt_tm_impl_Hoare_halt_mk_composable0 composable_tm0_mk_composable0 by blast
+
+  then have "\<exists>K0D0. composable_tm0 K0D0 \<and> (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
+    by blast
+
+  then obtain K0D0 where w_K0D0: "composable_tm0 K0D0 \<and> (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
+    by blast
+
+  define tm_contra where "tm_contra = K0D0 |+| tm_semi_id_gt0"
+
+(* second, we derive some theorems from our assumptions *)
+  have c2t_comp_t2c_TM_eq_for_tm_contra: "c2t (t2c tm_contra) = tm_contra"
+    by (auto simp add: c2t_comp_t2c_eq)
+
+(* now, we derive the contradiction *)
+  show False 
+  proof (cases "[t2c tm_contra] \<in> K0")
+    case True
+    from \<open>[t2c tm_contra] \<in> K0\<close> and w_K0D0 have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
+      by auto
+
+    then have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<up>"
+      unfolding tm_contra_def
+
+    proof (rule Hoare_plus_unhalt)
+      from tm_semi_id_gt0_loops' show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_gt0 \<up>"
+        using Hoare_unhalt_add_Bks_left_tape_L1 Hoare_unhalt_def assms
+        by auto
+    next
+      from w_K0D0 show "composable_tm0 K0D0" by auto
+    qed
+    then have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<up>"
+      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)
+
+    then have "\<not>(reaches_final (c2t (t2c tm_contra)) [t2c tm_contra])"
+      by (simp add: Hoare_unhalt_def Hoare_unhalt_impl_not_reaches_final)
+
+    then have "[t2c tm_contra] \<notin> K0"
+      by (auto simp add: K0_def)
+
+    with  \<open>[t2c tm_contra] \<in> K0\<close> show False by auto
+  next  
+
+    case False
+    from \<open>[t2c tm_contra] \<notin> K0\<close> and w_K0D0 have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> K0D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
+      by auto
+    then have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
+      unfolding tm_contra_def
+
+    proof (rule Hoare_plus_halt)
+      from tm_semi_id_gt0_halts''
+      show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_gt0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
+        by auto
+    next
+      from w_K0D0 show "composable_tm0 K0D0" by auto
+    qed
+
+    then have
+      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
+      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)
+
+    then have
+      "reaches_final (c2t (t2c tm_contra)) [t2c tm_contra]"
+      by (metis (mono_tags, lifting) Hoare_haltE reaches_final_iff)
+
+    then have "[t2c tm_contra] \<in> K0"
+      by (auto simp add: K0_def)
+
+    with \<open>[t2c tm_contra] \<notin> K0\<close> show False by auto
+  qed
+qed
+
+text\<open>Assuming the existence of a Turing Machine K0D1, which is able to decide the set K0,
+ we derive a contradiction using the machine @{term "tm_semi_id_eq0"}.
+ Thus, we show that the {\em Special Halting Problem K0} is not Turing decidable.
+ The proof uses a diagonal argument.
+\<close>
+
+lemma existence_of_decider_K0D1_for_K0_imp_False:
+  assumes "\<exists>K0D1'. (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow>TMC_yields_num_res K0D1' nl (1::nat))
+       \<and>  (nl \<notin> K0 \<longrightarrow>TMC_yields_num_res K0D1' nl (0::nat) ))"
+  shows False
+proof -
+  from assms have
+    "\<exists>K0D1'. (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
+  unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
+  by (simp add: tape_of_nat_def)
+  then obtain K0D1' where
+     "(\<forall>nl.
+          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
+    by blast
+
+(* first, create a composable version of the potentially non-composable machine K0D1' *)
+
+  then have "composable_tm0 (mk_composable0 K0D1') \<and> (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K0D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
+    using Hoare_halt_tm_impl_Hoare_halt_mk_composable0 composable_tm0_mk_composable0 by blast
+
+  then have "\<exists>K0D1. composable_tm0 K0D1 \<and> (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
+    by blast
+
+  then obtain K0D1 where w_K0D1: "composable_tm0 K0D1 \<and> (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
+       \<and>  (nl \<notin> K0 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
+    by blast
+
+  define tm_contra where "tm_contra = K0D1 |+| tm_semi_id_eq0"
+
+(* second, we derive some theorems from our assumptions *)
+  have c2t_comp_t2c_TM_eq_for_tm_contra: "c2t (t2c tm_contra) = tm_contra"
+    by (auto simp add: c2t_comp_t2c_eq)
+
+(* now, we derive the contradiction *)
+  show False 
+  proof (cases "[t2c tm_contra] \<in> K0")
+    case True
+    from \<open>[t2c tm_contra] \<in> K0\<close> and w_K0D1 have
+      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
+      by auto
+
+    then have
+      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<up>"
+      unfolding tm_contra_def
+    proof (rule Hoare_plus_unhalt)
+      from tm_semi_id_eq0_loops' show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_eq0 \<up>"
+        using Hoare_unhalt_add_Bks_left_tape_L1 Hoare_unhalt_def assms
+        by auto
+    next
+      from w_K0D1 show "composable_tm0 K0D1" by auto
+    qed
+
+    then have
+      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<up>"
+      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)
+
+    then have "\<not>(reaches_final (c2t (t2c tm_contra)) [t2c tm_contra])"
+      by (simp add: Hoare_unhalt_def Hoare_unhalt_impl_not_reaches_final)
+
+    then have "[t2c tm_contra] \<notin> K0"
+      by (auto simp add: K0_def)
+
+    with  \<open>[t2c tm_contra] \<in> K0\<close> show False by auto
+  next    
+    case False
+    from \<open>[t2c tm_contra] \<notin> K0\<close> and w_K0D1 have
+      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> K0D1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
+      by auto
+    then have
+      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
+      unfolding tm_contra_def
+    proof (rule Hoare_plus_halt)
+      from tm_semi_id_eq0_halts'' show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_eq0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
+        by auto
+    next
+      from w_K0D1 show "composable_tm0 K0D1" by auto
+    qed
+
+    then have
+      "\<lbrace>\<lambda>tap.\<exists>z. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
+      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)
+
+    then have
+      "reaches_final (c2t (t2c tm_contra)) [t2c tm_contra]"
+      by (metis (mono_tags, lifting) Hoare_halt_def reaches_final_iff)
+
+    then have "[t2c tm_contra] \<in> K0"
+      by (auto simp add: K0_def)
+
+    with \<open>[t2c tm_contra] \<notin> K0\<close> show False by auto
+  qed
+qed
+
+corollary not_Turing_decidable_K0: "\<not>(turing_decidable K0)"
+proof
+  assume "turing_decidable K0"
+  then have "(\<exists>D. (\<forall>nl.
+          (nl \<in> K0 \<longrightarrow>TMC_yields_num_res D nl (1::nat))
+       \<and>  (nl \<notin> K0 \<longrightarrow>TMC_yields_num_res D nl (0::nat) )))"
+    by (auto simp add: turing_decidable_unfolded_into_TMC_yields_conditions tape_of_nat_def)
+  with existence_of_decider_K0D1_for_K0_imp_False show False
+    by blast
+qed
+
+
+end (* locale hpk *)
+
+end
diff --git a/thys/Universal_Turing_Machine/Numerals.thy b/thys/Universal_Turing_Machine/Numerals.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/Numerals.thy
@@ -0,0 +1,874 @@
+(* Title: thys/Numerals.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+ 
+   Further contributions by Franz Regensburger (FABR) 02/2022 :
+   - Re-ordering of sections
+ *)
+
+section \<open>Encoding of Natural Numbers\<close>
+
+theory Numerals
+  imports ComposedTMs BlanksDoNotMatter
+begin
+
+subsection \<open>A class for generating numerals\<close>
+
+class tape =
+  fixes tape_of :: "'a \<Rightarrow> cell list" ("<_>" 100)
+
+
+instantiation nat::tape begin
+definition tape_of_nat where "tape_of_nat (n::nat) \<equiv> Oc \<up> (Suc n)"
+instance by standard
+end
+
+type_synonym nat_list = "nat list"
+
+instantiation list::(tape) tape begin
+(* fun tape_of_nat_list :: "nat list \<Rightarrow> cell list"
+   The type ('a::tape) list is needed for lemma tape_of_list_empty in Abacus_Mopup
+ *)
+fun tape_of_nat_list :: "('a::tape) list \<Rightarrow> cell list"
+  where 
+    "tape_of_nat_list [] = []" |
+    "tape_of_nat_list [n] = <n>" |
+    "tape_of_nat_list (n#ns) = <n> @ Bk # (tape_of_nat_list ns)"
+definition tape_of_list where "tape_of_list \<equiv> tape_of_nat_list"
+instance by standard
+end
+
+instantiation prod:: (tape, tape) tape begin
+fun tape_of_nat_prod :: "('a::tape) \<times> ('b::tape) \<Rightarrow> cell list" 
+  where "tape_of_nat_prod (n, m) = <n> @ [Bk] @ <m>" 
+definition tape_of_prod where "tape_of_prod \<equiv> tape_of_nat_prod"
+instance by standard
+end
+
+subsection \<open>Some lemmas about numerals used for rewriting\<close>
+
+(* Lemma tape_of_list_empty is needed in Abacus_Mopup.thy *)
+
+lemma tape_of_list_empty[simp]: "<[]> = ([]::cell list)" by (simp add: tape_of_list_def)
+
+lemma tape_of_nat_list_cases2: "<(nl::nat list)> = [] \<or> (\<exists>r'. <nl> = Oc # r')"
+  by (induct rule: tape_of_nat_list.induct)(auto simp add: tape_of_nat_def tape_of_list_def)
+
+subsection \<open>Unique decomposition of standard tapes\<close>
+
+text \<open>Some lemmas about unique decomposition of tapes in standard halting configuration.
+\<close>
+
+lemma OcSuc_lemma: "Oc # Oc \<up> n1 = Oc \<up> n2 \<Longrightarrow> Suc n1 = n2"
+proof (induct n1 arbitrary: n2)
+  case 0
+  then have A: "Oc # Oc \<up> 0 =  Oc \<up> n2" .
+  then show ?case
+  proof -
+    from A have "[Oc] = Oc \<up> n2" by auto
+    moreover have "[Oc] = Oc \<up> n2 \<Longrightarrow> Suc 0 = n2"
+      by (induct n2)auto
+    ultimately show ?case by auto
+  qed
+next
+  fix n1 n2
+  assume IV1: "\<And>n2. Oc # Oc \<up> n1 = Oc \<up> n2 \<Longrightarrow> Suc n1 = n2"
+  and IV2: "Oc # Oc \<up> Suc n1 = Oc \<up> n2"
+  show "Suc (Suc n1) = n2"
+  proof (cases n2)
+    case 0
+    then have "Oc \<up> n2 = []" by auto
+    with IV2 have False by auto
+    then show ?thesis by auto
+  next
+    case (Suc n3)
+    then have "n2 = Suc n3" .
+    with IV2 have "Oc # Oc \<up> Suc n1 = Oc \<up> (Suc n3)" by auto
+    then have "Oc # Oc # Oc \<up> n1 = Oc # Oc \<up> n3" by auto
+    then have "Oc # Oc \<up> n1 = Oc \<up> n3" by auto
+    with IV1 have "Suc n1 = n3" by auto
+    then have "Suc (Suc n1) = Suc n3" by auto
+   
+    with \<open>n2 = Suc n3\<close> show ?thesis by auto
+  qed
+qed
+
+lemma inj_tape_of_list: "(<n1::nat>) = (<n2::nat>) \<Longrightarrow> n1 = n2"
+  by (induct n1 arbitrary: n2) (auto simp add: OcSuc_lemma tape_of_nat_def)
+
+lemma inj_repl_Bk: "Bk \<up> k1 = Bk \<up> k2 \<Longrightarrow> k1 = k2" by auto
+
+lemma last_of_numeral_is_Oc: "last (<n::nat>) = Oc"
+  by (auto simp add: tape_of_nat_def)
+
+lemma hd_of_numeral_is_Oc: "hd (<n::nat>) = Oc"
+  by (auto simp add: tape_of_nat_def)
+
+lemma rev_replicate: "rev (Bk \<up> l1) = (Bk \<up> l1)" by auto
+
+lemma rev_numeral: "rev (<n::nat>) = <n::nat>"
+  by (induct n)(auto simp add: tape_of_nat_def)
+
+lemma drop_Bk_prefix: "n < l \<Longrightarrow> hd (drop n ((Bk \<up> l) @ xs)) = Bk"
+  by (induct n arbitrary: l xs)(auto)
+
+lemma unique_Bk_postfix: "<n1::nat> @ Bk \<up> l1 = <n2::nat> @ Bk \<up> l2 \<Longrightarrow> l1 = l2"
+proof -
+  assume "<n1::nat> @ Bk \<up> l1 = <n2::nat> @ Bk \<up> l2"
+  then have "rev (<n1::nat> @ Bk \<up> l1) = rev (<n2::nat> @ Bk \<up> l2)"
+    by auto
+  then have "rev (Bk \<up> l1) @ rev (<n1::nat>) = rev (Bk \<up> l2) @ rev (<n2::nat>)" by auto
+  then have A: "(Bk \<up> l1) @ (<n1::nat>) = (Bk \<up> l2) @ (<n2::nat>)"
+    by (auto simp add: rev_replicate rev_numeral)
+  then show "l1 = l2"
+  proof (cases "l1 = l2")
+    case True
+    then show ?thesis by auto
+  next
+    case False
+    then have "l1 < l2 \<or> l2 < l1" by auto
+    then show ?thesis
+    proof
+      assume "l1 < l2 "
+      then have False
+      proof -
+        have "hd (drop l1 (Bk \<up> l1) @ (<n1::nat>)) = hd ( <n1::nat>)" by auto
+        also have "... = Oc" by (auto simp add: hd_of_numeral_is_Oc)
+        finally have F1: "hd (drop l1 (Bk \<up> l1) @ (<n1::nat>)) =  Oc" .
+
+        from \<open>l1 < l2\<close>have "hd (drop l1 ((Bk \<up> l2) @ (<n2::nat>))) = Bk"
+          by (auto simp add: drop_Bk_prefix)
+        with A have  "hd (drop l1 ((Bk \<up> l1) @ (<n1::nat>))) = Bk" by auto
+        with F1 show False by auto
+      qed
+      then show ?thesis by auto
+    next
+      assume "l2 < l1"
+      then have False
+      proof -
+        have "hd (drop l2 (Bk \<up> l2) @ (<n2::nat>)) = hd ( <n2::nat>)" by auto
+        also have "... = Oc" by (auto simp add: hd_of_numeral_is_Oc)
+        finally have F2: "hd (drop l2 (Bk \<up> l2) @ (<n2::nat>)) =  Oc" .
+
+        from \<open>l2 < l1\<close> have "hd (drop l2 ((Bk \<up> l1) @ (<n1::nat>))) = Bk"
+          by (auto simp add: drop_Bk_prefix)
+        with A have  "hd (drop l2 ((Bk \<up> l2) @ (<n2::nat>))) = Bk" by auto
+        with F2 show False by auto
+      qed
+      then show ?thesis by auto
+    qed
+  qed
+qed
+
+lemma unique_decomp_tap:
+  assumes "(lx, <n1::nat> @ Bk \<up> l1) = (ly, <n2::nat> @ Bk \<up> l2)"
+  shows "lx=ly \<and> n1=n2 \<and> l1=l2"
+proof
+  from assms show "lx = ly " by auto
+next
+  show "n1 = n2 \<and> l1 = l2"
+  proof
+    from assms have major: "<n1::nat> @ Bk \<up> l1 = <n2::nat> @ Bk \<up> l2" by auto
+    then have "rev (<n1::nat> @ Bk \<up> l1) = rev (<n2::nat> @ Bk \<up> l2)"
+      by auto
+    then have "rev (Bk \<up> l1) @ rev (<n1::nat>) = rev (Bk \<up> l2) @ rev (<n2::nat>)" by auto
+    then have A: "(Bk \<up> l1) @ (<n1::nat>) = (Bk \<up> l2) @ (<n2::nat>)"
+      by (auto simp add: rev_replicate rev_numeral)
+    then show "n1 = n2"
+    proof -
+      from major have "l1 = l2" by (rule unique_Bk_postfix)
+      with A have "(<n1::nat>) = (<n2::nat>)" by auto
+      then show "n1 = n2" by (rule inj_tape_of_list)
+    qed
+  next
+    from assms have major: "<n1::nat> @ Bk \<up> l1 = <n2::nat> @ Bk \<up> l2" by auto
+    then show "l1 = l2" by (rule unique_Bk_postfix)
+  qed
+qed
+
+lemma unique_decomp_std_tap:
+  assumes "(Bk \<up> k1, <n1::nat> @ Bk \<up> l1) = (Bk \<up> k2, <n2::nat> @ Bk \<up> l2)"
+  shows "k1=k2 \<and> n1=n2 \<and> l1=l2"
+proof
+  from assms have "Bk \<up> k1 = Bk \<up> k2" by auto
+  then show "k1 = k2" by auto
+next
+  show "n1 = n2 \<and> l1 = l2"
+  proof
+    from assms have major: "<n1::nat> @ Bk \<up> l1 = <n2::nat> @ Bk \<up> l2" by auto
+    then have "rev (<n1::nat> @ Bk \<up> l1) = rev (<n2::nat> @ Bk \<up> l2)"
+      by auto
+    then have "rev (Bk \<up> l1) @ rev (<n1::nat>) = rev (Bk \<up> l2) @ rev (<n2::nat>)" by auto
+    then have A: "(Bk \<up> l1) @ (<n1::nat>) = (Bk \<up> l2) @ (<n2::nat>)"
+      by (auto simp add: rev_replicate rev_numeral)
+    then show "n1 = n2"
+    proof -
+      from major have "l1 = l2" by (rule unique_Bk_postfix)
+      with A have "(<n1::nat>) = (<n2::nat>)" by auto
+      then show "n1 = n2" by (rule inj_tape_of_list)
+    qed
+  next
+    from assms have major: "<n1::nat> @ Bk \<up> l1 = <n2::nat> @ Bk \<up> l2" by auto
+    then show "l1 = l2" by (rule unique_Bk_postfix)
+  qed
+qed
+
+
+subsection \<open>Lists of numerals never contain two consecutive blanks\<close>
+
+definition noDblBk:: "cell list \<Rightarrow> bool"
+  where "noDblBk cs \<equiv> \<forall>i. Suc i < length cs \<and> cs!i = Bk \<longrightarrow>  cs!(Suc i) = Oc"
+
+lemma noDblBk_Bk_Oc_rep: "noDblBk (Oc \<up> n1)"
+  by (simp add:  noDblBk_def )
+
+lemma noDblBk_Bk_imp_Oc: "\<lbrakk>noDblBk cs; Suc i < length cs; cs!i = Bk \<rbrakk> \<Longrightarrow>  cs!(Suc i) = Oc"
+  by (auto simp add: noDblBk_def)
+
+lemma noDblBk_imp_noDblBk_Oc_cons: "noDblBk cs \<Longrightarrow> noDblBk (Oc#cs)"
+  by (smt Suc_less_eq Suc_pred add.right_neutral add_Suc_right cell.exhaust list.size(4)
+      neq0_conv noDblBk_Bk_imp_Oc noDblBk_def nth_Cons_0 nth_Cons_Suc)
+
+lemma noDblBk_Numeral: "noDblBk (<n::nat>)"
+  by (auto simp add: noDblBk_def tape_of_nat_def)
+
+lemma noDblBk_Nil: "noDblBk []"
+  by (auto simp add: noDblBk_def)
+
+lemma noDblBk_Singleton: "noDblBk (<[n::nat]>)"
+  by (auto simp add: noDblBk_def tape_of_nat_def tape_of_list_def)
+
+(* the next two lemmas are for the inductive step in lemma noDblBk_tape_of_nat_list *)
+lemma tape_of_nat_list_cons_eq:"nl \<noteq> [] \<Longrightarrow> <(a::nat) # nl> = <a> @ Bk # <nl>"
+  by (metis list.exhaust tape_of_list_def tape_of_nat_list.simps(3))
+
+lemma noDblBk_cons_cons: "noDblBk(<(x::nat) # xs>) \<Longrightarrow> noDblBk(<a::nat> @ Bk # <x # xs>)"
+proof -
+  assume F0: "noDblBk (<x # xs>)"
+  have F1: "hd(<x # xs>) = Oc"
+    by (metis hd_append hd_of_numeral_is_Oc list.sel(1)
+        tape_of_nat_list_cons_eq tape_of_list_def tape_of_nat_list.simps(2)
+        tape_of_nat_list_cases2)
+  have F2: "<a> = Oc \<up> (Suc a)" by (auto simp add: tape_of_nat_def)
+  have "noDblBk (<a::nat>)" by (auto simp add: noDblBk_Numeral)
+  with F0 and F1 and F2 show ?thesis
+    unfolding noDblBk_def
+  proof -
+    assume A1: "\<forall>i. Suc i < length (<x # xs>) \<and> <x # xs> ! i = Bk \<longrightarrow> <x # xs> ! Suc i = Oc"
+      and  A2: "hd (<x # xs>) = Oc"
+      and  A3: "<a> = Oc \<up> Suc a"
+      and  A4: "\<forall>i. Suc i < length (<a>) \<and> <a> ! i = Bk \<longrightarrow> <a> ! Suc i = Oc"
+    show   "\<forall>i. Suc i < length (<a> @ Bk # <x # xs>) \<and>
+              (<a> @ Bk # <x # xs>) ! i = Bk \<longrightarrow> (<a> @ Bk # <x # xs>) ! Suc i = Oc"
+    proof
+      fix i
+      show "Suc i < length (<a> @ Bk # <x # xs>) \<and>
+                (<a> @ Bk # <x # xs>) ! i = Bk \<longrightarrow> (<a> @ Bk # <x # xs>) ! Suc i = Oc"
+      proof
+        assume "Suc i < length (<a> @ Bk # <x # xs>) \<and> (<a> @ Bk # <x # xs>) ! i = Bk"
+        then show "(<a> @ Bk # <x # xs>) ! Suc i = Oc"
+        proof
+          assume A5: "Suc i < length (<a> @ Bk # <x # xs>)"
+            and A6: "(<a> @ Bk # <x # xs>) ! i = Bk"
+          show "(<a> @ Bk # <x # xs>) ! Suc i = Oc"
+          proof -
+            from A5 have "Suc i < length (<a>) \<or> Suc i =  length (<a>) \<or>
+                          Suc i = Suc (length (<a>)) \<or> (Suc (length (<a>)) < Suc i \<and> Suc i < length (<a> @ Bk # <x # xs>))"
+              by auto
+            then show ?thesis
+            proof
+              assume "Suc i < length (<a>)"
+              with A1 A2 A3 A4 A5 show ?thesis
+                by (simp add: nth_append')
+            next
+              assume "Suc i = length (<a>) \<or> Suc i = Suc (length (<a>)) \<or> Suc (length (<a>)) < Suc i \<and> Suc i < length (<a> @ Bk # <x # xs>)"
+              then show "(<a> @ Bk # <x # xs>) ! Suc i = Oc"
+              proof
+                assume "Suc i = length (<a>)"
+                with A1 A2 A3 A4 A5 A6 show "(<a> @ Bk # <x # xs>) ! Suc i = Oc"
+                  by (metis lessI nth_Cons_Suc nth_append' nth_append_length replicate_append_same)
+              next
+                assume "Suc i = Suc (length (<a>)) \<or> Suc (length (<a>)) < Suc i \<and> Suc i < length (<a> @ Bk # <x # xs>)"
+                then show "(<a> @ Bk # <x # xs>) ! Suc i = Oc"
+                proof 
+                  assume "Suc i = Suc (length (<a>))"
+                  with A1 A2 A3 A4 A5 A6 show "(<a> @ Bk # <x # xs>) ! Suc i = Oc"                  
+                    by (metis One_nat_def Suc_eq_plus1 length_Cons length_append list.collapse list.size(3)
+                        nat_neq_iff nth_Cons_0 nth_Cons_Suc nth_append_length_plus)
+                next
+                  assume A7: "Suc (length (<a>)) < Suc i \<and> Suc i < length (<a> @ Bk # <x # xs>)"
+                  have F3: "(<a> @ Bk # <x # xs>) = ((<a> @ [Bk]) @ <x # xs>)" by auto
+
+                  have F4: "\<And>n. ((<a> @ [Bk]) @ <x # xs>)! (length (<a> @ [Bk]) + n) = (<x # xs>)!n"
+                    using nth_append_length_plus by blast
+                  from A7 have "\<exists>m. i = Suc (length (<a>)) + m" by arith
+                  then obtain m where w_m: "i = Suc (length (<a>)) + m" by blast
+                  with A7 have F5: "Suc m < length (<x # xs>)" by auto
+                  from w_m F4 have F6: "((<a> @ [Bk]) @ <x # xs>) ! i = (<x # xs>)! m" by auto
+                  with F5 A7 have F7: "((<a> @ [Bk]) @ <x # xs>) ! (Suc i) = (<x # xs>)! (Suc m)"
+                    by (metis F4 add_Suc_right length_append_singleton w_m)
+
+                  from A6 and F6  have "(<x # xs>)! m = Bk" by auto
+                  with A1 and F5 have "(<x # xs>)! (Suc m) = Oc" by auto
+                  with F7 have "((<a> @ [Bk]) @ <x # xs>) ! (Suc i) = Oc" by auto
+                  with F3 show "(<a> @ Bk # <x # xs>)! (Suc i) = Oc" by auto
+                qed
+              qed
+            qed
+          qed
+        qed
+      qed
+    qed
+  qed
+qed
+
+theorem noDblBk_tape_of_nat_list: "noDblBk(<nl:: nat list>)"
+proof (induct nl)
+  case Nil
+  then show ?case
+    by (auto simp add: noDblBk_def tape_of_nat_def tape_of_list_def)
+next
+  case (Cons a nl)
+  then have IV: "noDblBk (<nl>)" .
+  show "noDblBk (<a # nl>)"
+  proof (cases nl)
+    case Nil
+    then show ?thesis
+      by (auto simp add: noDblBk_def tape_of_nat_def tape_of_list_def)
+  next
+    case (Cons x xs)
+    then have "nl = x # xs" .
+    show ?thesis
+    proof -
+      from \<open>nl = x # xs\<close> have "noDblBk (<a # nl>) = noDblBk(<a> @ Bk # <x # xs>)"
+        by (auto simp add: tape_of_nat_list_cons_eq)
+      also with IV and \<open>nl = x # xs\<close> have "... = True" using noDblBk_cons_cons by auto
+      finally show ?thesis by auto
+    qed
+  qed
+qed
+
+lemma hasDblBk_L1: "\<lbrakk> CR = rs @ [Bk] @ Bk # rs'; noDblBk CR \<rbrakk> \<Longrightarrow> False"  
+  by (metis  add_diff_cancel_left' append.simps(2)
+      append_assoc cell.simps(2) length_Cons length_append
+      length_append_singleton noDblBk_def nth_append_length zero_less_Suc zero_less_diff)
+
+lemma hasDblBk_L2: "\<lbrakk> C = Bk # cls; noDblBk C \<rbrakk> \<Longrightarrow> cls = [] \<or> (\<exists>cls'. cls = Oc#cls')"
+  by (metis (full_types) append_Cons append_Nil cell.exhaust hasDblBk_L1 neq_Nil_conv)
+
+lemma hasDblBk_L3: "\<lbrakk> noDblBk C ; C = C1 @ (Bk#C2) \<rbrakk> \<Longrightarrow> C2 = [] \<or> (\<exists>C3. C2 = Oc#C3)"
+  by (metis (full_types) append_Cons append_Nil cell.exhaust hasDblBk_L1 neq_Nil_conv)
+
+
+lemma hasDblBk_L4:
+  assumes "noDblBk CL"
+    and "r = Bk # rs"
+    and "r = rev ls1 @ Oc # rss"
+    and "CL = ls1 @ ls2"
+  shows "ls2 = [] \<or> (\<exists>bs. ls2 = Oc#bs)"
+proof -
+  from \<open>r = Bk # rs\<close>  have "last ls1 = Bk"
+  proof (cases ls1)
+    case Nil
+    then have "ls1=[]" .
+    with \<open>r = rev ls1 @ Oc # rss\<close> have "r = Oc # rss" by auto
+    with \<open>r = Bk # rs\<close> have False by auto
+    then show ?thesis by auto
+  next
+    case (Cons b bs)
+    then have "ls1 = b#bs" .
+    with \<open>r = rev ls1 @ Oc # rss\<close> and \<open>r = Bk # rs\<close> show ?thesis              
+      by (metis \<open>r = rev ls1 @ Oc # rss\<close>
+          last_appendR last_snoc list.simps(3) rev.simps(2) rev_append rev_rev_ident)
+  qed
+  show ?thesis
+  proof (cases ls2)
+    case Nil
+    then show ?thesis by auto
+  next
+    case (Cons b bs)
+    then have "ls2 = b # bs" .
+    show ?thesis
+    proof (cases b)
+      case Bk
+      then have "b = Bk" .      
+      with \<open>ls2 = b # bs\<close> have "ls2 = Bk # bs" by auto
+      with \<open>CL = ls1 @ ls2\<close> have "CL = ls1 @ Bk # bs" by auto
+      then have "CL = butlast ls1 @ [Bk] @ Bk # ls2"
+        by (metis \<open>last ls1 = Bk\<close>  \<open>noDblBk CL\<close> \<open>r = Bk # rs\<close> \<open>r = rev ls1 @ Oc # rss\<close>
+            append_butlast_last_id append_eq_append_conv2 append_self_conv2
+            cell.distinct(1) hasDblBk_L1 list.inject rev_is_Nil_conv)
+      with \<open>noDblBk CL\<close> have False
+        using hasDblBk_L1 by blast
+      then show ?thesis by auto
+    next
+      case Oc
+      with \<open>ls2 = b # bs\<close> show ?thesis by auto
+    qed
+  qed
+qed
+
+lemma hasDblBk_L5:
+  assumes "noDblBk CL"
+    and "r = Bk # rs"
+    and "r = rev ls1 @ Oc # rss"
+    and  "CL = ls1 @ [Bk]"
+  shows False
+  using  assms hasDblBk_L4
+  by blast
+
+lemma noDblBk_cases:
+  assumes "noDblBk C"
+      and "C = C1 @ C2"
+      and "C2 = []   \<Longrightarrow> P"
+      and "C2 = [Bk] \<Longrightarrow> P"
+      and "\<And>C3. C2 = Bk#Oc#C3 \<Longrightarrow> P"
+      and "\<And>C3. C2 = Oc#C3 \<Longrightarrow> P"
+  shows "P"
+proof -
+  have "C2 = [] \<or> C2 = [Bk] \<or> (\<exists>C3. C2 = Bk#Oc#C3 \<or> C2 = Bk#Bk#C3 \<or> C2 = Oc#C3)"   
+    by (metis (full_types) cell.exhaust list.exhaust)
+  then show ?thesis    
+    using assms(1) assms(2) assms(3) assms(4) assms(5) assms(6) hasDblBk_L3 list.distinct(1) by blast
+qed
+
+subsection \<open>Unique decomposition of tapes containing lists of numerals\<close>
+
+text \<open>A lemma about appending lists of numerals.\<close>
+
+lemma append_numeral_list: "\<lbrakk> (nl1::nat list) \<noteq> []; nl2 \<noteq> [] \<rbrakk> \<Longrightarrow> <nl1 @ nl2> = <nl1>@[Bk]@<nl2>"
+proof (induct nl1 arbitrary: nl2)
+  case Nil
+  then show ?case
+    by blast
+next
+  fix a::nat
+  fix nl1::"nat list"
+  fix nl2::"nat list"
+  assume IH: "\<And>nl2. \<lbrakk>nl1 \<noteq> []; nl2 \<noteq> []\<rbrakk> \<Longrightarrow> <nl1 @ nl2> = <nl1> @ [Bk] @ <nl2>"
+    and minor1: "a # nl1 \<noteq> []"
+    and minor2: "nl2 \<noteq> []"
+  show "<(a # nl1) @ nl2> = <a # nl1> @ [Bk] @ <nl2>"
+  proof (cases nl1)
+    assume "nl1 = []"
+    then show "<(a # nl1) @ nl2> = <a # nl1> @ [Bk] @ <nl2>"      
+      by (metis append_Cons append_Nil minor2 tape_of_list_def tape_of_nat_list.simps(2) tape_of_nat_list_cons_eq)
+  next
+    fix na nl1s
+    assume "nl1 = na # nl1s"
+    then have "nl1 \<noteq> []" by auto
+    have "<(a # nl1) @ nl2> = <a # (nl1 @ nl2)>" by auto
+    also with \<open>nl1 \<noteq> []\<close> and \<open>nl1 = na # nl1s\<close>
+    have "... = <a>@[Bk]@<(nl1 @ nl2)>"
+      by (simp add:  tape_of_nat_list_cons_eq)
+    also with  \<open>nl1 \<noteq> []\<close> and minor2 and IH
+    have "... = <a>@[Bk]@ <nl1> @ [Bk] @ <nl2>" by auto
+    finally have "<(a # nl1) @ nl2> = <a>@[Bk]@ <nl1> @ [Bk] @ <nl2>" by auto
+
+    moreover with \<open>nl1 \<noteq> []\<close> and minor2 have "<a # nl1> @ [Bk] @ <nl2> = <a>@[Bk]@ <nl1> @ [Bk] @ <nl2>"
+      by (simp add: tape_of_nat_list_cons_eq)
+    ultimately 
+    show "<(a # nl1) @ nl2> = <a # nl1> @ [Bk] @ <nl2>"
+      by auto
+  qed
+qed
+
+text \<open>A lemma about reverting lists of numerals.\<close>
+
+lemma rev_numeral_list: "rev(<nl::nat list>) = <(rev nl)>"
+proof (induct nl)
+  case Nil
+  then show ?case
+    by (simp)
+next
+  fix a::nat
+  fix nl::"nat list"
+  assume IH: "rev (<nl>) = <rev nl>"
+  show "rev (<a # nl>) = <rev (a # nl)>"
+  proof (rule tape_of_nat_list.cases[of nl])
+    assume "nl = []"
+    then have "rev (<a # nl>) = rev (<a>)"
+      by (simp add: tape_of_list_def )
+    with \<open>nl = []\<close> show ?thesis
+      by (simp add: rev_numeral tape_of_list_def )
+  next
+    fix n
+    assume "nl = [n]"
+    then have "rev (<a # nl>) = rev (<a#[n]>)" by auto
+    also have "... = rev (<a>@[Bk]@<nl>)"
+      by (simp add: \<open>nl = [n]\<close> tape_of_list_def  tape_of_nat_list_cons_eq)
+    also have "... = rev(<nl>)@[Bk]@rev(<a>)"
+      by simp
+    also with IH have "... = <rev nl>@[Bk]@rev(<a>)" by auto
+    also with  IH \<open>nl = [n]\<close> have "... = <rev (a # nl)>"
+      by (simp add: Cons_eq_append_conv hd_rev rev_numeral tape_of_list_def   )
+    finally show "rev (<a # nl>) = <rev (a # nl)>" by auto
+  next
+    fix n v va
+    assume "nl = n # v # va"
+    then have "rev (<a # nl>) = rev (<a#n # v # va>)" by auto
+    also with \<open>nl = n # v # va\<close> have "... = rev(<nl>)@[Bk]@rev(<a>)"
+      by (simp add: tape_of_list_def )
+    also with IH have "... = <rev nl>@[Bk]@rev(<a>)" by auto
+    finally have "rev (<a # nl>) = <rev nl>@[Bk]@rev(<a>)" by auto
+
+    moreover have "<rev (a # nl)> = <rev nl>@[Bk]@rev(<a>)"
+    proof -
+      have "<rev (a # nl)> = <rev nl @ [a]>" by auto
+      also 
+      from \<open>nl = n # v # va\<close> have " <rev nl @ [a]> = <rev nl>@[Bk]@rev(<a>)"
+        by (metis  list.simps(3) append_numeral_list rev_is_Nil_conv rev_numeral tape_of_list_def tape_of_nat_list.simps(2))
+      finally show "<rev (a # nl)> = <rev nl>@[Bk]@rev(<a>)" by auto
+    qed
+    ultimately show ?thesis by auto
+  qed
+qed
+
+
+text \<open>Some more lemmas about unique decomposition of tapes that contain lists of numerals.\<close>
+
+lemma unique_Bk_postfix_numeral_list_Nil: "<[]> @ Bk \<up> l1 = <yl::nat list> @ Bk \<up> l2 \<Longrightarrow> [] = yl"
+proof (induct yl arbitrary: l1  l2)
+  case Nil
+  then show ?case by auto
+next
+  fix a
+  fix yl:: "nat list"
+  fix l1 l2
+  assume IV: "\<And>l1 l2. <[]> @ Bk \<up> l1 = <yl> @ Bk \<up> l2 \<Longrightarrow> [] = yl"
+  and major: "<[]> @ Bk \<up> l1 = <a # yl> @ Bk \<up> l2"
+  then show "[] = a # yl"
+    by (metis append.assoc append.simps(1) append.simps(2) cell.distinct(1) list.sel(1) list.simps(3)
+        replicate_Suc replicate_app_Cons_same tape_of_list_def tape_of_nat_def tape_of_nat_list.elims
+        tape_of_nat_list.simps(3) tape_of_nat_list_cases2)
+qed
+
+lemma nonempty_list_of_numerals_neq_BKs: "<a# xs::nat list> \<noteq> Bk \<up> l"
+  by (metis append_Nil append_Nil2 list.simps(3) replicate_0 tape_of_list_def
+            tape_of_list_empty unique_Bk_postfix_numeral_list_Nil)
+
+(* ENHANCE: simplify proof: use cases "a < b \<or> a = b \<or> b < a" only once (earlier in the proof) *)
+lemma unique_Bk_postfix_nonempty_numeral_list:
+  "\<lbrakk> xl \<noteq> []; yl \<noteq> [];   <xl::nat list> @ Bk \<up> l1 = <yl::nat list>  @ Bk \<up> l2 \<rbrakk> \<Longrightarrow> xl = yl"
+proof (induct xl arbitrary: l1 yl l2)
+  fix l1 yl l2
+  assume "<[]> @ Bk \<up> l1 = <yl::nat list> @ Bk \<up> l2"
+  then show "[] = yl"
+    using unique_Bk_postfix_numeral_list_Nil by auto
+next
+  fix a:: nat
+  fix xl:: "nat list"
+  fix l1
+  fix yl:: "nat list"
+  fix l2
+  assume IV: "\<And>l1 yl l2. \<lbrakk>xl \<noteq> []; yl \<noteq> []; <xl> @ Bk \<up> l1 = <yl> @ Bk \<up> l2\<rbrakk> \<Longrightarrow> xl = yl"
+    and minor_xl: "a # xl \<noteq> []"
+    and minor_yl: "yl \<noteq> []"
+    and major: "<a # xl> @ Bk \<up> l1 = <yl> @ Bk \<up> l2" 
+  show "a # xl = yl"
+  proof (cases yl)
+    case Nil
+    then show ?thesis
+      by (metis major tape_of_list_empty unique_Bk_postfix_numeral_list_Nil)      
+  next
+    fix b:: nat
+    fix ys:: "nat list"
+    assume Ayl: "yl = b # ys"
+
+    have "a # xl = b # ys"
+    proof
+      show "a = b \<and> xl = ys"
+      proof (cases xl)
+        case Nil
+        then have "xl = []" .
+        from major and \<open>yl = b # ys\<close>
+        have "<a # xl> @ Bk \<up> l1 = <b # ys> @ Bk \<up> l2" by auto
+
+        with minor_xl and \<open>xl = []\<close> have "<a # xl::nat list> = <a>"
+          by (simp add: local.Nil tape_of_list_def)
+        with major and Ayl have "<a> @ Bk \<up> l1 = <b # ys> @ Bk \<up> l2" by auto
+        show "a = b \<and> xl = ys"
+        proof (cases ys)
+          case Nil
+          then have "ys = []" .
+          then have "<b # ys> = <b>"
+            by (simp add: local.Nil tape_of_list_def)
+          with \<open><a> @ Bk \<up> l1 = <b # ys> @ Bk \<up> l2\<close>
+          have "<a> @ Bk \<up> l1 = <b> @ Bk \<up> l2" by auto
+          then have "a = b" 
+            by (metis append_same_eq inj_tape_of_list unique_Bk_postfix)
+          with \<open>xl = []\<close> and \<open>ys = []\<close>
+          show ?thesis by auto
+        next
+          fix c
+          fix ys':: "nat list"
+          assume "ys = c# ys'"
+          then have "<b # ys> = <b> @ Bk # <ys>"
+            by (simp add: Ayl tape_of_list_def)
+
+          with \<open><a> @ Bk \<up> l1 = <b # ys> @ Bk \<up> l2\<close>
+          have "<a> @ Bk \<up> l1 = <b> @ Bk # <ys> @ Bk \<up> l2"
+            by simp
+
+          show "a = b \<and> xl = ys"
+          proof (cases l1)
+            case 0
+            then have "l1 = 0" .
+            with \<open><a> @ Bk \<up> l1 = <b> @ Bk # <ys> @ Bk \<up> l2\<close>
+            have "<a> = <b> @ Bk # <ys> @ Bk \<up> l2"
+              by auto
+            then have False
+              by (metis "0"   \<open><a> @ Bk \<up> l1 = <b> @ Bk # <ys> @ Bk \<up> l2\<close>
+                  cell.distinct(1)  length_Cons length_append length_replicate less_add_same_cancel1
+                  nth_append_length nth_replicate  tape_of_nat_def  zero_less_Suc)
+            then show ?thesis by auto
+          next
+            case (Suc l1')
+            then have "l1 = Suc l1'" .
+            then have "<a> @ Bk \<up> l1 = <a> @ (Bk #Bk \<up> l1')"
+              by simp
+            then have F1: "(<a> @ Bk \<up> l1)!(Suc a) = Bk"
+              by (metis cell.distinct(1) cell.exhaust length_replicate nth_append_length tape_of_nat_def)
+            have "a < b \<or> a = b \<or> b < a" by arith (* move upwards in the proof: do cases only once *)
+            then show "a = b \<and> xl = ys"
+            proof
+              assume "a < b"
+              with \<open><a> @ Bk \<up> l1 = <b> @ Bk # <ys> @ Bk \<up> l2\<close>
+              have "(<b> @ Bk # <ys> @ Bk \<up> l2)!(Suc a) \<noteq> Bk"              
+                by (simp add:  hd_of_numeral_is_Oc  nth_append'  tape_of_nat_def)
+              with F1 and \<open><a> @ Bk \<up> l1 = <b> @ Bk # <ys> @ Bk \<up> l2\<close> have False
+                by (simp add: \<open>(<a> @ Bk \<up> l1) ! Suc a = Bk\<close>)
+              then show "a = b \<and> xl = ys"
+                by auto
+            next
+              assume "a = b \<or> b < a"
+              then show ?thesis
+              proof
+                assume "b < a"
+                with \<open><a> @ Bk \<up> l1 = <b> @ Bk # <ys> @ Bk \<up> l2\<close>
+                have "(<a> @ Bk \<up> l1)!(Suc a) \<noteq> Bk"
+                  by (metis Suc_mono cell.distinct(1) length_replicate nth_append'
+                            nth_append_length nth_replicate tape_of_nat_def)
+                with F1 have False by auto
+                then show ?thesis by auto
+              next  
+                assume "a=b"
+                then have False
+                  using \<open>xl = []\<close> and \<open>ys = c# ys'\<close> and \<open><a> @ Bk \<up> l1 = <b> @ Bk # <ys> @ Bk \<up> l2\<close>                  
+                  using \<open><a> @ Bk \<up> l1 = <a> @ Bk # Bk \<up> l1'\<close> list.distinct(1) list.inject
+                    same_append_eq self_append_conv2 tape_of_list_empty unique_Bk_postfix_numeral_list_Nil
+                  by fastforce
+                then show ?thesis by auto
+              qed
+            qed
+          qed
+        qed
+      next
+        fix a'::nat 
+        fix xs:: "nat list"
+        assume "xl = a'#xs"
+
+        from major and \<open>yl = b # ys\<close>
+        have "<a # xl> @ Bk \<up> l1 = <b # ys> @ Bk \<up> l2" by auto
+
+        from \<open>xl = a'#xs\<close> have "<a # xl::nat list> = <a> @ Bk # <xl>"
+          by (simp add: tape_of_list_def)
+
+        with \<open><a # xl> @ Bk \<up> l1 = <b # ys> @ Bk \<up> l2\<close>
+        have "(<a> @ Bk # <xl>) @ Bk \<up> l1 = <b # ys> @ Bk \<up> l2" by auto
+
+        then have F2: "<a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b # ys> @ Bk \<up> l2" by auto
+
+        then have F3: "(<a> @ [Bk] @ (<xl> @ Bk \<up> l1))!(Suc a) = Bk"
+          by (metis Ayl append.simps(1) append.simps(2) length_replicate nth_append_length
+                    tape_of_nat_def)
+
+        show "a = b \<and> xl = ys"
+        proof (cases ys)
+          case Nil
+          then have "ys = []" .
+          then have "<b # ys> = <b>"
+            by (simp add: local.Nil tape_of_list_def)
+
+          with F2
+          have "<a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ Bk \<up> l2" by auto
+
+          have "a < b \<or> a = b \<or> b < a" by arith (* move upwards in the proof: do cases only once *)
+          then have False
+          proof
+            assume "a < b"
+            then have "(<b> @ Bk \<up> l2)!(Suc a) \<noteq> Bk"              
+              by (simp add: \<open>a < b\<close>   nth_append'  tape_of_nat_def)
+            with F2 and F3 show False
+              using \<open><a> @ [Bk] @ <xl> @ Bk \<up> l1 = <b> @ Bk \<up> l2\<close> by auto
+          next
+            assume "a = b \<or> b < a"
+            then show False
+            proof
+              assume "b < a"
+              show False
+              proof (cases l2)
+                case 0
+                then have "l2 = 0" .
+                then have "<b> @ Bk \<up> l2 = <b>" by auto
+                with \<open><a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ Bk \<up> l2\<close>
+                have "<a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b>" by auto
+
+                with \<open>xl = a'#xs\<close> and \<open>b < a\<close>
+                have "length (<a>) < length (<a> @ [Bk] @ (<xl> @ Bk \<up> l1))"
+                  by (metis  inj_tape_of_list le_add1 length_append less_irrefl
+                      nat_less_le nth_append' nth_equalityI)
+                with \<open>b < a\<close> have "b < length (<a> @ [Bk] @ (<xl> @ Bk \<up> l1))"                  
+                  by (simp add: \<open><a> @ [Bk] @ <xl> @ Bk \<up> l1 = <b>\<close>   tape_of_nat_def)
+                with \<open><a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b>\<close> show False                 
+                  using Suc_less_SucD \<open>b < a\<close> \<open>length (<a>) < length (<a> @ [Bk] @ <xl> @ Bk \<up> l1)\<close>
+                        length_replicate not_less_iff_gr_or_eq tape_of_nat_def by auto
+              next
+                fix l2'
+                assume "l2 = Suc l2'"
+                with \<open><a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ Bk \<up> l2\<close>
+                have "<a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ [Bk] @ Bk \<up> l2'" by auto
+
+                from \<open>b < a\<close> have "(<b> @ [Bk] @ Bk \<up> l2')!(Suc b) = Bk"
+                  by (metis  append_Cons length_replicate nth_append_length tape_of_nat_def)
+
+                moreover from \<open>b < a\<close> have "(<a> @ [Bk] @ (<xl> @ Bk \<up> l1))!(Suc b) \<noteq> Bk"                  
+                  by (simp add: Suc_mono  last_of_numeral_is_Oc  nth_append'  tape_of_nat_def)
+                ultimately show False
+                  using \<open><a> @ [Bk] @ <xl> @ Bk \<up> l1 = <b> @ [Bk] @ Bk \<up> l2'\<close> by auto
+              qed
+            next
+              assume "a=b"
+              with \<open><a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ Bk \<up> l2\<close> and \<open>xl = a'#xs\<close>
+              show False               
+                by (metis append_Nil append_eq_append_conv2  list.sel(3) list.simps(3)
+                    local.Nil same_append_eq  tape_of_list_empty tl_append2 tl_replicate
+                    unique_Bk_postfix_numeral_list_Nil)
+            qed
+          qed
+          then show ?thesis by auto
+        next
+          fix c
+          fix ys':: "nat list"
+          assume "ys = c# ys'"
+
+          from \<open>ys = c# ys'\<close> have "(<b # ys>) = (<b> @ [Bk] @ <ys>)"           
+            by (simp add: Ayl tape_of_list_def )
+
+          with F2 have "<a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ [Bk] @ <ys> @ Bk \<up> l2" by auto
+
+          have "a < b \<or> a = b \<or> b < a" by arith (* move upwards in the proof: do cases only once *)
+          then show "a = b \<and> xl = ys"
+          proof
+            assume "a < b"
+            with \<open>a < b\<close> have "(<b> @ [Bk] @ <ys> @ Bk \<up> l2) !(Suc a) \<noteq> Bk"
+              by (simp add: hd_of_numeral_is_Oc  nth_append'  tape_of_nat_def)
+
+            with F3 and \<open><a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ [Bk] @ <ys> @ Bk \<up> l2\<close>
+            have False
+              by auto
+            then show ?thesis by auto
+          next
+            assume "a = b \<or> b < a"
+            then show ?thesis
+            proof
+              assume "b < a"
+
+              from \<open>b < a\<close> and \<open><a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ [Bk] @ <ys> @ Bk \<up> l2\<close>
+              have "(<b> @ [Bk] @ <ys> @ Bk \<up> l2) ! Suc b = Bk"                  
+                by (metis  append_Cons cell.distinct(1) cell.exhaust length_replicate
+                           nth_append_length tape_of_nat_def)
+
+              moreover from \<open>b < a\<close> and \<open><a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ [Bk] @ <ys> @ Bk \<up> l2\<close>
+              have "(<a> @ [Bk] @ (<xl> @ Bk \<up> l1)) ! Suc b \<noteq>  Bk"                
+                by (metis Suc_mono cell.distinct(1) length_replicate nth_append' nth_replicate tape_of_nat_def)
+              ultimately have False using \<open><a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ [Bk] @ <ys> @ Bk \<up> l2\<close>                  
+                by auto
+              then show ?thesis by auto
+            next 
+              assume "a = b"
+              with \<open><a> @ [Bk] @ (<xl> @ Bk \<up> l1) = <b> @ [Bk] @ <ys> @ Bk \<up> l2\<close>
+              have "<xl> @ Bk \<up> l1 =  <ys> @ Bk \<up> l2" by auto
+              moreover from \<open>xl = a'#xs\<close> have "xl \<noteq> []" by auto
+              moreover from \<open>ys = c# ys'\<close> have "ys \<noteq> []" by auto
+              ultimately have "xl = ys" using IV by auto
+              with \<open>a = b\<close> show ?thesis
+                by auto
+            qed
+          qed
+        qed
+      qed
+    qed
+    with \<open>yl = b # ys\<close> show ?thesis by auto
+  qed
+qed
+
+corollary unique_Bk_postfix_numeral_list: "<xl::nat list> @ Bk \<up> l1 = <yl::nat list> @ Bk \<up> l2 \<Longrightarrow> xl = yl"
+  by (metis append_Nil tape_of_list_def tape_of_list_empty
+            unique_Bk_postfix_nonempty_numeral_list unique_Bk_postfix_numeral_list_Nil)
+
+
+text \<open>Some more lemmas about noDblBks in lists of numerals.\<close>
+
+lemma numeral_list_head_is_Oc: "(nl::nat list) \<noteq> [] \<Longrightarrow> hd (<nl>) = Oc"
+proof -
+  assume A: "(nl::nat list) \<noteq> []"
+  then have "(\<exists>r'. <nl> = Oc # r')"
+    using append_Nil tape_of_list_empty tape_of_nat_list_cases2 unique_Bk_postfix_numeral_list_Nil by fastforce
+  then obtain r' where w_r': "<nl> = Oc # r'" by blast
+  then show "hd (<nl>) = Oc" by auto
+qed
+
+lemma numeral_list_last_is_Oc: "(nl::nat list) \<noteq> [] \<Longrightarrow> last (<nl>) = Oc"
+proof -
+  assume A: "(nl::nat list) \<noteq> []"
+  then have "<nl> = <rev (rev nl)>" by auto
+  also have "... = rev (<rev nl>)" by (auto simp add: rev_numeral_list)
+  finally have "<nl> = rev (<rev nl>)" by auto
+  moreover from A have "hd (<rev nl>) = Oc" by (auto simp add: numeral_list_head_is_Oc)
+  with A have "last (rev (<rev nl>)) = Oc"
+    by (simp add: last_rev)
+  ultimately show ?thesis
+    by (simp add: \<open>last (rev (<rev nl>)) = Oc\<close>)
+qed
+
+lemma noDblBk_tape_of_nat_list_imp_noDblBk_tl: "noDblBk (<nl>) \<Longrightarrow> noDblBk (tl (<nl>))"
+proof (cases "<nl>")
+  case Nil
+  then show ?thesis
+    by (simp add: local.Nil noDblBk_Nil)
+next
+  fix a nls
+  assume "noDblBk (<nl>)" and "<nl> = a # nls"
+  then have "noDblBk (a # nls)" by auto
+  then have "\<forall>i. Suc i < length (a # nls) \<and> (a # nls) ! i = Bk \<longrightarrow> (a # nls) ! Suc i = Oc"
+    using noDblBk_def by auto
+  then have "noDblBk (nls)" using noDblBk_def  by auto
+  with \<open><nl> = a # nls\<close> show "noDblBk (tl (<nl>))" using noDblBk_def  by auto
+qed
+
+lemma noDblBk_tape_of_nat_list_cons_imp_noDblBk_tl: "noDblBk (a # <nl>) \<Longrightarrow> noDblBk (<nl>)"
+proof -
+  assume "noDblBk (a # <nl>)"
+  then have "\<forall>i. Suc i < length (a # <nl>) \<and> (a # <nl>) ! i = Bk \<longrightarrow> (a # <nl>) ! Suc i = Oc"
+    using noDblBk_def by auto
+  then show "noDblBk (<nl>)" using   noDblBk_def  by auto
+qed
+
+lemma noDblBk_tape_of_nat_list_imp_noDblBk_cons_Bk: "(nl::nat list) \<noteq> [] \<Longrightarrow> noDblBk ([Bk] @ <nl>)"
+proof -
+  assume "(nl::nat list) \<noteq> []"
+  then have major: "<(0::nat) # nl> = <0::nat> @ Bk # <nl>"
+    using tape_of_nat_list_cons_eq 
+    by auto
+  moreover have "noDblBk (<(0::nat) # nl>)" by (rule noDblBk_tape_of_nat_list)
+  ultimately have "noDblBk (<0::nat> @ Bk # <nl>)" by auto
+  then have "noDblBk (Oc # Bk # <nl>)"
+    by (simp add:  cell.exhaust noDblBk_tape_of_nat_list   tape_of_nat_def)
+  then show ?thesis 
+    using major
+    by (metis append_eq_Cons_conv  empty_replicate  list.sel(3) noDblBk_tape_of_nat_list_imp_noDblBk_tl 
+        replicate_Suc self_append_conv2 tape_of_nat_def )
+qed
+
+end
diff --git a/thys/Universal_Turing_Machine/Numerals_Ex.thy b/thys/Universal_Turing_Machine/Numerals_Ex.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/Numerals_Ex.thy
@@ -0,0 +1,59 @@
+(* Title: thys/Numerals_Ex.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+ 
+   Further contributions by Franz Regensburger (FABR) 02/2022 :
+   - Re-ordering of sections
+ *)
+
+theory Numerals_Ex
+  imports Numerals
+begin
+
+subsection \<open>About the expansion of the numeral notation\<close>
+
+(* Some spikes by FABR concerning the notation <...>:
+
+   The notation <...> produces a proper list of cells
+   where lists of natural numbers are monadic encoded as blocks of Oc\<up>(n+1) for all n in the list
+
+   The empty list of natural numbers is encoded as the empty cell list 
+ *)
+
+lemma "<[]> == []" by auto
+lemma "<[]::(nat list)> = ([]::(cell list))" by auto
+
+(* value requests typed naturals. Otherwise, the syntactic expansion of <..> fails 
+
+    value "<0>"   \<longrightarrow> Error: Term to be evaluated contains free dictionaries
+    value "<1>"   \<longrightarrow> Error: Term to be evaluated contains free dictionaries
+ *)
+
+value "<0::nat>"  (* OK *)
+value "<1::nat>"  (* OK *)
+
+(* empty nat list \<longrightarrow> empty cell list \<longrightarrow> the empty word epsilon *)
+
+value "<[]::(nat list)>"
+
+value "<[1::nat, 2::nat]>"
+
+(* tuples *)
+
+value "<(0::nat)>"
+value "<(1::nat)>"
+
+value "<(1::nat, 2::nat)>"
+
+(* the following yield identical expansions; nested tuples are flattened *)
+value "<[1::nat, 2::nat, 3::nat]>"
+value "<(1::nat, 2::nat, 3::nat)>"
+value "<(1::nat, (2::nat, 3::nat))>"
+value "<(1::nat, [2::nat, 3::nat])>"
+
+(*
+   However:, nested lists are not possible (no need for such things)
+   value "<[1::nat, [2::nat, 3::nat]]>"  \<longrightarrow> Error
+ *)
+
+end
diff --git a/thys/Universal_Turing_Machine/OneStrokeTM.thy b/thys/Universal_Turing_Machine/OneStrokeTM.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/OneStrokeTM.thy
@@ -0,0 +1,497 @@
+(* Title: thys/OnetrokeTM.thy
+   Author: Franz Regensburger (FABR) 03/2022
+ *)
+
+subsection \<open>tm\_onestroke: A Machine for deciding the empty set\<close>
+
+theory OneStrokeTM
+  imports
+    Turing_Hoare
+begin
+
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+
+subsubsection \<open>Definition of the machine tm\_onestroke\<close>
+
+text \<open>We can rely on the fact, that on the initial tape,
+two consecutive blanks mean end of input
+(see theorem @{thm "noDblBk_tape_of_nat_list"}).
+
+Thus, the machine can check both ends of the (initial) tape.
+Note however, that this is just a convention for encoding arguments for functions.
+Nevertheless, the tape is (potentially) infinite on both sides.
+\<close>
+
+definition tm_onestroke :: "instr list"
+  where
+    "tm_onestroke \<equiv> [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2)]"
+
+subsubsection \<open>The machine tm\_onestroke in action\<close>
+
+(* <[]> *)
+value "steps0 (1, [], <([]::nat list)>) tm_onestroke 0" (* "(1, [], [])" *)
+value "steps0 (1, [], <([]::nat list)>) tm_onestroke 1" (* "(3, [Bk], [])" *)
+value "steps0 (1, [], <([]::nat list)>) tm_onestroke 2" (* "(0, [Bk], [Oc])" *)
+
+lemma "steps0 (1, [], <([]::nat list)>) tm_onestroke 2 = (0, [Bk], [Oc])"
+  by (simp add: tape_of_nat_def tape_of_list_def
+                tm_onestroke_def
+                numeral_eqs_upto_12
+                step.simps steps.simps)
+
+(*  <[0]> *)
+value "steps0 (1, [], <[0::nat]>) tm_onestroke 0"  (* "(1, [], [Oc])" *)
+value "steps0 (1, [], <[0::nat]>) tm_onestroke 1"  (* "(2, [], [Bk])" *)
+value "steps0 (1, [], <[0::nat]>) tm_onestroke 2"  (* "(1, [Bk], [])" *)
+value "steps0 (1, [], <[0::nat]>) tm_onestroke 3"  (* "(3, [Bk, Bk], [])" *)
+value "steps0 (1, [], <[0::nat]>) tm_onestroke 4"  (* "(0, [Bk, Bk], [Oc])" *)
+
+lemma "steps0 (1, [], <[0::nat]>) tm_onestroke 4 = (0, [Bk, Bk], [Oc])"
+  by (simp add: tape_of_nat_def tape_of_list_def
+                tm_onestroke_def
+                numeral_eqs_upto_12
+                step.simps steps.simps)
+
+(*  <[0,0]> *)
+lemma "steps0 (1, [], <[0::nat,0]>) tm_onestroke 7 = (0, [Bk, Bk, Bk, Bk], [Oc])"
+  by (simp add: tape_of_nat_def tape_of_list_def
+                tm_onestroke_def
+                numeral_eqs_upto_12
+                step.simps steps.simps)
+
+(*  <[1,1]> *)
+lemma "steps0 (1, [], <[1::nat,1]>) tm_onestroke 11 = (0, [Bk, Bk, Bk, Bk, Bk, Bk], [Oc])"
+  by (simp add: tape_of_nat_def tape_of_list_def
+                tm_onestroke_def
+                numeral_eqs_upto_12
+                step.simps steps.simps)
+
+subsubsection \<open>Partial and Total Correctness of machine tm\_onestroke\<close>
+
+(* Assemble an invariant for the Hoare style proofs:
+
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 0"    (* "(1, [], [Oc, Oc, Bk, Oc, Oc])" *)
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 1"    (* "(2, [], [Bk, Oc, Bk, Oc, Oc])" *)
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 2"    (* "(1, [Bk], [Oc, Bk, Oc, Oc])" *)
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 3"    (* "(2, [Bk], [Bk, Bk, Oc, Oc])" <== DblBk in r *)
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 4"    (* "(1, [Bk, Bk], [Bk, Oc, Oc])" *)
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 5"    (* "(3, [Bk, Bk, Bk], [Oc, Oc])" *)
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 6"    (* "(2, [Bk, Bk, Bk], [Bk, Oc])" *)
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 7"    (* "(1, [Bk, Bk, Bk, Bk], [Oc])" *)
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 8"    (* "(2, [Bk, Bk, Bk, Bk], [Bk])" *)
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 9"    (* "(1, [Bk, Bk, Bk, Bk, Bk], [])" *)
+
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 10"   (* "(3, [Bk, Bk, Bk, Bk, Bk, Bk], [])" *)
+value "steps0 (1, [], <[1::nat,1]>) tm_onestroke 11"   (* "(0, [Bk, Bk, Bk, Bk, Bk, Bk], [Oc])" *)
+
+*)
+
+fun 
+  inv_tm_onestroke1 :: "tape \<Rightarrow> bool" and
+  inv_tm_onestroke2 :: "tape \<Rightarrow> bool" and
+  inv_tm_onestroke3 :: "tape \<Rightarrow> bool" and
+  inv_tm_onestroke0 :: "tape \<Rightarrow> bool"
+  where
+    "inv_tm_onestroke1 (l, r) = 
+        (noDblBk r \<and> l = Bk\<up> (length l) )"
+  | "inv_tm_onestroke2 (l, r) =
+        (noDblBk (tl r) \<and> l = Bk\<up> (length l) \<and> (\<exists>rs. r = Bk#rs))"
+  | "inv_tm_onestroke3 (l, r) =
+        (noDblBk r \<and> l = Bk\<up> (length l) \<and> (r= [] \<or> (\<exists>rs. r = Oc#rs)) )"
+  | "inv_tm_onestroke0 (l, r) =
+         (noDblBk r \<and> l = Bk\<up> (length l) \<and> (r = [Oc]))"
+
+fun inv_tm_onestroke :: "config \<Rightarrow> bool"
+  where
+    "inv_tm_onestroke (s, tap) = 
+        (if s = 0 then inv_tm_onestroke0 tap else
+         if s = 1 then inv_tm_onestroke1 tap else
+         if s = 2 then inv_tm_onestroke2 tap else
+         if s = 3 then inv_tm_onestroke3 tap 
+         else False)"
+
+lemma tm_onestroke_cases: 
+  fixes s::nat
+  assumes "inv_tm_onestroke (s,l,r)"
+    and "s=0 \<Longrightarrow> P"
+    and "s=1 \<Longrightarrow> P"
+    and "s=2 \<Longrightarrow> P"
+    and "s=3 \<Longrightarrow> P"
+  shows "P"
+proof -
+  have "s < 4"
+  proof (rule ccontr)
+    assume "\<not> s < 4"
+    with \<open>inv_tm_onestroke (s,l,r)\<close> show False by auto
+  qed
+  then have "s = 0 \<or> s = 1 \<or> s = 2 \<or> s = 3" by auto
+  with assms show ?thesis by auto
+qed
+
+lemma inv_tm_onestroke_step: 
+  assumes "inv_tm_onestroke cf" 
+  shows "inv_tm_onestroke (step0 cf tm_onestroke)"
+proof (cases cf)
+  case (fields s l r)
+  then have cf_cases: "cf = (s, l, r)" .
+  show "inv_tm_onestroke (step0 cf tm_onestroke)"
+  proof (rule tm_onestroke_cases)
+    from cf_cases and assms
+    show "inv_tm_onestroke (s, l, r)" by auto
+  next
+    assume "s = 0"
+    with cf_cases and assms
+    show ?thesis by (auto simp add: tm_onestroke_def)
+  next
+    assume "s = 1"
+    show ?thesis
+    proof -
+      have "inv_tm_onestroke (step0 (1, l, r) tm_onestroke)"
+      proof (cases r)
+        case Nil
+        then have "r = []" .
+        with assms and cf_cases and \<open>s = 1\<close> show ?thesis
+          by (auto simp add: tm_onestroke_def step.simps steps.simps)
+      next
+        case (Cons a rs)
+        then have "r = a # rs" .
+        show ?thesis
+        proof (cases a)
+        next
+          case Oc
+          then have "a = Oc" .
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 1\<close>
+          show ?thesis 
+            by (auto simp add: tm_onestroke_def noDblBk_def
+                               step.simps steps.simps)
+        next
+          case Bk
+          then have "a = Bk" .
+
+          from assms and cf_cases  and \<open>s = 1\<close> have "noDblBk r" by auto
+          with \<open>r = a # rs\<close> have "noDblBk rs" by (auto simp add: noDblBk_def)
+
+          from \<open>r = a # rs\<close> and \<open>a = Bk\<close> and \<open>noDblBk r\<close>          
+          have "r!0 = Bk \<and> (rs = [] \<or> r!(Suc 0) = Oc)"
+            using noDblBk_def by fastforce
+          with \<open>r = a # rs\<close> have  "(rs = [] \<or> rs!0 = Oc)" by auto
+          then have "(rs = [] \<or> (\<exists>rs'. rs = Oc#rs'))"
+            by (metis hd_conv_nth list.collapse)
+
+          from \<open>a = Bk\<close> and \<open>r = a # rs\<close> and cf_cases and \<open>s = 1\<close>
+          have "inv_tm_onestroke (step0 (1, l, r) tm_onestroke) =
+                  inv_tm_onestroke (step0 (1, l, Bk#rs) tm_onestroke)" by auto
+          also have "... = inv_tm_onestroke (3, Bk#l,rs)"
+            by (auto simp add: tm_onestroke_def step.simps steps.simps)
+
+          also with assms and \<open>r = a # rs\<close>  and \<open>a = Bk\<close> and \<open>a = Bk\<close>
+            and cf_cases and \<open>s = 1\<close> and \<open>noDblBk rs\<close>
+            and \<open>(rs = [] \<or> (\<exists>rs'. rs = Oc#rs'))\<close>
+          have "... = True"
+            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12)
+          finally show ?thesis by auto
+        qed
+      qed
+      with cf_cases and \<open>s=1\<close> show ?thesis by auto
+    qed
+  next
+    assume "s = 2"
+    show "inv_tm_onestroke (step0 cf tm_onestroke)"
+    proof -
+      have "inv_tm_onestroke (step0 (2, l, r) tm_onestroke)"
+      proof (cases r)
+        case Nil
+        with assms and cf_cases and \<open>s = 2\<close> show ?thesis
+          by (auto simp add: tm_onestroke_def numeral_eqs_upto_12)
+      next
+        case (Cons a rs)
+        then have "r = a # rs" .
+        show ?thesis
+        proof (cases a)
+          case Bk
+          then have "a = Bk" .
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 2\<close>
+          show ?thesis
+            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12
+                               step.simps steps.simps)
+        next
+          case Oc
+          then have "a = Oc" .
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 2\<close>
+          show ?thesis by (auto simp add: tm_onestroke_def numeral_eqs_upto_12)
+        qed
+      qed
+      with cf_cases and \<open>s=2\<close> show ?thesis by auto
+    qed
+  next
+    assume "s = 3"
+    show "inv_tm_onestroke (step0 cf tm_onestroke)"
+    proof -
+      have "inv_tm_onestroke (step0 (3, l, r) tm_onestroke)"
+      proof (cases r)
+        case Nil
+        with assms and cf_cases and \<open>s = 3\<close> show ?thesis
+          by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 noDblBk_def
+                             step.simps steps.simps)
+      next
+        case (Cons a rs)
+        then have "r = a # rs" .
+        show ?thesis
+        proof (cases a)
+          case Oc
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 3\<close>
+          show ?thesis
+            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 noDblBk_def
+                               step.simps steps.simps)
+        next
+          case Bk
+          then have "a = Bk" .
+          from assms and cf_cases and \<open>s = 3\<close>
+          have "(r= [] \<or> (\<exists>rs. r = Oc#rs))" by auto
+          with \<open>a = Bk\<close> and  \<open>r = a # rs\<close> have False by auto
+          then show ?thesis by auto
+        qed
+      qed
+      with cf_cases and \<open>s=3\<close> show ?thesis by auto
+    qed
+  qed
+qed
+
+lemma inv_tm_onestroke_steps: 
+  assumes "inv_tm_onestroke cf" 
+  shows "inv_tm_onestroke (steps0 cf tm_onestroke stp)"
+proof (induct stp)
+  case 0
+  with assms show ?case
+    by (auto simp add: inv_tm_onestroke_step step.simps steps.simps)
+next
+  case (Suc stp)
+  with assms show ?case
+    using inv_tm_onestroke_step step_red by auto 
+qed
+
+lemma tm_onestroke_partial_correctness:
+  assumes "\<exists>stp. is_final (steps0 (1, [], <nl:: nat list>) tm_onestroke stp)"
+  shows "\<lbrace> \<lambda>tap. tap = ([], <nl:: nat list>) \<rbrace> 
+           tm_onestroke
+         \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc]  @ Bk \<up>l) \<rbrace>"
+proof (rule Hoare_consequence)
+  show "(\<lambda>tap. tap = ([], <nl>)) \<mapsto> (\<lambda>tap. tap = ([], <nl>))" by auto
+next
+  show "inv_tm_onestroke0 \<mapsto> (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc]  @ Bk \<up>l))"
+    using assert_imp_def by auto
+next
+  show "\<lbrace> \<lambda>tap. tap = ([], <nl:: nat list>) \<rbrace> tm_onestroke \<lbrace> inv_tm_onestroke0 \<rbrace>"
+  proof (rule Hoare_haltI)
+    fix l::"cell list"
+    fix r:: "cell list"
+    assume "(l, r) = ([], <nl:: nat list>)"
+    with assms have "\<exists>n. is_final (steps0 (1, l, r) tm_onestroke n)" by auto
+    then obtain stp where w_n: "is_final (steps0 (1, l, r) tm_onestroke stp)" by blast
+
+    moreover have "inv_tm_onestroke0 holds_for steps0 (1, l, r) tm_onestroke stp"
+    proof -
+      have h: "inv_tm_onestroke (steps0 (1, [], <nl:: nat list>) tm_onestroke stp)"
+        by  (rule inv_tm_onestroke_steps)(auto simp add: noDblBk_tape_of_nat_list)
+      with  \<open>(l, r) = ([], <nl:: nat list>)\<close> show ?thesis
+        by (metis Pair_inject holds_for.elims(3) inv_tm_onestroke.elims(2) is_final_eq w_n)
+    qed
+    ultimately 
+    show "\<exists>n. is_final (steps0 (1, l, r) tm_onestroke n) \<and>
+              inv_tm_onestroke0 holds_for steps0 (1, l, r) tm_onestroke n"
+      by auto
+  qed
+qed
+
+(* --- now, we prove termination of tm_onestroke and thus total correctness --- *)
+(* 
+    Lexicographic orders (See List.measures)
+    quote: "These are useful for termination proofs"
+    
+    lemma in_measures[simp]:
+      "(x, y) \<in> measures [] = False"
+      "(x, y) \<in> measures (f # fs)
+             = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"
+*)
+
+(* Assemble a lexicographic measure function *)
+
+definition measure_tm_onestroke :: "(config \<times> config) set"
+  where
+    "measure_tm_onestroke = measures [
+      \<lambda>(s, l, r). (if s = 0 then 0 else 1),
+      \<lambda>(s, l, r). length r,
+      \<lambda>(s, l, r). count_list r Oc,
+      \<lambda>(s, l, r). (if s = 3 then 0 else 1)      
+      ]"
+
+lemma wf_measure_tm_onestroke: "wf measure_tm_onestroke"
+  unfolding measure_tm_onestroke_def
+  by (auto)
+
+lemma measure_tm_onestroke_induct [case_names Step]: 
+  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_tm_onestroke\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
+  using wf_measure_tm_onestroke
+  by (metis wf_iff_no_infinite_down_chain)
+
+(* Machine tm_onestroke always halts *)
+
+lemma tm_onestroke_induct_halts: "\<exists> stp. is_final (steps0 (1, [], <nl:: nat list>) tm_onestroke stp)"
+proof (induct rule: measure_tm_onestroke_induct)
+  case (Step stp)
+  then have "\<not>is_final (steps0 (1, [], <nl>) tm_onestroke stp)" .
+
+  have "inv_tm_onestroke (steps0 (1, [], <nl>) tm_onestroke stp)"
+  proof (rule_tac inv_tm_onestroke_steps)
+    show "inv_tm_onestroke (1, [], <nl>)"
+      by (auto simp add: noDblBk_tape_of_nat_list)
+  qed
+
+  show "(steps0 (1, [], <nl>) tm_onestroke (Suc stp), steps0 (1, [], <nl>) tm_onestroke stp)
+         \<in> measure_tm_onestroke"
+  proof (cases "steps0 (1, [], <nl>) tm_onestroke stp")
+    case (fields s l r)
+    then have cf_cases: "steps0 (1, [], <nl>) tm_onestroke stp = (s, l, r)" .
+
+    show ?thesis
+    proof (rule tm_onestroke_cases)
+      from \<open>inv_tm_onestroke (steps0 (1, [], <nl>) tm_onestroke stp)\<close> and cf_cases
+      show "inv_tm_onestroke (s, l, r)" by auto
+    next
+      assume "s=0"
+      with cf_cases \<open>\<not>is_final (steps0 (1, [], <nl>) tm_onestroke stp)\<close> show ?thesis by auto
+    next
+      assume "s=1"
+      show ?thesis
+      proof (cases r)
+        case Nil
+        then have "r = []" .
+        with cf_cases and \<open>s=1\<close> have "steps0 (1, [], <nl>) tm_onestroke stp = (1, l, [])" by auto       
+        have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
+              step0 (steps0 (1,[], <nl>) tm_onestroke stp) tm_onestroke"
+          by (rule step_red)
+        also with cf_cases and \<open>s=1\<close> and \<open>r = []\<close> have "... = step0 (1,l,[]) tm_onestroke" by auto
+        also have "... = (3,Bk#l,[])"
+          by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (3,Bk#l,[])" by auto
+
+        with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (1, l, [])\<close>
+        show ?thesis by (auto simp add: measure_tm_onestroke_def)
+      next
+        case (Cons a rs)
+        then have "r = a # rs" .
+        show ?thesis
+        proof (cases "a")
+          case Bk
+          then have "a=Bk" .
+          with cf_cases and \<open>s=1\<close> and \<open>r = a # rs\<close>
+          have "steps0 (1, [], <nl>) tm_onestroke stp = (1, l, Bk#rs)" by auto       
+
+          have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
+                step0 (steps0 (1, [], <nl>) tm_onestroke stp) tm_onestroke"
+            by (rule step_red)
+          also  with cf_cases and \<open>s=1\<close> and \<open>r = a # rs\<close> and \<open>a=Bk\<close>
+          have "... = step0 ((1, l, Bk#rs)) tm_onestroke" by auto
+          also have "... = (3,Bk#l,rs)"
+            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (3,Bk#l,rs)" by auto
+
+          with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (1, l, Bk#rs)\<close>
+          show ?thesis by (auto simp add: measure_tm_onestroke_def)
+        next
+          case Oc
+          then have "a=Oc" .
+          with cf_cases and \<open>s=1\<close> and \<open>r = a # rs\<close>
+          have "steps0 (1, [], <nl>) tm_onestroke stp = (1, l, Oc#rs)"  by auto   
+
+          have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
+                step0 (steps0 (1, [], <nl>) tm_onestroke stp) tm_onestroke"
+            by (rule step_red)
+          also  with cf_cases and \<open>s=1\<close> and \<open>r = a # rs\<close> and \<open>a=Oc\<close>
+          have "... = step0 ((1, l, Oc#rs)) tm_onestroke" by auto
+          also have "... = (2,l,Bk#rs)"
+            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (2,l,Bk#rs)" by auto
+
+          with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (1, l, Oc#rs)\<close>
+          show ?thesis by (auto simp add: measure_tm_onestroke_def)
+        qed         
+      qed
+    next
+      assume "s=2"
+      show ?thesis
+      proof -
+        from cf_cases and \<open>s=2\<close> have "steps0 (1, [], <nl>) tm_onestroke stp = (2, l, r)" by auto
+        with \<open>inv_tm_onestroke (steps0 (1, [], <nl>) tm_onestroke stp)\<close> have "(\<exists>rs. r = Bk#rs)" by auto
+        then obtain rs where "r = Bk#rs" by blast
+        with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (2, l, r)\<close>
+        have "steps0 (1, [], <nl>) tm_onestroke stp = (2, l, Bk#rs)" by auto
+
+        have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
+              step0 (steps0 (1, [], <nl>) tm_onestroke stp) tm_onestroke"
+          by (rule step_red)
+        also with cf_cases and \<open>s=2\<close> and \<open>r = Bk#rs\<close>
+        have "... = step0 (2,l,Bk#rs) tm_onestroke" by auto
+        also have "... = (1,Bk#l,rs)"
+          by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (1,Bk#l,rs)" by auto
+
+        with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (2, l, Bk#rs)\<close>
+        show ?thesis by (auto simp add: measure_tm_onestroke_def)
+      qed
+    next
+      assume "s=3"
+      show ?thesis
+      proof -
+        from cf_cases and \<open>s=3\<close> have "steps0 (1, [], <nl>) tm_onestroke stp = (3, l, r)" by auto
+        with \<open>inv_tm_onestroke (steps0 (1,[], <nl>) tm_onestroke stp)\<close> have "(r= [] \<or> (\<exists>rs. r = Oc#rs))" by auto
+        then show ?thesis
+        proof
+          assume "r = []"
+          with cf_cases and \<open>s=3\<close> have "steps0 (1, [], <nl>) tm_onestroke stp = (3, l, [])" by auto       
+          have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
+                step0 (steps0 (1, [], <nl>) tm_onestroke stp) tm_onestroke"
+            by (rule step_red)
+          also with cf_cases and \<open>s=3\<close> and \<open>r = []\<close>
+          have "... = step0 (3,l,[]) tm_onestroke" by auto
+          also have "... = (0,l,[Oc])"
+            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (0,l,[Oc])" by auto
+
+          with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (3, l, [])\<close>
+          show ?thesis by (auto simp add: measure_tm_onestroke_def)
+        next
+          assume "\<exists>rs. r = Oc # rs"
+          then obtain rs where "r = Oc # rs" by blast
+          with cf_cases and \<open>s=3\<close> have "steps0 (1, [], <nl>) tm_onestroke stp = (3, l,Oc # rs)" by auto       
+          have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) =
+                step0 (steps0 (1, [], <nl>) tm_onestroke stp) tm_onestroke"
+            by (rule step_red)
+          also with cf_cases and \<open>s=3\<close> and \<open>r = Oc # rs\<close>
+          have "... = step0 (3,l,Oc # rs) tm_onestroke" by auto
+          also have "... = (2,l,Bk#rs)"
+            by (auto simp add: tm_onestroke_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [], <nl>) tm_onestroke (Suc stp) = (2,l,Bk#rs)" by auto
+
+          with \<open>steps0 (1, [], <nl>) tm_onestroke stp = (3, l,Oc # rs)\<close>
+          show ?thesis by (auto simp add: measure_tm_onestroke_def)
+        qed
+      qed
+    qed
+  qed
+qed
+
+lemma tm_onestroke_total_correctness:
+  "\<lbrace> \<lambda>tap. tap = ([], <nl:: nat list>) \<rbrace> tm_onestroke \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc]  @ Bk \<up>l) \<rbrace>"
+proof (rule tm_onestroke_partial_correctness)
+  show "\<exists>stp. is_final (steps0 (1, [], <nl>) tm_onestroke stp)"
+    using  tm_onestroke_induct_halts by auto
+qed
+
+end
diff --git a/thys/Universal_Turing_Machine/ROOT b/thys/Universal_Turing_Machine/ROOT
--- a/thys/Universal_Turing_Machine/ROOT
+++ b/thys/Universal_Turing_Machine/ROOT
@@ -1,21 +1,72 @@
 chapter AFP
 
 session Universal_Turing_Machine (AFP) = HOL +
   options [timeout = 1200]
+
   sessions
     "HOL-Library"
-  theories
+  theories [document = false]
+     "HOL-Library.Code_Target_Int"
+     "HOL-Library.Code_Abstract_Nat"
+     "HOL-Library.Code_Binary_Nat"
+     "HOL-Library.Code_Target_Nat"
+     "HOL-Library.Code_Target_Numeral"
+
+  theories [document = pdf]
     "Turing"
+    "Turing_aux"
+    "BlanksDoNotMatter"
+    "ComposableTMs"
+    "ComposedTMs"
+
+    "Numerals"
+    "Numerals_Ex"
+
     "Turing_Hoare"
-    "Uncomputable"
+    "SemiIdTM"
+    "Turing_HaltingConditions"
+
+    "OneStrokeTM"
+    "WeakCopyTM"
+    "StrongCopyTM"
+    "TuringDecidable"
+    "TuringReducible"
+    "SimpleGoedelEncoding"
+    "HaltingProblems_K_H"
+    "HaltingProblems_K_aux"
+    "TuringComputable"
+
+    (* ------------------- *)
+
+    "DitherTM"
+    "CopyTM"
+    "TuringUnComputable_H2"
+    "TuringUnComputable_H2_original"
+
+    (* ------------------- *)
+
     "Abacus_Mopup"
     "Abacus"
-    "Abacus_Defs"
+    "Abacus_alt_Compile"
+    "Abacus_Hoare"
+
     "Rec_Def"
+    "Rec_Ex"
     "Recursive"
-    "Recs"
+
+    "Recs_alt_Def"
+    "Recs_alt_Ex"
+
     "UF"
     "UTM"
-  document_files
+
+    (* ------------------- *)
+
+    "GeneratedCode"
+
+    (* ------------------- *)
+
+document_files
     "root.bib"
     "root.tex"
+
diff --git a/thys/Universal_Turing_Machine/Rec_Def.thy b/thys/Universal_Turing_Machine/Rec_Def.thy
--- a/thys/Universal_Turing_Machine/Rec_Def.thy
+++ b/thys/Universal_Turing_Machine/Rec_Def.thy
@@ -1,55 +1,63 @@
 (* Title: thys/Rec_Def.thy
    Author: Jian Xu, Xingyuan Zhang, and Christian Urban
    Modifications: Sebastiaan Joosten
-*)
+   Modifications: Franz Regensburger (FABR) 08/2022
+     added LaTeX sections and some comments
+ *)
+
+chapter \<open>Recursive Function and their compilation into Turing Machines\<close>
 
 theory Rec_Def
   imports Main
 begin
 
+section \<open>Definition of a recursive datatype for Recursive Functions\<close>
+
 datatype recf =  z
   |  s
   |  id nat nat
   |  Cn nat recf "recf list"
   |  Pr nat recf recf
   |  Mn nat recf 
 
+section \<open>Definition of an interpreter for Recursive Functions\<close>
+
 definition pred_of_nl :: "nat list \<Rightarrow> nat list"
   where
     "pred_of_nl xs = butlast xs @ [last xs - 1]"
 
 function rec_exec :: "recf \<Rightarrow> nat list \<Rightarrow> nat"
   where
     "rec_exec z xs = 0" |
     "rec_exec s xs = (Suc (xs ! 0))" |
     "rec_exec (id m n) xs = (xs ! n)" |
     "rec_exec (Cn n f gs) xs = 
      rec_exec f (map (\<lambda> a. rec_exec a xs) gs)" | 
     "rec_exec (Pr n f g) xs = 
      (if last xs = 0 then rec_exec f (butlast xs)
       else rec_exec g (butlast xs @ (last xs - 1) # [rec_exec (Pr n f g) (butlast xs @ [last xs - 1])]))" |
     "rec_exec (Mn n f) xs = (LEAST x. rec_exec f (xs @ [x]) = 0)"
   by pat_completeness auto
 
 termination
   apply(relation "measures [\<lambda> (r, xs). size r, (\<lambda> (r, xs). last xs)]")
         apply(auto simp add: less_Suc_eq_le intro: trans_le_add2 size_list_estimation'[THEN trans_le_add1])
   done
 
 inductive terminate :: "recf \<Rightarrow> nat list \<Rightarrow> bool"
   where
     termi_z: "terminate z [n]"
   | termi_s: "terminate s [n]"
   | termi_id: "\<lbrakk>n < m; length xs = m\<rbrakk> \<Longrightarrow> terminate (id m n) xs"
   | termi_cn: "\<lbrakk>terminate f (map (\<lambda>g. rec_exec g xs) gs); 
               \<forall>g \<in> set gs. terminate g xs; length xs = n\<rbrakk> \<Longrightarrow> terminate (Cn n f gs) xs"
   | termi_pr: "\<lbrakk>\<forall> y < x. terminate g (xs @ y # [rec_exec (Pr n f g) (xs @ [y])]);
               terminate f xs;
               length xs = n\<rbrakk> 
               \<Longrightarrow> terminate (Pr n f g) (xs @ [x])"
   | termi_mn: "\<lbrakk>length xs = n; terminate f (xs @ [r]); 
               rec_exec f (xs @ [r]) = 0;
               \<forall> i < r. terminate f (xs @ [i]) \<and> rec_exec f (xs @ [i]) > 0\<rbrakk> \<Longrightarrow> terminate (Mn n f) xs"
 
 
-end
\ No newline at end of file
+end
diff --git a/thys/Universal_Turing_Machine/Rec_Ex.thy b/thys/Universal_Turing_Machine/Rec_Ex.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/Rec_Ex.thy
@@ -0,0 +1,99 @@
+(*  Title: thys/Rec_Ex.thy
+    Author: Franz Regensburger (FABR) 03/2022
+ *)
+
+section \<open>Examples for Recursive Functions based on Rec\_def\<close>
+
+theory Rec_Ex
+  imports Rec_Def
+begin
+
+
+definition plus_2 :: "recf"
+  where
+    "plus_2 = (Cn 1 s [s])"
+
+lemma "rec_exec plus_2 [0] = Suc (Suc 0)"
+  unfolding plus_2_def
+proof -
+  have "rec_exec (Cn 1 s [s]) [0] = rec_exec s (map (\<lambda> a. rec_exec a [0]) [s])"
+    by auto
+  also have "... = rec_exec s [Suc 0]"
+    by auto
+  also have "... = Suc (Suc 0)"
+    by auto
+  finally show "rec_exec (Cn 1 s [s]) [0] = Suc (Suc 0)" .
+qed
+
+lemma "rec_exec plus_2 [2] = 4"
+  unfolding plus_2_def
+ by auto
+
+lemma "rec_exec plus_2 [0] = 2"
+  unfolding plus_2_def
+ by auto
+
+text \<open>The arity parameter given to the constructors of recursive functions
+is not checked during execution by the interpreter.
+
+See the next example where we
+run @{term "pls_2"} with two arguments instead of only one.
+\<close>
+
+lemma "rec_exec plus_2 [2,3] = 4"
+  unfolding plus_2_def
+ by auto
+
+lemma "rec_exec plus_2 [2,3] = 4"
+  unfolding plus_2_def
+ by auto
+
+text \<open>What is the purpose of the arity parameter?
+
+   The argument 1 of the constructors, which is supposed to be the arity,
+   is completely ignored by @{term "rec_exec"}.
+   However, for proofing termination, we need a correct arity specification.
+\<close>
+
+lemma "terminate plus_2 [2]"
+  unfolding plus_2_def
+proof (rule Rec_Def.terminate.termi_cn)
+  show "terminate s (map (\<lambda>g. rec_exec g [2]) [s])"
+  proof -
+    have "(map (\<lambda>g. rec_exec g [2]) [s]) = [rec_exec s [2]]" by auto
+    then show ?thesis using termi_s by auto
+  qed
+next
+  show "\<forall>g\<in>set [s]. terminate g [2]" by (auto simp add: termi_s)
+next
+ (*  1. length [2] = 8
+    ahh: we need the correct arity for proving the predicate termination
+ *)
+  show "length [2] = 1" by auto
+qed
+
+lemma "terminate plus_2 [2]"
+  unfolding plus_2_def
+  by (rule Rec_Def.terminate.termi_cn) (auto simp add: termi_s)
+
+text \<open>If we try to proof termination of a run with superfluous arguments, we are stuck.
+We need the correct arity for proving the predicate termination.\<close>
+
+lemma "terminate plus_2 [2,3]"
+  unfolding plus_2_def
+proof (rule Rec_Def.terminate.termi_cn)
+  show "terminate s (map (\<lambda>g. rec_exec g [2, 3]) [s])"
+    by (auto simp add: termi_s)
+next
+  show "\<forall>g\<in>set [s]. terminate g [2, 3]"
+  proof
+    fix g
+    assume "g \<in> set [s]"
+    then show "terminate g [2, 3]"
+    proof -
+      have "terminate s [2, 3]"
+        (* this, we cannot prove based on the inductive definition of s *)
+        oops
+
+
+end
diff --git a/thys/Universal_Turing_Machine/Recs_alt_Def.thy b/thys/Universal_Turing_Machine/Recs_alt_Def.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/Recs_alt_Def.thy
@@ -0,0 +1,859 @@
+(* Title: thys/Recs_alt_Def.thy
+   Author: Christian Urban
+ *)
+
+chapter \<open>An alternative modelling of Recursive Functions\<close>
+
+theory Recs_alt_Def
+  imports Main
+    "HOL-Library.Nat_Bijection"
+    "HOL-Library.Discrete"
+begin
+
+
+text\<open>
+  A more streamlined and cleaned-up version of Recursive
+  Functions following
+
+    A Course in Formal Languages, Automata and Groups
+    I. M. Chiswell
+
+  and
+
+    Lecture on Undecidability
+    Michael M. Wolf
+\<close>
+
+declare One_nat_def[simp del]
+
+
+lemma if_zero_one [simp]:
+  "(if P then 1 else 0) = (0::nat) \<longleftrightarrow> \<not> P"
+  "(0::nat) < (if P then 1 else 0) = P"
+  "(if P then 0 else 1) = (if \<not>P then 1 else (0::nat))"
+  by (simp_all)
+
+lemma nth:
+  "(x # xs) ! 0 = x"
+  "(x # y # xs) ! 1 = y"
+  "(x # y # z # xs) ! 2 = z"
+  "(x # y # z # u # xs) ! 3 = u"
+  by (simp_all)
+
+
+section \<open>Some auxiliary lemmas about the Recursive Functions Sigma and Pi\<close>
+
+lemma setprod_atMost_Suc[simp]:
+  "(\<Prod>i \<le> Suc n. f i) = (\<Prod>i \<le> n. f i) * f(Suc n)"
+  by(simp add:atMost_Suc mult_ac)
+
+lemma setprod_lessThan_Suc[simp]:
+  "(\<Prod>i < Suc n. f i) = (\<Prod>i < n. f i) * f n"
+  by (simp add:lessThan_Suc mult_ac)
+
+lemma setsum_add_nat_ivl2: "n \<le> p  \<Longrightarrow>
+  sum f {..<n} + sum f {n..p} = sum f {..p::nat}"
+  apply(subst sum.union_disjoint[symmetric])
+     apply(auto simp add: ivl_disj_un_one)
+  done
+
+lemma setsum_eq_zero [simp]:
+  fixes f::"nat \<Rightarrow> nat"
+  shows "(\<Sum>i < n. f i) = 0 \<longleftrightarrow> (\<forall>i < n. f i = 0)"
+    "(\<Sum>i \<le> n. f i) = 0 \<longleftrightarrow> (\<forall>i \<le> n. f i = 0)"
+  by (auto)
+
+lemma setprod_eq_zero [simp]:
+  fixes f::"nat \<Rightarrow> nat"
+  shows "(\<Prod>i < n. f i) = 0 \<longleftrightarrow> (\<exists>i < n. f i = 0)"
+    "(\<Prod>i \<le> n. f i) = 0 \<longleftrightarrow> (\<exists>i \<le> n. f i = 0)"
+  by (auto)
+
+lemma setsum_one_less:
+  fixes n::nat
+  assumes "\<forall>i < n. f i \<le> 1"
+  shows "(\<Sum>i < n. f i) \<le> n"
+  using assms
+  by (induct n) (auto)
+
+lemma setsum_one_le:
+  fixes n::nat
+  assumes "\<forall>i \<le> n. f i \<le> 1"
+  shows "(\<Sum>i \<le> n. f i) \<le> Suc n"
+  using assms
+  by (induct n) (auto)
+
+lemma setsum_eq_one_le:
+  fixes n::nat
+  assumes "\<forall>i \<le> n. f i = 1"
+  shows "(\<Sum>i \<le> n. f i) = Suc n"
+  using assms
+  by (induct n) (auto)
+
+lemma setsum_least_eq:
+  fixes f::"nat \<Rightarrow> nat"
+  assumes h0: "p \<le> n"
+  assumes h1: "\<forall>i \<in> {..<p}. f i = 1"
+  assumes h2: "\<forall>i \<in> {p..n}. f i = 0"
+  shows "(\<Sum>i \<le> n. f i) = p"
+proof -
+  have eq_p: "(\<Sum>i \<in> {..<p}. f i) = p"
+    using h1 by (induct p) (simp_all)
+  have eq_zero: "(\<Sum>i \<in> {p..n}. f i) = 0"
+    using h2 by auto
+  have "(\<Sum>i \<le> n. f i) = (\<Sum>i \<in> {..<p}. f i) + (\<Sum>i \<in> {p..n}. f i)"
+    using h0 by (simp add: setsum_add_nat_ivl2)
+  also have "... = (\<Sum>i \<in> {..<p}. f i)" using eq_zero by simp
+  finally show "(\<Sum>i \<le> n. f i) = p" using eq_p by simp
+qed
+
+lemma nat_mult_le_one:
+  fixes m n::nat
+  assumes "m \<le> 1" "n \<le> 1"
+  shows "m * n \<le> 1"
+  using assms by (induct n) (auto)
+
+lemma setprod_one_le:
+  fixes f::"nat \<Rightarrow> nat"
+  assumes "\<forall>i \<le> n. f i \<le> 1"
+  shows "(\<Prod>i \<le> n. f i) \<le> 1"
+  using assms
+  by (induct n) (auto intro: nat_mult_le_one)
+
+lemma setprod_greater_zero:
+  fixes f::"nat \<Rightarrow> nat"
+  assumes "\<forall>i \<le> n. f i \<ge> 0"
+  shows "(\<Prod>i \<le> n. f i) \<ge> 0"
+  using assms by (induct n) (auto)
+
+lemma setprod_eq_one:
+  fixes f::"nat \<Rightarrow> nat"
+  assumes "\<forall>i \<le> n. f i = Suc 0"
+  shows "(\<Prod>i \<le> n. f i) = Suc 0"
+  using assms by (induct n) (auto)
+
+lemma setsum_cut_off_less:
+  fixes f::"nat \<Rightarrow> nat"
+  assumes h1: "m \<le> n"
+    and     h2: "\<forall>i \<in> {m..<n}. f i = 0"
+  shows "(\<Sum>i < n. f i) = (\<Sum>i < m. f i)"
+proof -
+  have eq_zero: "(\<Sum>i \<in> {m..<n}. f i) = 0"
+    using h2 by auto
+  have "(\<Sum>i < n. f i) = (\<Sum>i \<in> {..<m}. f i) + (\<Sum>i \<in> {m..<n}. f i)"
+    using h1 by (metis atLeast0LessThan le0 sum.atLeastLessThan_concat)
+  also have "... = (\<Sum>i \<in> {..<m}. f i)" using eq_zero by simp
+  finally show "(\<Sum>i < n. f i) = (\<Sum>i < m. f i)" by simp
+qed
+
+lemma setsum_cut_off_le:
+  fixes f::"nat \<Rightarrow> nat"
+  assumes h1: "m \<le> n"
+    and     h2: "\<forall>i \<in> {m..n}. f i = 0"
+  shows "(\<Sum>i \<le> n. f i) = (\<Sum>i < m. f i)"
+proof -
+  have eq_zero: "(\<Sum>i \<in> {m..n}. f i) = 0"
+    using h2 by auto
+  have "(\<Sum>i \<le> n. f i) = (\<Sum>i \<in> {..<m}. f i) + (\<Sum>i \<in> {m..n}. f i)"
+    using h1 by (simp add: setsum_add_nat_ivl2)
+  also have "... = (\<Sum>i \<in> {..<m}. f i)" using eq_zero by simp
+  finally show "(\<Sum>i \<le> n. f i) = (\<Sum>i < m. f i)" by simp
+qed
+
+lemma setprod_one [simp]:
+  fixes n::nat
+  shows "(\<Prod>i < n. Suc 0) = Suc 0"
+    "(\<Prod>i \<le> n. Suc 0) = Suc 0"
+  by (induct n) (simp_all)
+
+
+
+section \<open>Recursive Functions\<close>
+
+datatype recf =  Z
+  |  S
+  |  Id nat nat
+  |  Cn nat recf "recf list"
+  |  Pr nat recf recf
+  |  Mn nat recf
+
+fun arity :: "recf \<Rightarrow> nat"
+  where
+    "arity Z = 1"
+  | "arity S = 1"
+  | "arity (Id m n) = m"
+  | "arity (Cn n f gs) = n"
+  | "arity (Pr n f g) = Suc n"
+  | "arity (Mn n f) = n"
+
+text \<open>Abbreviations for calculating the arity of the constructors\<close>
+
+abbreviation
+  "CN f gs \<equiv> Cn (arity (hd gs)) f gs"
+
+abbreviation
+  "PR f g \<equiv> Pr (arity f) f g"
+
+abbreviation
+  "MN f \<equiv> Mn (arity f - 1) f"
+
+text \<open>the evaluation function and termination relation\<close>
+
+fun rec_eval :: "recf \<Rightarrow> nat list \<Rightarrow> nat"
+  where
+    "rec_eval Z xs = 0"
+  | "rec_eval S xs = Suc (xs ! 0)"
+  | "rec_eval (Id m n) xs = xs ! n"
+  | "rec_eval (Cn n f gs) xs = rec_eval f (map (\<lambda>x. rec_eval x xs) gs)"
+  | "rec_eval (Pr n f g) [] = undefined"     (* added by FABR *)
+  | "rec_eval (Pr n f g) (0 # xs) = rec_eval f xs"
+  | "rec_eval (Pr n f g) (Suc x # xs) =
+         rec_eval g (x # (rec_eval (Pr n f g) (x # xs)) # xs)"
+  | "rec_eval (Mn n f) xs = (LEAST x. rec_eval f (x # xs) = 0)"
+
+inductive
+  terminates :: "recf \<Rightarrow> nat list \<Rightarrow> bool"
+  where
+    termi_z: "terminates Z [n]"
+  | termi_s: "terminates S [n]"
+  | termi_id: "\<lbrakk>n < m; length xs = m\<rbrakk> \<Longrightarrow> terminates (Id m n) xs"
+  | termi_cn: "\<lbrakk>terminates f (map (\<lambda>g. rec_eval g xs) gs);
+              \<forall>g \<in> set gs. terminates g xs; length xs = n\<rbrakk> \<Longrightarrow> terminates (Cn n f gs) xs"
+  | termi_pr: "\<lbrakk>\<forall> y < x. terminates g (y # (rec_eval (Pr n f g) (y # xs) # xs));
+              terminates f xs;
+              length xs = n\<rbrakk>
+              \<Longrightarrow> terminates (Pr n f g) (x # xs)"
+  | termi_mn: "\<lbrakk>length xs = n; terminates f (r # xs);
+              rec_eval f (r # xs) = 0;
+              \<forall> i < r. terminates f (i # xs) \<and> rec_eval f (i # xs) > 0\<rbrakk> \<Longrightarrow> terminates (Mn n f) xs"
+
+
+section \<open>Arithmetic Functions\<close>
+
+text \<open>
+  \<open>constn n\<close> is the recursive function which computes
+  natural number \<open>n\<close>.
+\<close>
+fun constn :: "nat \<Rightarrow> recf"
+  where
+    "constn 0 = Z"  |
+    "constn (Suc n) = CN S [constn n]"
+
+definition
+  "rec_swap f = CN f [Id 2 1, Id 2 0]"
+
+definition
+  "rec_add = PR (Id 1 0) (CN S [Id 3 1])"
+
+definition
+  "rec_mult = PR Z (CN rec_add [Id 3 1, Id 3 2])"
+
+definition
+  "rec_power = rec_swap (PR (constn 1) (CN rec_mult [Id 3 1, Id 3 2]))"
+
+definition
+  "rec_fact_aux = PR (constn 1) (CN rec_mult [CN S [Id 3 0], Id 3 1])"
+
+definition
+  "rec_fact = CN rec_fact_aux [Id 1 0, Id 1 0]"
+
+definition
+  "rec_predecessor = CN (PR Z (Id 3 0)) [Id 1 0, Id 1 0]"
+
+definition
+  "rec_minus = rec_swap (PR (Id 1 0) (CN rec_predecessor [Id 3 1]))"
+
+lemma constn_lemma [simp]:
+  "rec_eval (constn n) xs = n"
+  by (induct n) (simp_all)
+
+lemma swap_lemma [simp]:
+  "rec_eval (rec_swap f) [x, y] = rec_eval f [y, x]"
+  by (simp add: rec_swap_def)
+
+lemma add_lemma [simp]:
+  "rec_eval rec_add [x, y] =  x + y"
+  by (induct x) (simp_all add: rec_add_def)
+
+lemma mult_lemma [simp]:
+  "rec_eval rec_mult [x, y] = x * y"
+  by (induct x) (simp_all add: rec_mult_def)
+
+lemma power_lemma [simp]:
+  "rec_eval rec_power [x, y] = x ^ y"
+  by (induct y) (simp_all add: rec_power_def)
+
+lemma fact_aux_lemma [simp]:
+  "rec_eval rec_fact_aux [x, y] = fact x"
+  by (induct x) (simp_all add: rec_fact_aux_def)
+
+lemma fact_lemma [simp]:
+  "rec_eval rec_fact [x] = fact x"
+  by (simp add: rec_fact_def)
+
+lemma pred_lemma [simp]:
+  "rec_eval rec_predecessor [x] =  x - 1"
+  by (induct x) (simp_all add: rec_predecessor_def)
+
+lemma minus_lemma [simp]:
+  "rec_eval rec_minus [x, y] = x - y"
+  by (induct y) (simp_all add: rec_minus_def)
+
+
+section \<open>Logical functions\<close>
+
+text \<open>
+  The \<open>sign\<close> function returns 1 when the input argument
+  is greater than \<open>0\<close>.\<close>
+
+definition
+  "rec_sign = CN rec_minus [constn 1, CN rec_minus [constn 1, Id 1 0]]"
+
+definition
+  "rec_not = CN rec_minus [constn 1, Id 1 0]"
+
+text \<open>
+  \<open>rec_eq\<close> compares two arguments: returns \<open>1\<close>
+  if they are equal; \<open>0\<close> otherwise.\<close>
+definition
+  "rec_eq = CN rec_minus [CN (constn 1) [Id 2 0], CN rec_add [rec_minus, rec_swap rec_minus]]"
+
+definition
+  "rec_noteq = CN rec_not [rec_eq]"
+
+definition
+  "rec_conj = CN rec_sign [rec_mult]"
+
+definition
+  "rec_disj = CN rec_sign [rec_add]"
+
+definition
+  "rec_imp = CN rec_disj [CN rec_not [Id 2 0], Id 2 1]"
+
+text \<open>@{term "rec_ifz [z, x, y]"} returns x if z is zero,
+  y otherwise;  @{term "rec_if [z, x, y]"} returns x if z is *not*
+  zero, y otherwise\<close>
+
+definition
+  "rec_ifz = PR (Id 2 0) (Id 4 3)"
+
+definition
+  "rec_if = CN rec_ifz [CN rec_not [Id 3 0], Id 3 1, Id 3 2]"
+
+
+lemma sign_lemma [simp]:
+  "rec_eval rec_sign [x] = (if x = 0 then 0 else 1)"
+  by (simp add: rec_sign_def)
+
+lemma not_lemma [simp]:
+  "rec_eval rec_not [x] = (if x = 0 then 1 else 0)"
+  by (simp add: rec_not_def)
+
+lemma eq_lemma [simp]:
+  "rec_eval rec_eq [x, y] = (if x = y then 1 else 0)"
+  by (simp add: rec_eq_def)
+
+lemma noteq_lemma [simp]:
+  "rec_eval rec_noteq [x, y] = (if x \<noteq> y then 1 else 0)"
+  by (simp add: rec_noteq_def)
+
+lemma conj_lemma [simp]:
+  "rec_eval rec_conj [x, y] = (if x = 0 \<or> y = 0 then 0 else 1)"
+  by (simp add: rec_conj_def)
+
+lemma disj_lemma [simp]:
+  "rec_eval rec_disj [x, y] = (if x = 0 \<and> y = 0 then 0 else 1)"
+  by (simp add: rec_disj_def)
+
+lemma imp_lemma [simp]:
+  "rec_eval rec_imp [x, y] = (if 0 < x \<and> y = 0 then 0 else 1)"
+  by (simp add: rec_imp_def)
+
+lemma ifz_lemma [simp]:
+  "rec_eval rec_ifz [z, x, y] = (if z = 0 then x else y)"
+  by (cases z) (simp_all add: rec_ifz_def)
+
+lemma if_lemma [simp]:
+  "rec_eval rec_if [z, x, y] = (if 0 < z then x else y)"
+  by (simp add: rec_if_def)
+
+section \<open>Less and Le Relations\<close>
+
+text \<open>
+  \<open>rec_less\<close> compares two arguments and returns \<open>1\<close> if
+  the first is less than the second; otherwise returns \<open>0\<close>.\<close>
+
+definition
+  "rec_less = CN rec_sign [rec_swap rec_minus]"
+
+definition
+  "rec_le = CN rec_disj [rec_less, rec_eq]"
+
+lemma less_lemma [simp]:
+  "rec_eval rec_less [x, y] = (if x < y then 1 else 0)"
+  by (simp add: rec_less_def)
+
+lemma le_lemma [simp]:
+  "rec_eval rec_le [x, y] = (if (x \<le> y) then 1 else 0)"
+  by(simp add: rec_le_def)
+
+
+section \<open>Summation and Product Functions\<close>
+
+definition
+  "rec_sigma1 f = PR (CN f [CN Z [Id 1 0], Id 1 0])
+                     (CN rec_add [Id 3 1, CN f [CN S [Id 3 0], Id 3 2]])"
+
+definition
+  "rec_sigma2 f = PR (CN f [CN Z [Id 2 0], Id 2 0, Id 2 1])
+                     (CN rec_add [Id 4 1, CN f [CN S [Id 4 0], Id 4 2, Id 4 3]])"
+
+definition
+  "rec_accum1 f = PR (CN f [CN Z [Id 1 0], Id 1 0])
+                     (CN rec_mult [Id 3 1, CN f [CN S [Id 3 0], Id 3 2]])"
+
+definition
+  "rec_accum2 f = PR (CN f [CN Z [Id 2 0], Id 2 0, Id 2 1])
+                     (CN rec_mult [Id 4 1, CN f [CN S [Id 4 0], Id 4 2, Id 4 3]])"
+
+definition
+  "rec_accum3 f = PR (CN f [CN Z [Id 3 0], Id 3 0, Id 3 1, Id 3 2])
+                     (CN rec_mult [Id 5 1, CN f [CN S [Id 5 0], Id 5 2, Id 5 3, Id 5 4]])"
+
+
+lemma sigma1_lemma [simp]:
+  shows "rec_eval (rec_sigma1 f) [x, y] = (\<Sum> z \<le> x. rec_eval f [z, y])"
+  by (induct x) (simp_all add: rec_sigma1_def)
+
+lemma sigma2_lemma [simp]:
+  shows "rec_eval (rec_sigma2 f) [x, y1, y2] = (\<Sum> z \<le> x. rec_eval f  [z, y1, y2])"
+  by (induct x) (simp_all add: rec_sigma2_def)
+
+lemma accum1_lemma [simp]:
+  shows "rec_eval (rec_accum1 f) [x, y] = (\<Prod> z \<le> x. rec_eval f  [z, y])"
+  by (induct x) (simp_all add: rec_accum1_def)
+
+lemma accum2_lemma [simp]:
+  shows "rec_eval (rec_accum2 f) [x, y1, y2] = (\<Prod> z \<le> x. rec_eval f  [z, y1, y2])"
+  by (induct x) (simp_all add: rec_accum2_def)
+
+lemma accum3_lemma [simp]:
+  shows "rec_eval (rec_accum3 f) [x, y1, y2, y3] = (\<Prod> z \<le> x. (rec_eval f)  [z, y1, y2, y3])"
+  by (induct x) (simp_all add: rec_accum3_def)
+
+
+section \<open>Bounded Quantifiers\<close>
+
+definition
+  "rec_all1 f = CN rec_sign [rec_accum1 f]"
+
+definition
+  "rec_all2 f = CN rec_sign [rec_accum2 f]"
+
+definition
+  "rec_all3 f = CN rec_sign [rec_accum3 f]"
+
+definition
+  "rec_all1_less f = (let cond1 = CN rec_eq [Id 3 0, Id 3 1] in
+                      let cond2 = CN f [Id 3 0, Id 3 2]
+                      in CN (rec_all2 (CN rec_disj [cond1, cond2])) [Id 2 0, Id 2 0, Id 2 1])"
+
+definition
+  "rec_all2_less f = (let cond1 = CN rec_eq [Id 4 0, Id 4 1] in
+                      let cond2 = CN f [Id 4 0, Id 4 2, Id 4 3] in
+                      CN (rec_all3 (CN rec_disj [cond1, cond2])) [Id 3 0, Id 3 0, Id 3 1, Id 3 2])"
+
+definition
+  "rec_ex1 f = CN rec_sign [rec_sigma1 f]"
+
+definition
+  "rec_ex2 f = CN rec_sign [rec_sigma2 f]"
+
+
+lemma ex1_lemma [simp]:
+  "rec_eval (rec_ex1 f) [x, y] = (if (\<exists>z \<le> x. 0 < rec_eval f [z, y]) then 1 else 0)"
+  by (simp add: rec_ex1_def)
+
+lemma ex2_lemma [simp]:
+  "rec_eval (rec_ex2 f) [x, y1, y2] = (if (\<exists>z \<le> x. 0 < rec_eval f [z, y1, y2]) then 1 else 0)"
+  by (simp add: rec_ex2_def)
+
+lemma all1_lemma [simp]:
+  "rec_eval (rec_all1 f) [x, y] = (if (\<forall>z \<le> x. 0 < rec_eval f [z, y]) then 1 else 0)"
+  by (simp add: rec_all1_def)
+
+lemma all2_lemma [simp]:
+  "rec_eval (rec_all2 f) [x, y1, y2] = (if (\<forall>z \<le> x. 0 < rec_eval f [z, y1, y2]) then 1 else 0)"
+  by (simp add: rec_all2_def)
+
+lemma all3_lemma [simp]:
+  "rec_eval (rec_all3 f) [x, y1, y2, y3] = (if (\<forall>z \<le> x. 0 < rec_eval f [z, y1, y2, y3]) then 1 else 0)"
+  by (simp add: rec_all3_def)
+
+lemma all1_less_lemma [simp]:
+  "rec_eval (rec_all1_less f) [x, y] = (if (\<forall>z < x. 0 < rec_eval f [z, y]) then 1 else 0)"
+  apply(auto simp add: Let_def rec_all1_less_def)
+   apply (metis nat_less_le)+
+  done
+
+lemma all2_less_lemma [simp]:
+  "rec_eval (rec_all2_less f) [x, y1, y2] = (if (\<forall>z < x. 0 < rec_eval f [z, y1, y2]) then 1 else 0)"
+  apply(auto simp add: Let_def rec_all2_less_def)
+   apply(metis nat_less_le)+
+  done
+
+section \<open>Quotients\<close>
+
+definition
+  "rec_quo = (let lhs = CN S [Id 3 0] in
+              let rhs = CN rec_mult [Id 3 2, CN S [Id 3 1]] in
+              let cond = CN rec_eq [lhs, rhs] in
+              let if_stmt = CN rec_if [cond, CN S [Id 3 1], Id 3 1]
+              in PR Z if_stmt)"
+
+fun Quo where
+  "Quo x 0 = 0"
+| "Quo x (Suc y) = (if (Suc y = x * (Suc (Quo x y))) then Suc (Quo x y) else Quo x y)"
+
+lemma Quo0:
+  shows "Quo 0 y = 0"
+  by (induct y) (auto)
+
+lemma Quo1:
+  "x * (Quo x y) \<le> y"
+  by (induct y) (simp_all)
+
+lemma Quo2:
+  "b * (Quo b a) + a mod b = a"
+  by (induct a) (auto simp add: mod_Suc)
+
+lemma Quo3:
+  "n * (Quo n m) = m - m mod n"
+  using Quo2[of n m] by (auto)
+
+lemma Quo4:
+  assumes h: "0 < x"
+  shows "y < x + x * Quo x y"
+proof -
+  have "x - (y mod x) > 0" using mod_less_divisor assms by auto
+  then have "y < y + (x - (y mod x))" by simp
+  then have "y < x + (y - (y mod x))" by simp
+  then show "y < x + x * (Quo x y)" by (simp add: Quo3)
+qed
+
+lemma Quo_div:
+  shows "Quo x y = y div x"
+  by (metis Quo0 Quo1 Quo4 div_by_0 div_nat_eqI mult_Suc_right neq0_conv)
+
+lemma Quo_rec_quo:
+  shows "rec_eval rec_quo [y, x] = Quo x y"
+  by (induct y) (simp_all add: rec_quo_def)
+
+lemma quo_lemma [simp]:
+  shows "rec_eval rec_quo [y, x] = y div x"
+  by (simp add: Quo_div Quo_rec_quo)
+
+
+section \<open>Iteration\<close>
+
+definition
+  "rec_iter f = PR (Id 1 0) (CN f [Id 3 1])"
+
+fun Iter where
+  "Iter f 0 = id"
+| "Iter f (Suc n) = f \<circ> (Iter f n)"
+
+lemma Iter_comm:
+  "(Iter f n) (f x) = f ((Iter f n) x)"
+  by (induct n) (simp_all)
+
+lemma iter_lemma [simp]:
+  "rec_eval (rec_iter f) [n, x] =  Iter (\<lambda>x. rec_eval f [x]) n x"
+  by (induct n) (simp_all add: rec_iter_def)
+
+
+section \<open>Bounded Maximisation\<close>
+
+
+fun BMax_rec where
+  "BMax_rec R 0 = 0"
+| "BMax_rec R (Suc n) = (if R (Suc n) then (Suc n) else BMax_rec R n)"
+
+definition
+  BMax_set :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> nat"
+  where
+    "BMax_set R x = Max ({z. z \<le> x \<and> R z} \<union> {0})"
+
+lemma BMax_rec_eq1:
+  "BMax_rec R x = (GREATEST z. (R z \<and> z \<le> x) \<or> z = 0)"
+  apply(induct x)
+   apply(auto intro: Greatest_equality Greatest_equality[symmetric])
+  apply(simp add: le_Suc_eq)
+  by metis
+
+lemma BMax_rec_eq2:
+  "BMax_rec R x = Max ({z. z \<le> x \<and> R z} \<union> {0})"
+  apply(induct x)
+   apply(auto intro: Max_eqI Max_eqI[symmetric])
+  apply(simp add: le_Suc_eq)
+  by metis
+
+lemma BMax_rec_eq3:
+  "BMax_rec R x = Max (Set.filter (\<lambda>z. R z) {..x} \<union> {0})"
+  by (simp add: BMax_rec_eq2 Set.filter_def)
+
+definition
+  "rec_max1 f = PR Z (CN rec_ifz [CN f [CN S [Id 3 0], Id 3 2], CN S [Id 3 0], Id 3 1])"
+
+lemma max1_lemma [simp]:
+  "rec_eval (rec_max1 f) [x, y] = BMax_rec (\<lambda>u. rec_eval f [u, y] = 0) x"
+  by (induct x) (simp_all add: rec_max1_def)
+
+definition
+  "rec_max2 f = PR Z (CN rec_ifz [CN f [CN S [Id 4 0], Id 4 2, Id 4 3], CN S [Id 4 0], Id 4 1])"
+
+lemma max2_lemma [simp]:
+  "rec_eval (rec_max2 f) [x, y1, y2] = BMax_rec (\<lambda>u. rec_eval f [u, y1, y2] = 0) x"
+  by (induct x) (simp_all add: rec_max2_def)
+
+
+section \<open>Encodings using Cantor's pairing function\<close>
+
+text \<open>
+  We use Cantor's pairing function from Nat-Bijection.
+  However, we need to prove that the formulation of the
+  decoding function there is recursive. For this we first
+  prove that we can extract the maximal triangle number
+  using @{term prod_decode}.
+\<close>
+
+abbreviation Max_triangle_aux where
+  "Max_triangle_aux k z \<equiv> fst (prod_decode_aux k z) + snd (prod_decode_aux k z)"
+
+abbreviation Max_triangle where
+  "Max_triangle z \<equiv> Max_triangle_aux 0 z"
+
+abbreviation
+  "pdec1 z \<equiv> fst (prod_decode z)"
+
+abbreviation
+  "pdec2 z \<equiv> snd (prod_decode z)"
+
+abbreviation
+  "penc m n \<equiv> prod_encode (m, n)"
+
+lemma fst_prod_decode:
+  "pdec1 z = z - triangle (Max_triangle z)"
+  by (subst (3) prod_decode_inverse[symmetric])
+    (simp add: prod_encode_def prod_decode_def split: prod.split)
+
+lemma snd_prod_decode:
+  "pdec2 z = Max_triangle z - pdec1 z"
+  by (simp only: prod_decode_def)
+
+lemma le_triangle:
+  "m \<le> triangle (n + m)"
+  by (induct m) (simp_all)
+
+lemma Max_triangle_triangle_le:
+  "triangle (Max_triangle z) \<le> z"
+  by (subst (9) prod_decode_inverse[symmetric])
+    (simp add: prod_decode_def prod_encode_def split: prod.split)
+
+lemma Max_triangle_le:
+  "Max_triangle z \<le> z"
+proof -
+  have "Max_triangle z \<le> triangle (Max_triangle z)"
+    using le_triangle[of _ 0, simplified] by simp
+  also have "... \<le> z" by (rule Max_triangle_triangle_le)
+  finally show "Max_triangle z \<le> z" .
+qed
+
+lemma w_aux:
+  "Max_triangle (triangle k + m) = Max_triangle_aux k m"
+  by (simp add: prod_decode_def[symmetric] prod_decode_triangle_add)
+
+lemma y_aux: "y \<le> Max_triangle_aux y k"
+  apply(induct k arbitrary: y rule: nat_less_induct)
+  apply(subst (1 2) prod_decode_aux.simps)
+  by(auto dest!:spec mp elim:Suc_leD)
+
+lemma Max_triangle_greatest:
+  "Max_triangle z = (GREATEST k. (triangle k \<le> z \<and> k \<le> z) \<or> k = 0)"
+  apply(rule Greatest_equality[symmetric])
+   apply(rule disjI1)
+   apply(rule conjI)
+    apply(rule Max_triangle_triangle_le)
+   apply(rule Max_triangle_le)
+  apply(erule disjE)
+   apply(erule conjE)
+   apply(subst (asm) (1) le_iff_add)
+   apply(erule exE)
+   apply(clarify)
+   apply(simp only: w_aux)
+   apply(rule y_aux)
+  apply(simp)
+  done
+
+
+definition
+  "rec_triangle = CN rec_quo [CN rec_mult [Id 1 0, S], constn 2]"
+
+definition
+  "rec_max_triangle =
+       (let cond = CN rec_not [CN rec_le [CN rec_triangle [Id 2 0], Id 2 1]] in
+        CN (rec_max1 cond) [Id 1 0, Id 1 0])"
+
+
+lemma triangle_lemma [simp]:
+  "rec_eval rec_triangle [x] = triangle x"
+  by (simp add: rec_triangle_def triangle_def)
+
+lemma max_triangle_lemma [simp]:
+  "rec_eval rec_max_triangle [x] = Max_triangle x"
+  by (simp add: Max_triangle_greatest rec_max_triangle_def Let_def BMax_rec_eq1)
+
+
+text \<open>Encodings for Products\<close>
+
+definition
+  "rec_penc = CN rec_add [CN rec_triangle [CN rec_add [Id 2 0, Id 2 1]], Id 2 0]"
+
+definition
+  "rec_pdec1 = CN rec_minus [Id 1 0, CN rec_triangle [CN rec_max_triangle [Id 1 0]]]"
+
+definition
+  "rec_pdec2 = CN rec_minus [CN rec_max_triangle [Id 1 0], CN rec_pdec1 [Id 1 0]]"
+
+lemma pdec1_lemma [simp]:
+  "rec_eval rec_pdec1 [z] = pdec1 z"
+  by (simp add: rec_pdec1_def fst_prod_decode)
+
+lemma pdec2_lemma [simp]:
+  "rec_eval rec_pdec2 [z] = pdec2 z"
+  by (simp add: rec_pdec2_def snd_prod_decode)
+
+lemma penc_lemma [simp]:
+  "rec_eval rec_penc [m, n] = penc m n"
+  by (simp add: rec_penc_def prod_encode_def)
+
+
+text \<open>Encodings of Lists\<close>
+
+fun
+  lenc :: "nat list \<Rightarrow> nat"
+  where
+    "lenc [] = 0"
+  | "lenc (x # xs) = penc (Suc x) (lenc xs)"
+
+fun
+  ldec :: "nat \<Rightarrow> nat \<Rightarrow> nat"
+  where
+    "ldec z 0 = (pdec1 z) - 1"
+  | "ldec z (Suc n) = ldec (pdec2 z) n"
+
+lemma pdec_zero_simps [simp]:
+  "pdec1 0 = 0"
+  "pdec2 0 = 0"
+  by (simp_all add: prod_decode_def prod_decode_aux.simps)
+
+lemma ldec_zero:
+  "ldec 0 n = 0"
+  by (induct n) (simp_all add: prod_decode_def prod_decode_aux.simps)
+
+lemma list_encode_inverse:
+  "ldec (lenc xs) n = (if n < length xs then xs ! n else 0)"
+  by (induct xs arbitrary: n rule: lenc.induct)
+    (auto simp add: ldec_zero nth_Cons split: nat.splits)
+
+lemma lenc_length_le:
+  "length xs \<le> lenc xs"
+  by (induct xs) (simp_all add: prod_encode_def)
+
+
+text \<open>Membership for the List Encoding\<close>
+
+fun inside :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
+  "inside z 0 = (0 < z)"
+| "inside z (Suc n) = inside (pdec2 z) n"
+
+definition enclen :: "nat \<Rightarrow> nat" where
+  "enclen z = BMax_rec (\<lambda>x. inside z (x - 1)) z"
+
+lemma inside_False [simp]:
+  "inside 0 n = False"
+  by (induct n) (simp_all)
+
+lemma inside_length [simp]:
+  "inside (lenc xs) s = (s < length xs)"
+proof(induct s arbitrary: xs)
+  case 0
+  then show ?case by (cases xs) (simp_all add: prod_encode_def)
+next
+  case (Suc s)
+  then show ?case by (cases xs;auto)
+qed
+
+text \<open>Length of Encoded Lists\<close>
+
+lemma enclen_length [simp]:
+  "enclen (lenc xs) = length xs"
+  unfolding enclen_def
+  apply(simp add: BMax_rec_eq1)
+  apply(rule Greatest_equality)
+   apply(auto simp add: lenc_length_le)
+  done
+
+lemma enclen_penc [simp]:
+  "enclen (penc (Suc x) (lenc xs)) = Suc (enclen (lenc xs))"
+  by (simp only: lenc.simps[symmetric] enclen_length) (simp)
+
+lemma enclen_zero [simp]:
+  "enclen 0 = 0"
+  by (simp add: enclen_def)
+
+
+text \<open>Recursive Definitions for List Encodings\<close>
+
+fun
+  rec_lenc :: "recf list \<Rightarrow> recf"
+  where
+    "rec_lenc [] = Z"
+  | "rec_lenc (f # fs) = CN rec_penc [CN S [f], rec_lenc fs]"
+
+definition
+  "rec_ldec = CN rec_predecessor [CN rec_pdec1 [rec_swap (rec_iter rec_pdec2)]]"
+
+definition
+  "rec_inside = CN rec_less [Z, rec_swap (rec_iter rec_pdec2)]"
+
+definition
+  "rec_enclen = CN (rec_max1 (CN rec_not [CN rec_inside [Id 2 1, CN rec_predecessor [Id 2 0]]])) [Id 1 0, Id 1 0]"
+
+lemma ldec_iter:
+  "ldec z n = pdec1 (Iter pdec2 n z) - 1"
+  by (induct n arbitrary: z) (simp | subst Iter_comm)+
+
+lemma inside_iter:
+  "inside z n = (0 < Iter pdec2 n z)"
+  by (induct n arbitrary: z) (simp | subst Iter_comm)+
+
+lemma lenc_lemma [simp]:
+  "rec_eval (rec_lenc fs) xs = lenc (map (\<lambda>f. rec_eval f xs) fs)"
+  by (induct fs) (simp_all)
+
+lemma ldec_lemma [simp]:
+  "rec_eval rec_ldec [z, n] = ldec z n"
+  by (simp add: ldec_iter rec_ldec_def)
+
+lemma inside_lemma [simp]:
+  "rec_eval rec_inside [z, n] = (if inside z n then 1 else 0)"
+  by (simp add: inside_iter rec_inside_def)
+
+lemma enclen_lemma [simp]:
+  "rec_eval rec_enclen [z] = enclen z"
+  by (simp add: rec_enclen_def enclen_def)
+
+
+end
+
diff --git a/thys/Universal_Turing_Machine/Recs_alt_Ex.thy b/thys/Universal_Turing_Machine/Recs_alt_Ex.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/Recs_alt_Ex.thy
@@ -0,0 +1,93 @@
+(*  Title: thys/Recs_alt__Ex.thy
+    Author: Franz Regensburger (FABR) 03/2022
+ *)
+
+section \<open>Examples for recursive functions using the alternative definitions\<close>
+
+theory Recs_alt_Ex
+  imports Recs_alt_Def
+begin
+
+(*
+definition plus_2 :: "recf"
+  where
+    "plus_2 = (Cn 8 S [S])"      (* arity is deliberately and falsely set to 8 *)
+*)
+
+definition plus_2 :: "recf"
+  where
+    "plus_2 = (CN S [S])"  
+
+lemma "rec_eval S [0] = Suc 0"
+  by auto
+
+lemma "rec_eval plus_2 [0] = rec_eval (Cn 8 S [S]) [0]" (* arity is not checked by rec_eval *)
+  unfolding plus_2_def
+  by auto
+
+lemma "Cn 1 S [S] = CN S [S]"
+  by auto
+
+lemma "rec_eval plus_2 [0] = 2"
+  unfolding plus_2_def
+  by auto
+
+lemma "rec_eval plus_2 [2] = 4"
+  unfolding plus_2_def
+  by auto
+
+lemma "rec_eval plus_2 [0,4] = 2"  (* arity is not checked by rec_eval *)
+  unfolding plus_2_def
+  by auto
+
+(* Q: what is the purpose of the arity parameter? 
+ * A: the arity is needed for termination proofs.
+ *    See the inductive predicate 'Recs.terminates'
+ *)
+
+(* --------------- from Recs.thy --------------- *)
+
+(* 
+definition
+  "rec_add = PR (Id 1 0) (CN S [Id 3 1])"
+
+lemma add_lemma:
+  "rec_eval rec_add [x, y] =  x + y"
+  by (induct x) (simp_all add: rec_add_def)
+
+*)
+
+(* but also *)
+
+lemma add_lemma_more_args:
+  "rec_eval rec_add ([x, y] @ z) =  x + y"
+  by (induct x) (simp_all add: rec_add_def)
+
+lemma "rec_eval (Pr v va vb) [] = undefined"
+  by auto
+
+lemma add_lemma_no_args:
+  "rec_eval rec_add [] =  undefined"
+  by (simp_all add: rec_add_def)
+
+
+lemma add_lemma_one_arg:
+  "rec_eval rec_add [x] =  undefined"
+proof (induct x)
+  case 0
+(*
+  then show ?case by (auto simp add: rec_add_def)
+
+goal (1 subgoal):
+ 1. \<And>x. rec_eval rec_add [x] = undefined \<Longrightarrow> rec_eval rec_add [Suc x] = undefined 
+Failed to finish proof\<^here>:
+goal (1 subgoal):
+ 1. [] ! 0 = undefined
+*)
+  oops
+
+
+lemma "[]!0 = undefined" (* how can we prove this one? *)
+  oops
+
+end
diff --git a/thys/Universal_Turing_Machine/Recursive.thy b/thys/Universal_Turing_Machine/Recursive.thy
--- a/thys/Universal_Turing_Machine/Recursive.thy
+++ b/thys/Universal_Turing_Machine/Recursive.thy
@@ -1,2843 +1,2869 @@
 (* Title: thys/Recursive.thy
    Author: Jian Xu, Xingyuan Zhang, and Christian Urban
    Modifications: Sebastiaan Joosten
-*)
+   Modifications: Franz Regensburger (FABR) 08/2022
+     Added LaTeX sections and comments
+ *)
+
+section \<open>Compilation of Recursive Functions into Abacus Programs\<close>
 
 theory Recursive
   imports Abacus Rec_Def Abacus_Hoare
 begin
 
 fun addition :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> abc_prog"
   where
     "addition m n p = [Dec m 4, Inc n, Inc p, Goto 0, Dec p 7, Inc m, Goto 4]"
 
 fun mv_box :: "nat \<Rightarrow> nat \<Rightarrow> abc_prog"
   where
     "mv_box m n = [Dec m 3, Inc n, Goto 0]"
 
 text \<open>The compilation of \<open>z\<close>-operator.\<close>
 definition rec_ci_z :: "abc_inst list"
   where
     "rec_ci_z \<equiv> [Goto 1]"
 
 text \<open>The compilation of \<open>s\<close>-operator.\<close>
 definition rec_ci_s :: "abc_inst list"
   where
     "rec_ci_s \<equiv> (addition 0 1 2 [+] [Inc 1])"
 
 
 text \<open>The compilation of \<open>id i j\<close>-operator\<close>
 fun rec_ci_id :: "nat \<Rightarrow> nat \<Rightarrow> abc_inst list"
   where
     "rec_ci_id i j = addition j i (i + 1)"
 
 fun mv_boxes :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> abc_inst list"
   where
     "mv_boxes ab bb 0 = []" |
     "mv_boxes ab bb (Suc n) = mv_boxes ab bb n [+] mv_box (ab + n) (bb + n)"
 
 fun empty_boxes :: "nat \<Rightarrow> abc_inst list"
   where
     "empty_boxes 0 = []" |
     "empty_boxes (Suc n) = empty_boxes n [+] [Dec n 2, Goto 0]"
 
 fun cn_merge_gs ::
   "(abc_inst list \<times> nat \<times> nat) list \<Rightarrow> nat \<Rightarrow> abc_inst list"
   where
     "cn_merge_gs [] p = []" |
     "cn_merge_gs (g # gs) p = 
       (let (gprog, gpara, gn) = g in 
          gprog [+] mv_box gpara p [+] cn_merge_gs gs (Suc p))"
 
+subsection \<open>Definition of the compiler rec\_ci\<close>
 
 text \<open>
   The compiler of recursive functions, where \<open>rec_ci recf\<close> return 
   \<open>(ap, arity, fp)\<close>, where \<open>ap\<close> is the Abacus program, \<open>arity\<close> is the 
   arity of the recursive function \<open>recf\<close>, 
   \<open>fp\<close> is the amount of memory which is going to be
   used by \<open>ap\<close> for its execution. 
 \<close>
 
 fun rec_ci :: "recf \<Rightarrow> abc_inst list \<times> nat \<times> nat"
   where
     "rec_ci z = (rec_ci_z, 1, 2)" |
     "rec_ci s = (rec_ci_s, 1, 3)" |
     "rec_ci (id m n) = (rec_ci_id m n, m, m + 2)" |
     "rec_ci (Cn n f gs) = 
       (let cied_gs = map (\<lambda> g. rec_ci g) gs in
        let (fprog, fpara, fn) = rec_ci f in 
        let pstr = Max (set (Suc n # fn # (map (\<lambda> (aprog, p, n). n) cied_gs))) in
        let qstr = pstr + Suc (length gs) in 
        (cn_merge_gs cied_gs pstr [+] mv_boxes 0 qstr n [+] 
           mv_boxes pstr 0 (length gs) [+] fprog [+] 
             mv_box fpara pstr [+] empty_boxes (length gs) [+] 
              mv_box pstr n [+] mv_boxes qstr 0 n, n,  qstr + n))" |
     "rec_ci (Pr n f g) = 
          (let (fprog, fpara, fn) = rec_ci f in 
           let (gprog, gpara, gn) = rec_ci g in 
           let p = Max (set ([n + 3, fn, gn])) in 
           let e = length gprog + 7 in 
            (mv_box n p [+] fprog [+] mv_box n (Suc n) [+] 
                (([Dec p e] [+] gprog [+] 
                  [Inc n, Dec (Suc n) 3, Goto 1]) @
                      [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gprog + 4)]),
              Suc n, p + 1))" |
     "rec_ci (Mn n f) =
          (let (fprog, fpara, fn) = rec_ci f in 
           let len = length (fprog) in 
             (fprog @ [Dec (Suc n) (len + 5), Dec (Suc n) (len + 3),
              Goto (len + 1), Inc n, Goto 0], n, max (Suc n) fn))"
 
+subsection \<open>Correctness of the compiler rec\_ci\<close>
+
 declare rec_ci.simps [simp del] rec_ci_s_def[simp del] 
   rec_ci_z_def[simp del] rec_ci_id.simps[simp del]
   mv_boxes.simps[simp del] 
   mv_box.simps[simp del] addition.simps[simp del]
 
 declare abc_steps_l.simps[simp del] abc_fetch.simps[simp del] 
   abc_step_l.simps[simp del] 
 
 inductive_cases terminate_pr_reverse: "terminate (Pr n f g) xs"
 
 inductive_cases terminate_z_reverse[elim!]: "terminate z xs"
 
 inductive_cases terminate_s_reverse[elim!]: "terminate s xs"
 
 inductive_cases terminate_id_reverse[elim!]: "terminate (id m n) xs"
 
 inductive_cases terminate_cn_reverse[elim!]: "terminate (Cn n f gs) xs"
 
 inductive_cases terminate_mn_reverse[elim!]:"terminate (Mn n f) xs"
 
 fun addition_inv :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>     
                      nat list \<Rightarrow> bool"
   where
     "addition_inv (as, lm') m n p lm = 
         (let sn = lm ! n in
          let sm = lm ! m in
          lm ! p = 0 \<and>
              (if as = 0 then \<exists> x. x \<le> lm ! m \<and> lm' = lm[m := x,
                                     n := (sn + sm - x), p := (sm - x)]
              else if as = 1 then \<exists> x. x < lm ! m \<and> lm' = lm[m := x,
                             n := (sn + sm - x - 1), p := (sm - x - 1)]
              else if as = 2 then \<exists> x. x < lm ! m \<and> lm' = lm[m := x, 
                                n := (sn + sm - x), p := (sm - x - 1)]
              else if as = 3 then \<exists> x. x < lm ! m \<and> lm' = lm[m := x,
                                    n := (sn + sm - x), p := (sm - x)]
              else if as = 4 then \<exists> x. x \<le> lm ! m \<and> lm' = lm[m := x,
                                        n := (sn + sm), p := (sm - x)] 
              else if as = 5 then \<exists> x. x < lm ! m \<and> lm' = lm[m := x, 
                                   n := (sn + sm), p := (sm - x - 1)] 
              else if as = 6 then \<exists> x. x < lm ! m \<and> lm' =
                      lm[m := Suc x, n := (sn + sm), p := (sm - x - 1)]
              else if as = 7 then lm' = lm[m := sm, n := (sn + sm)]
              else False))"
 
 fun addition_stage1 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "addition_stage1 (as, lm) m p = 
           (if as = 0 \<or> as = 1 \<or> as = 2 \<or> as = 3 then 2 
            else if as = 4 \<or> as = 5 \<or> as = 6 then 1
            else 0)"
 
 fun addition_stage2 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow>  nat \<Rightarrow> nat"
   where
     "addition_stage2 (as, lm) m p = 
               (if 0 \<le> as \<and> as \<le> 3 then lm ! m
                else if 4 \<le> as \<and> as \<le> 6 then lm ! p
                else 0)"
 
 fun addition_stage3 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "addition_stage3 (as, lm) m p = 
              (if as = 1 then 4  
               else if as = 2 then 3 
               else if as = 3 then 2
               else if as = 0 then 1 
               else if as = 5 then 2
               else if as = 6 then 1 
               else if as = 4 then 0 
               else 0)"
 
 fun addition_measure :: "((nat \<times> nat list) \<times> nat \<times> nat) \<Rightarrow> 
                                                  (nat \<times> nat \<times> nat)"
   where
     "addition_measure ((as, lm), m, p) =
      (addition_stage1 (as, lm) m p, 
       addition_stage2 (as, lm) m p,
       addition_stage3 (as, lm) m p)"
 
 definition addition_LE :: "(((nat \<times> nat list) \<times> nat \<times> nat) \<times> 
                           ((nat \<times> nat list) \<times> nat \<times> nat)) set"
   where "addition_LE \<equiv> (inv_image lex_triple addition_measure)"
 
 lemma wf_additon_LE[simp]: "wf addition_LE"
   by(auto simp: addition_LE_def lex_triple_def lex_pair_def)
 
 declare addition_inv.simps[simp del]
 
 lemma update_zero_to_zero[simp]: "\<lbrakk>am ! n = (0::nat); n < length am\<rbrakk> \<Longrightarrow> am[n := 0] = am"
   apply(simp add: list_update_same_conv)
   done
 
 lemma addition_inv_init: 
   "\<lbrakk>m \<noteq> n; max m n < p; length lm > p; lm ! p = 0\<rbrakk> \<Longrightarrow>
                                    addition_inv (0, lm) m n p lm"
   apply(simp add: addition_inv.simps Let_def )
   apply(rule_tac x = "lm ! m" in exI, simp)
   done
 
 lemma abs_fetch[simp]:
   "abc_fetch 0 (addition m n p) = Some (Dec m 4)"
   "abc_fetch (Suc 0) (addition m n p) = Some (Inc n)"
   "abc_fetch 2 (addition m n p) = Some (Inc p)"
   "abc_fetch 3 (addition m n p) = Some (Goto 0)"
   "abc_fetch 4 (addition m n p) = Some (Dec p 7)"
   "abc_fetch 5 (addition m n p) = Some (Inc m)"
   "abc_fetch 6 (addition m n p) = Some (Goto 4)"
   by(simp_all add: abc_fetch.simps addition.simps)
 
 lemma exists_small_list_elem1[simp]:
   "\<lbrakk>m \<noteq> n; p < length lm; lm ! p = 0; m < p; n < p; x \<le> lm ! m; 0 < x\<rbrakk>
  \<Longrightarrow> \<exists>xa<lm ! m. lm[m := x, n := lm ! n + lm ! m - x, 
                     p := lm ! m - x, m := x - Suc 0] =
                  lm[m := xa, n := lm ! n + lm ! m - Suc xa,
                     p := lm ! m - Suc xa]"
   apply(cases x, simp, simp)
   apply(rule_tac x = "x - 1" in exI, simp add: list_update_swap 
       list_update_overwrite)
   done
 
 lemma exists_small_list_elem2[simp]:
   "\<lbrakk>m \<noteq> n; p < length lm; lm ! p = 0; m < p; n < p; x < lm ! m\<rbrakk>
    \<Longrightarrow> \<exists>xa<lm ! m. lm[m := x, n := lm ! n + lm ! m - Suc x,
                       p := lm ! m - Suc x, n := lm ! n + lm ! m - x]
                  = lm[m := xa, n := lm ! n + lm ! m - xa, 
                       p := lm ! m - Suc xa]"
   apply(rule_tac x = x in exI, 
       simp add: list_update_swap list_update_overwrite)
   done
 
 lemma exists_small_list_elem3[simp]: 
   "\<lbrakk>m \<noteq> n; p < length lm; lm ! p = 0; m < p; n < p; x < lm ! m\<rbrakk>
    \<Longrightarrow> \<exists>xa<lm ! m. lm[m := x, n := lm ! n + lm ! m - x, 
                           p := lm ! m - Suc x, p := lm ! m - x]
                  = lm[m := xa, n := lm ! n + lm ! m - xa, 
                           p := lm ! m - xa]"
   apply(rule_tac x = x in exI, simp add: list_update_overwrite)
   done
 
 lemma exists_small_list_elem4[simp]: 
   "\<lbrakk>m \<noteq> n; p < length lm; lm ! p = (0::nat); m < p; n < p; x < lm ! m\<rbrakk>
   \<Longrightarrow> \<exists>xa\<le>lm ! m. lm[m := x, n := lm ! n + lm ! m - x,
                                    p := lm ! m - x] = 
                   lm[m := xa, n := lm ! n + lm ! m - xa, 
                                    p := lm ! m - xa]"
   apply(rule_tac x = x in exI, simp)
   done
 
 lemma exists_small_list_elem5[simp]: 
   "\<lbrakk>m \<noteq> n; p < length lm; lm ! p = 0; m < p; n < p;
     x \<le> lm ! m; lm ! m \<noteq> x\<rbrakk>
   \<Longrightarrow> \<exists>xa<lm ! m. lm[m := x, n := lm ! n + lm ! m, 
                        p := lm ! m - x, p := lm ! m - Suc x] 
                = lm[m := xa, n := lm ! n + lm ! m, 
                        p := lm ! m - Suc xa]"
   apply(rule_tac x = x in exI, simp add: list_update_overwrite)
   done
 
 lemma exists_small_list_elem6[simp]:
   "\<lbrakk>m \<noteq> n; p < length lm; lm ! p = 0; m < p; n < p; x < lm ! m\<rbrakk>
   \<Longrightarrow> \<exists>xa<lm ! m. lm[m := x, n := lm ! n + lm ! m,
                              p := lm ! m - Suc x, m := Suc x]
                 = lm[m := Suc xa, n := lm ! n + lm ! m, 
                              p := lm ! m - Suc xa]"
   apply(rule_tac x = x in exI, 
       simp add: list_update_swap list_update_overwrite)
   done
 
 lemma exists_small_list_elem7[simp]: 
   "\<lbrakk>m \<noteq> n; p < length lm; lm ! p = 0; m < p; n < p; x < lm ! m\<rbrakk>
   \<Longrightarrow> \<exists>xa\<le>lm ! m. lm[m := Suc x, n := lm ! n + lm ! m, 
                              p := lm ! m - Suc x] 
                = lm[m := xa, n := lm ! n + lm ! m, p := lm ! m - xa]"
   apply(rule_tac x = "Suc x" in exI, simp)
   done
 
 lemma abc_steps_zero: "abc_steps_l asm ap 0 = asm"
   apply(cases asm, simp add: abc_steps_l.simps)
   done
 
 lemma list_double_update_2:
   "lm[a := x, b := y, a := z] = lm[b := y, a:=z]"
   by (metis list_update_overwrite list_update_swap)
 
 declare Let_def[simp]
 lemma addition_halt_lemma: 
   "\<lbrakk>m \<noteq> n; max m n < p; length lm > p\<rbrakk> \<Longrightarrow>
   \<forall>na. \<not> (\<lambda>(as, lm') (m, p). as = 7) 
         (abc_steps_l (0, lm) (addition m n p) na) (m, p) \<and> 
   addition_inv (abc_steps_l (0, lm) (addition m n p) na) m n p lm 
 \<longrightarrow> addition_inv (abc_steps_l (0, lm) (addition m n p) 
                                  (Suc na)) m n p lm 
   \<and> ((abc_steps_l (0, lm) (addition m n p) (Suc na), m, p), 
      abc_steps_l (0, lm) (addition m n p) na, m, p) \<in> addition_LE"
 proof -
-  assume assms:"m\<noteq>n" "max m n < p" "length lm > p"
+  assume assms_1: "m\<noteq>n" and assms_2: "max m n < p" and assms_3: "length lm > p"
+
   { fix na
     obtain a b where ab:"abc_steps_l (0, lm) (addition m n p) na = (a, b)" by force
     assume assms2: "\<not> (\<lambda>(as, lm') (m, p). as = 7) 
         (abc_steps_l (0, lm) (addition m n p) na) (m, p)"
-      "addition_inv (abc_steps_l (0, lm) (addition m n p) na) m n p lm"
-    have r1:"addition_inv (abc_steps_l (0, lm) (addition m n p) 
-                                 (Suc na)) m n p lm" using assms(1-3) assms2
-      unfolding abc_step_red2 ab abc_step_l.simps abc_lm_v.simps abc_lm_s.simps 
+      "addition_inv (abc_steps_l (0, lm) (addition m n p) na) m n p lm" 
+    have r1:"addition_inv (abc_steps_l (0, lm) (addition m n p)
+                                 (Suc na)) m n p lm" using assms_1 assms_2 assms_3 assms2
+      unfolding abc_step_red2 ab abc_step_l.simps abc_lm_v.simps abc_lm_s.simps
         addition_inv.simps
       by (auto split:if_splits simp add: addition_inv.simps Suc_diff_Suc)
     have r2:"((abc_steps_l (0, lm) (addition m n p) (Suc na), m, p), 
-              abc_steps_l (0, lm) (addition m n p) na, m, p) \<in> addition_LE" using assms(1-3) assms2
+              abc_steps_l (0, lm) (addition m n p) na, m, p) \<in> addition_LE" using assms_1 assms_2 assms_3 assms2
       unfolding abc_step_red2 ab 
       apply(auto split:if_splits simp add: addition_inv.simps abc_steps_zero)
       by(auto simp add: addition_LE_def lex_triple_def lex_pair_def 
           abc_step_l.simps abc_lm_v.simps abc_lm_s.simps split: if_splits)
     note r1 r2
   }
   thus ?thesis by auto
 qed
 
 lemma  addition_correct': 
   "\<lbrakk>m \<noteq> n; max m n < p; length lm > p; lm ! p = 0\<rbrakk> \<Longrightarrow> 
   \<exists> stp. (\<lambda> (as, lm'). as = 7 \<and> addition_inv (as, lm') m n p lm) 
                         (abc_steps_l (0, lm) (addition m n p) stp)"
   apply(insert halt_lemma2[of addition_LE
         "\<lambda> ((as, lm'), m, p). addition_inv (as, lm') m n p lm"
         "\<lambda> stp. (abc_steps_l (0, lm) (addition m n p) stp, m, p)"
         "\<lambda> ((as, lm'), m, p). as = 7"], 
       simp add: abc_steps_zero addition_inv_init)
   apply(drule_tac addition_halt_lemma,force,force)
   apply (simp,erule_tac exE)
   apply(rename_tac na)
   apply(rule_tac x = na in exI)
   apply(auto)
   done
 
 lemma length_addition[simp]: "length (addition a b c) = 7"
   by(auto simp: addition.simps)
 
 lemma addition_correct:
   assumes "m \<noteq> n" "max m n < p" "length lm > p" "lm ! p = 0"
-  shows "{\<lambda> a. a = lm} (addition m n p) {\<lambda> nl. addition_inv (7, nl) m n p lm}"
+  shows "\<lbrace>\<lambda> a. a = lm\<rbrace> (addition m n p) \<lbrace>\<lambda> nl. addition_inv (7, nl) m n p lm\<rbrace>"
   using assms
 proof(rule_tac abc_Hoare_haltI, simp)
   fix lma
   assume "m \<noteq> n" "m < p \<and> n < p" "p < length lm" "lm ! p = 0"
   then have "\<exists> stp. (\<lambda> (as, lm'). as = 7 \<and> addition_inv (as, lm') m n p lm) 
                         (abc_steps_l (0, lm) (addition m n p) stp)"
     by(rule_tac addition_correct', auto simp: addition_inv.simps)
   then obtain stp where "(\<lambda> (as, lm'). as = 7 \<and> addition_inv (as, lm') m n p lm) 
                         (abc_steps_l (0, lm) (addition m n p) stp)"
     using exE by presburger
   thus "\<exists>na. abc_final (abc_steps_l (0, lm) (addition m n p) na) (addition m n p) \<and>
                   (\<lambda>nl. addition_inv (7, nl) m n p lm) abc_holds_for abc_steps_l (0, lm) (addition m n p) na"
     by(auto intro:exI[of _ stp])
 qed
 
+subsubsection \<open>Correctness of compilation for constructor s\<close>
+
 lemma compile_s_correct':
-  "{\<lambda>nl. nl = n # 0 \<up> 2 @ anything} addition 0 (Suc 0) 2 [+] [Inc (Suc 0)] {\<lambda>nl. nl = n # Suc n # 0 # anything}"
+  "\<lbrace>\<lambda>nl. nl = n # 0 \<up> 2 @ anything\<rbrace> addition 0 (Suc 0) 2 [+] [Inc (Suc 0)] \<lbrace>\<lambda>nl. nl = n # Suc n # 0 # anything\<rbrace>"
 proof(rule_tac abc_Hoare_plus_halt)
-  show "{\<lambda>nl. nl = n # 0 \<up> 2 @ anything} addition 0 (Suc 0) 2 {\<lambda> nl. addition_inv (7, nl) 0 (Suc 0) 2 (n # 0 \<up> 2 @ anything)}"
+  show "\<lbrace>\<lambda>nl. nl = n # 0 \<up> 2 @ anything\<rbrace> addition 0 (Suc 0) 2 \<lbrace>\<lambda> nl. addition_inv (7, nl) 0 (Suc 0) 2 (n # 0 \<up> 2 @ anything)\<rbrace>"
     by(rule_tac addition_correct, auto simp: numeral_2_eq_2)
 next
-  show "{\<lambda>nl. addition_inv (7, nl) 0 (Suc 0) 2 (n # 0 \<up> 2 @ anything)} [Inc (Suc 0)] {\<lambda>nl. nl = n # Suc n # 0 # anything}"
+  show "\<lbrace>\<lambda>nl. addition_inv (7, nl) 0 (Suc 0) 2 (n # 0 \<up> 2 @ anything)\<rbrace> [Inc (Suc 0)] \<lbrace>\<lambda>nl. nl = n # Suc n # 0 # anything\<rbrace>"
     by(rule_tac abc_Hoare_haltI, rule_tac x = 1 in exI, auto simp: addition_inv.simps 
         abc_steps_l.simps abc_step_l.simps abc_fetch.simps numeral_2_eq_2 abc_lm_s.simps abc_lm_v.simps)
 qed
 
 declare rec_exec.simps[simp del]
 
 lemma abc_comp_commute: "(A [+] B) [+] C = A [+] (B [+] C)"
   apply(auto simp: abc_comp.simps abc_shift.simps)
   apply(rename_tac x)
   apply(case_tac x, auto)
   done
 
+lemma compile_s_correct: 
+  "\<lbrakk>rec_ci s = (ap, arity, fp); rec_exec s [n] = r\<rbrakk> \<Longrightarrow> 
+  \<lbrace>\<lambda>nl. nl = n # 0 \<up> (fp - arity) @ anything\<rbrace> ap \<lbrace>\<lambda>nl. nl = n # r # 0 \<up> (fp - Suc arity) @ anything\<rbrace>"
+  apply(auto simp: rec_ci.simps rec_ci_s_def compile_s_correct' rec_exec.simps)
+  done
 
+subsubsection \<open>Correctness of compilation for constructor z\<close>
 
 lemma compile_z_correct: 
   "\<lbrakk>rec_ci z = (ap, arity, fp); rec_exec z [n] = r\<rbrakk> \<Longrightarrow> 
-  {\<lambda>nl. nl = n # 0 \<up> (fp - arity) @ anything} ap {\<lambda>nl. nl = n # r # 0 \<up> (fp - Suc arity) @ anything}"
+  \<lbrace>\<lambda>nl. nl = n # 0 \<up> (fp - arity) @ anything\<rbrace> ap \<lbrace>\<lambda>nl. nl = n # r # 0 \<up> (fp - Suc arity) @ anything\<rbrace>"
   apply(rule_tac abc_Hoare_haltI)
   apply(rule_tac x = 1 in exI)
   apply(auto simp: abc_steps_l.simps rec_ci.simps rec_ci_z_def 
       numeral_2_eq_2 abc_fetch.simps abc_step_l.simps rec_exec.simps)
   done
 
-lemma compile_s_correct: 
-  "\<lbrakk>rec_ci s = (ap, arity, fp); rec_exec s [n] = r\<rbrakk> \<Longrightarrow> 
-  {\<lambda>nl. nl = n # 0 \<up> (fp - arity) @ anything} ap {\<lambda>nl. nl = n # r # 0 \<up> (fp - Suc arity) @ anything}"
-  apply(auto simp: rec_ci.simps rec_ci_s_def compile_s_correct' rec_exec.simps)
-  done
+subsubsection \<open>Correctness of compilation for constructor id\<close>
 
 lemma compile_id_correct':
   assumes "n < length args" 
-  shows "{\<lambda>nl. nl = args @ 0 \<up> 2 @ anything} addition n (length args) (Suc (length args))
-  {\<lambda>nl. nl = args @ rec_exec (recf.id (length args) n) args # 0 # anything}"
+  shows "\<lbrace>\<lambda>nl. nl = args @ 0 \<up> 2 @ anything\<rbrace> addition n (length args) (Suc (length args))
+  \<lbrace>\<lambda>nl. nl = args @ rec_exec (recf.id (length args) n) args # 0 # anything\<rbrace>"
 proof -
-  have "{\<lambda>nl. nl = args @ 0 \<up> 2 @ anything} addition n (length args) (Suc (length args))
-  {\<lambda>nl. addition_inv (7, nl) n (length args) (Suc (length args)) (args @ 0 \<up> 2 @ anything)}"
+  have "\<lbrace>\<lambda>nl. nl = args @ 0 \<up> 2 @ anything\<rbrace> addition n (length args) (Suc (length args))
+  \<lbrace>\<lambda>nl. addition_inv (7, nl) n (length args) (Suc (length args)) (args @ 0 \<up> 2 @ anything)\<rbrace>"
     using assms
     by(rule_tac addition_correct, auto simp: numeral_2_eq_2 nth_append)
   thus "?thesis"
     using assms
     by(simp add: addition_inv.simps rec_exec.simps 
         nth_append numeral_2_eq_2 list_update_append)
 qed
 
 lemma compile_id_correct: 
   "\<lbrakk>n < m; length xs = m; rec_ci (recf.id m n) = (ap, arity, fp); rec_exec (recf.id m n) xs = r\<rbrakk>
-       \<Longrightarrow> {\<lambda>nl. nl = xs @ 0 \<up> (fp - arity) @ anything} ap {\<lambda>nl. nl = xs @ r # 0 \<up> (fp - Suc arity) @ anything}"
+       \<Longrightarrow> \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (fp - arity) @ anything\<rbrace> ap \<lbrace>\<lambda>nl. nl = xs @ r # 0 \<up> (fp - Suc arity) @ anything\<rbrace>"
   apply(auto simp: rec_ci.simps rec_ci_id.simps compile_id_correct')
   done
 
+
+subsubsection \<open>Correctness of compilation for constructor Cn\<close>
+
 lemma cn_merge_gs_tl_app: 
   "cn_merge_gs (gs @ [g]) pstr = 
         cn_merge_gs gs pstr [+] cn_merge_gs [g] (pstr + length gs)"
   apply(induct gs arbitrary: pstr, simp add: cn_merge_gs.simps, auto)
   apply(simp add: abc_comp_commute)
   done
 
 lemma footprint_ge: 
   "rec_ci a = (p, arity, fp) \<Longrightarrow> arity < fp"
 proof(induct a)
   case (Cn x1 a x3)
   then show ?case by(cases "rec_ci a", auto simp:rec_ci.simps)
 next
   case (Pr x1 a1 a2)
   then show ?case by(cases "rec_ci a1";cases "rec_ci a2", auto simp:rec_ci.simps)
 next
   case (Mn x1 a)
   then show ?case by(cases "rec_ci a", auto simp:rec_ci.simps)
 qed (auto simp: rec_ci.simps)
 
 lemma param_pattern: 
   "\<lbrakk>terminate f xs; rec_ci f = (p, arity, fp)\<rbrakk> \<Longrightarrow> length xs = arity"
 proof(induct arbitrary: p arity fp rule: terminate.induct)
   case (termi_cn f xs gs n) thus ?case 
     by(cases "rec_ci f", (auto simp: rec_ci.simps))
 next
   case (termi_pr x g xs n f) thus ?case 
     by (cases "rec_ci f", cases "rec_ci g", auto simp: rec_ci.simps)
 next
   case (termi_mn xs n f r) thus ?case 
     by (cases "rec_ci f", auto simp: rec_ci.simps)
 qed (auto simp: rec_ci.simps)
 
 lemma replicate_merge_anywhere: 
   "x\<up>a @ x\<up>b @ ys = x\<up>(a+b) @ ys"
   by(simp add:replicate_add)
 
 fun mv_box_inv :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool"
   where
     "mv_box_inv (as, lm) m n initlm = 
          (let plus = initlm ! m + initlm ! n in
            length initlm > max m n \<and> m \<noteq> n \<and> 
               (if as = 0 then \<exists> k l. lm = initlm[m := k, n := l] \<and> 
                     k + l = plus \<and> k \<le> initlm ! m 
               else if as = 1 then \<exists> k l. lm = initlm[m := k, n := l]
                              \<and> k + l + 1 = plus \<and> k < initlm ! m 
               else if as = 2 then \<exists> k l. lm = initlm[m := k, n := l] 
                               \<and> k + l = plus \<and> k \<le> initlm ! m
               else if as = 3 then lm = initlm[m := 0, n := plus]
               else False))"
 
 fun mv_box_stage1 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "mv_box_stage1 (as, lm) m  = 
             (if as = 3 then 0 
              else 1)"
 
 fun mv_box_stage2 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "mv_box_stage2 (as, lm) m = (lm ! m)"
 
 fun mv_box_stage3 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "mv_box_stage3 (as, lm) m = (if as = 1 then 3 
                                 else if as = 2 then 2
                                 else if as = 0 then 1 
                                 else 0)"
 
 fun mv_box_measure :: "((nat \<times> nat list) \<times> nat) \<Rightarrow> (nat \<times> nat \<times> nat)"
   where
     "mv_box_measure ((as, lm), m) = 
      (mv_box_stage1 (as, lm) m, mv_box_stage2 (as, lm) m,
       mv_box_stage3 (as, lm) m)"
 
 definition lex_pair :: "((nat \<times> nat) \<times> nat \<times> nat) set"
   where
     "lex_pair = less_than <*lex*> less_than"
 
 definition lex_triple :: 
   "((nat \<times> (nat \<times> nat)) \<times> (nat \<times> (nat \<times> nat))) set"
   where
     "lex_triple \<equiv> less_than <*lex*> lex_pair"
 
 definition mv_box_LE :: 
   "(((nat \<times> nat list) \<times> nat) \<times> ((nat \<times> nat list) \<times> nat)) set"
   where 
     "mv_box_LE \<equiv> (inv_image lex_triple mv_box_measure)"
 
 lemma wf_lex_triple: "wf lex_triple"
   by (auto simp:lex_triple_def lex_pair_def)
 
 lemma wf_mv_box_le[intro]: "wf mv_box_LE"
   by(auto intro:wf_lex_triple simp: mv_box_LE_def)
 
 declare mv_box_inv.simps[simp del]
 
 lemma mv_box_inv_init:  
   "\<lbrakk>m < length initlm; n < length initlm; m \<noteq> n\<rbrakk> \<Longrightarrow> 
   mv_box_inv (0, initlm) m n initlm"
   apply(simp add: abc_steps_l.simps mv_box_inv.simps)
   apply(rule_tac x = "initlm ! m" in exI, 
       rule_tac x = "initlm ! n" in exI, simp)
   done
 
 lemma abc_fetch[simp]:
   "abc_fetch 0 (mv_box m n) = Some (Dec m 3)"
   "abc_fetch (Suc 0) (mv_box m n) = Some (Inc n)"
   "abc_fetch 2 (mv_box m n) = Some (Goto 0)"
   "abc_fetch 3 (mv_box m n) = None"
      apply(simp_all add: mv_box.simps abc_fetch.simps)
   done
 
 lemma replicate_Suc_iff_anywhere: "x # x\<up>b @ ys = x\<up>(Suc b) @ ys"
   by simp
 
 lemma exists_smaller_in_list0[simp]: 
   "\<lbrakk>m \<noteq> n; m < length initlm; n < length initlm;
     k + l = initlm ! m + initlm ! n; k \<le> initlm ! m; 0 < k\<rbrakk>
  \<Longrightarrow> \<exists>ka la. initlm[m := k, n := l, m := k - Suc 0] = 
      initlm[m := ka, n := la] \<and>
      Suc (ka + la) = initlm ! m + initlm ! n \<and> 
      ka < initlm ! m"
   apply(rule_tac x = "k - Suc 0" in exI, rule_tac x = l in exI, auto)
   apply(subgoal_tac 
       "initlm[m := k, n := l, m := k - Suc 0] = 
        initlm[n := l, m := k, m := k - Suc 0]",force intro:list_update_swap)
   by(simp add: list_update_swap)
 
 lemma exists_smaller_in_list1[simp]:
   "\<lbrakk>m \<noteq> n; m < length initlm; n < length initlm; 
     Suc (k + l) = initlm ! m + initlm ! n;
     k < initlm ! m\<rbrakk>
     \<Longrightarrow> \<exists>ka la. initlm[m := k, n := l, n := Suc l] = 
                 initlm[m := ka, n := la] \<and> 
                 ka + la = initlm ! m + initlm ! n \<and> 
                 ka \<le> initlm ! m"
   apply(rule_tac x = k in exI, rule_tac x = "Suc l" in exI, auto)
   done
 
 lemma abc_steps_prop[simp]: 
   "\<lbrakk>length initlm > max m n; m \<noteq> n\<rbrakk> \<Longrightarrow> 
    \<not> (\<lambda>(as, lm) m. as = 3) 
     (abc_steps_l (0, initlm) (mv_box m n) na) m \<and> 
   mv_box_inv (abc_steps_l (0, initlm) 
            (mv_box m n) na) m n initlm \<longrightarrow>
   mv_box_inv (abc_steps_l (0, initlm) 
            (mv_box m n) (Suc na)) m n initlm \<and>
   ((abc_steps_l (0, initlm) (mv_box m n) (Suc na), m),
    abc_steps_l (0, initlm) (mv_box m n) na, m) \<in> mv_box_LE"
   apply(rule impI, simp add: abc_step_red2)
   apply(cases "(abc_steps_l (0, initlm) (mv_box m n) na)",
       simp)
   apply(auto split:if_splits simp add:abc_steps_l.simps mv_box_inv.simps)
        apply(auto simp add: mv_box_LE_def lex_triple_def lex_pair_def 
       abc_step_l.simps abc_steps_l.simps
       mv_box_inv.simps abc_lm_v.simps abc_lm_s.simps
       split: if_splits )
   apply(rule_tac x = k in exI, rule_tac x = "Suc l" in exI, simp)
   done
 
 lemma mv_box_inv_halt: 
   "\<lbrakk>length initlm > max m n; m \<noteq> n\<rbrakk> \<Longrightarrow> 
   \<exists> stp. (\<lambda> (as, lm). as = 3 \<and> 
   mv_box_inv (as, lm) m n initlm) 
              (abc_steps_l (0::nat, initlm) (mv_box m n) stp)"
   apply(insert halt_lemma2[of mv_box_LE
         "\<lambda> ((as, lm), m). mv_box_inv (as, lm) m n initlm"
         "\<lambda> stp. (abc_steps_l (0, initlm) (mv_box m n) stp, m)"
         "\<lambda> ((as, lm), m). as = (3::nat)"
         ])
   apply(insert wf_mv_box_le)
   apply(simp add: mv_box_inv_init abc_steps_zero)
   apply(erule_tac exE)
   by (metis (no_types, lifting) case_prodE' case_prodI)
 
 lemma mv_box_halt_cond:
   "\<lbrakk>m \<noteq> n; mv_box_inv (a, b) m n lm; a = 3\<rbrakk> \<Longrightarrow> 
   b = lm[n := lm ! m + lm ! n, m := 0]"
   apply(simp add: mv_box_inv.simps, auto)
   apply(simp add: list_update_swap)
   done
 
 lemma mv_box_correct':
   "\<lbrakk>length lm > max m n; m \<noteq> n\<rbrakk> \<Longrightarrow> 
   \<exists> stp. abc_steps_l (0::nat, lm) (mv_box m n) stp
   = (3, (lm[n := (lm ! m + lm ! n)])[m := 0::nat])"
   by(drule mv_box_inv_halt, auto dest:mv_box_halt_cond)
 
 lemma length_mvbox[simp]: "length (mv_box m n) = 3"
   by(simp add: mv_box.simps)
 
 lemma mv_box_correct: 
   "\<lbrakk>length lm > max m n; m\<noteq>n\<rbrakk> 
-  \<Longrightarrow> {\<lambda> nl. nl = lm} mv_box m n {\<lambda> nl. nl = lm[n := (lm ! m + lm ! n), m:=0]}"
+  \<Longrightarrow> \<lbrace>\<lambda> nl. nl = lm\<rbrace> mv_box m n \<lbrace>\<lambda> nl. nl = lm[n := (lm ! m + lm ! n), m:=0]\<rbrace>"
   apply(drule_tac mv_box_correct', simp)
   apply(auto simp: abc_Hoare_halt_def)
   by (metis abc_final.simps abc_holds_for.simps length_mvbox)
 
 declare list_update.simps(2)[simp del]
 
 lemma zero_case_rec_exec[simp]:
   "\<lbrakk>length xs < gf; gf \<le> ft; n < length gs\<rbrakk>
   \<Longrightarrow> (rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything)
   [ft + n - length xs := rec_exec (gs ! n) xs, 0 := 0] =
   0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ rec_exec (gs ! n) xs # 0 \<up> (length gs - Suc n) @ 0 # 0 \<up> length xs @ anything"
   using list_update_append[of "rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @ map (\<lambda>i. rec_exec i xs) (take n gs)"
       "0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything" "ft + n - length xs" "rec_exec (gs ! n) xs"]
   apply(auto)
   apply(cases "length gs - n", simp, simp add: list_update.simps replicate_Suc_iff_anywhere Suc_diff_Suc del: replicate_Suc)
   apply(simp add: list_update.simps)
   done
 
 lemma compile_cn_gs_correct':
   assumes
     g_cond: "\<forall>g\<in>set (take n gs). terminate g xs \<and>
-  (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow> (\<forall>xc. {\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc} x {\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc}))"
+  (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow> (\<forall>xc. \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc\<rbrace> x \<lbrace>\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc\<rbrace>))"
     and ft: "ft = max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))"
   shows 
-    "{\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything}
+    "\<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything\<rbrace>
     cn_merge_gs (map rec_ci (take n gs)) ft
-  {\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @
-                    map (\<lambda>i. rec_exec i xs) (take n gs) @ 0\<up>(length gs - n) @ 0 \<up> Suc (length xs) @ anything}"
+  \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @
+                    map (\<lambda>i. rec_exec i xs) (take n gs) @ 0\<up>(length gs - n) @ 0 \<up> Suc (length xs) @ anything\<rbrace>"
   using g_cond
 proof(induct n)
   case 0
   have "ft > length xs"
     using ft
     by simp
   thus "?case"
     apply(rule_tac abc_Hoare_haltI)
     apply(rule_tac x = 0 in exI, simp add: abc_steps_l.simps replicate_add[THEN sym] 
         replicate_Suc[THEN sym] del: replicate_Suc)
     done
 next
   case (Suc n)
   have ind': "\<forall>g\<in>set (take n gs).
      terminate g xs \<and> (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow> 
-    (\<forall>xc. {\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc} x {\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc})) \<Longrightarrow>
-    {\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything} cn_merge_gs (map rec_ci (take n gs)) ft 
-    {\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything}"
+    (\<forall>xc. \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc\<rbrace> x \<lbrace>\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc\<rbrace>)) \<Longrightarrow>
+    \<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything\<rbrace> cn_merge_gs (map rec_ci (take n gs)) ft 
+    \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything\<rbrace>"
     by fact
   have g_newcond: "\<forall>g\<in>set (take (Suc n) gs).
-     terminate g xs \<and> (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow> (\<forall>xc. {\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc} x {\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc}))"
+     terminate g xs \<and> (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow> (\<forall>xc. \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc\<rbrace> x \<lbrace>\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc\<rbrace>))"
     by fact
   from g_newcond have ind:
-    "{\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything} cn_merge_gs (map rec_ci (take n gs)) ft 
-    {\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything}"
+    "\<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything\<rbrace> cn_merge_gs (map rec_ci (take n gs)) ft 
+    \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything\<rbrace>"
     apply(rule_tac ind', rule_tac ballI, erule_tac x = g in ballE, simp_all add: take_Suc)
     by(cases "n < length gs", simp add:take_Suc_conv_app_nth, simp)    
   show "?case"
   proof(cases "n < length gs")
     case True
     have h: "n < length gs" by fact
     thus "?thesis"
-    proof (simp add: take_Suc_conv_app_nth cn_merge_gs_tl_app)
+    proof(simp add: take_Suc_conv_app_nth cn_merge_gs_tl_app)
       obtain gp ga gf where a: "rec_ci (gs!n) = (gp, ga, gf)"
         by (metis prod_cases3)
       moreover have "min (length gs) n = n"
         using h by simp
       moreover have 
-        "{\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything}
+        "\<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything\<rbrace>
         cn_merge_gs (map rec_ci (take n gs)) ft [+] (gp [+] mv_box ga (ft + n))
-        {\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 
-        rec_exec (gs ! n) xs # 0 \<up> (length gs - Suc n) @ 0 # 0 \<up> length xs @ anything}"
+        \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 
+        rec_exec (gs ! n) xs # 0 \<up> (length gs - Suc n) @ 0 # 0 \<up> length xs @ anything\<rbrace>"
       proof(rule_tac abc_Hoare_plus_halt)
-        show "{\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything} cn_merge_gs (map rec_ci (take n gs)) ft
-          {\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything}"
+        show "\<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything\<rbrace> cn_merge_gs (map rec_ci (take n gs)) ft
+          \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything\<rbrace>"
           using ind by simp
       next
         have x: "gs!n \<in> set (take (Suc n) gs)"
           using h
           by(simp add: take_Suc_conv_app_nth)
         have b: "terminate (gs!n) xs"
           using a g_newcond h x
           by(erule_tac x = "gs!n" in ballE, simp_all)
         hence c: "length xs = ga"
           using a param_pattern by metis  
         have d: "gf > ga" using footprint_ge a by simp
         have e: "ft \<ge> gf"
           using ft a h Max_ge image_eqI
           by(simp, rule_tac max.coboundedI2, rule_tac Max_ge, simp, 
               rule_tac insertI2,  
               rule_tac f = "(\<lambda>(aprog, p, n). n)" and x = "rec_ci (gs!n)" in image_eqI, simp, 
               rule_tac x = "gs!n" in image_eqI, simp, simp)
-        show "{\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ 
-          map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything} gp [+] mv_box ga (ft + n)
-          {\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) 
-          (take n gs) @ rec_exec (gs ! n) xs # 0 \<up> (length gs - Suc n) @ 0 # 0 \<up> length xs @ anything}"
+        show "\<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ 
+          map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything\<rbrace> gp [+] mv_box ga (ft + n)
+          \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) 
+          (take n gs) @ rec_exec (gs ! n) xs # 0 \<up> (length gs - Suc n) @ 0 # 0 \<up> length xs @ anything\<rbrace>"
         proof(rule_tac abc_Hoare_plus_halt)
-          show "{\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything} gp 
-                {\<lambda>nl. nl = xs @ (rec_exec (gs!n) xs) # 0 \<up> (ft - Suc (length xs)) @ map (\<lambda>i. rec_exec i xs) 
-                              (take n gs) @  0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything}"
+          show "\<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything\<rbrace> gp 
+                \<lbrace>\<lambda>nl. nl = xs @ (rec_exec (gs!n) xs) # 0 \<up> (ft - Suc (length xs)) @ map (\<lambda>i. rec_exec i xs) 
+                              (take n gs) @  0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything\<rbrace>"
           proof -
             have 
-              "({\<lambda>nl. nl = xs @ 0 \<up> (gf - ga) @ 0\<up>(ft - gf)@map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything} 
-            gp {\<lambda>nl. nl = xs @ (rec_exec (gs!n) xs) # 0 \<up> (gf - Suc ga) @ 
-              0\<up>(ft - gf)@map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything})"
+              "(\<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (gf - ga) @ 0\<up>(ft - gf)@map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything\<rbrace> 
+            gp \<lbrace>\<lambda>nl. nl = xs @ (rec_exec (gs!n) xs) # 0 \<up> (gf - Suc ga) @ 
+              0\<up>(ft - gf)@map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 \<up> Suc (length xs) @ anything\<rbrace>)"
               using a g_newcond h x
               apply(erule_tac x = "gs!n" in ballE)
                apply(simp, simp)
               done            
             thus "?thesis"
               using a b c d e
               by(simp add: replicate_merge_anywhere)
           qed
         next
           show 
-            "{\<lambda>nl. nl = xs @ rec_exec (gs ! n) xs #
-            0 \<up> (ft - Suc (length xs)) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything}
+            "\<lbrace>\<lambda>nl. nl = xs @ rec_exec (gs ! n) xs #
+            0 \<up> (ft - Suc (length xs)) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything\<rbrace>
             mv_box ga (ft + n)
-            {\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @
-            rec_exec (gs ! n) xs # 0 \<up> (length gs - Suc n) @ 0 # 0 \<up> length xs @ anything}"
+            \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @
+            rec_exec (gs ! n) xs # 0 \<up> (length gs - Suc n) @ 0 # 0 \<up> length xs @ anything\<rbrace>"
           proof -
-            have "{\<lambda>nl. nl = xs @ rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @
-              map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything}
-              mv_box ga (ft + n) {\<lambda>nl. nl = (xs @ rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @
+            have "\<lbrace>\<lambda>nl. nl = xs @ rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @
+              map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything\<rbrace>
+              mv_box ga (ft + n) \<lbrace>\<lambda>nl. nl = (xs @ rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @
               map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything)
               [ft + n := (xs @ rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 
               0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything) ! ga +
               (xs @ rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @ 
               map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything) !
-                      (ft + n),  ga := 0]}"
+                      (ft + n),  ga := 0]\<rbrace>"
               using a c d e h
               apply(rule_tac mv_box_correct)
-              apply simp_all
+               apply(simp_all)
               done
             moreover have "(xs @ rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @
               map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything)
               [ft + n := (xs @ rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ 
               0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything) ! ga +
               (xs @ rec_exec (gs ! n) xs # 0 \<up> (ft - Suc (length xs)) @ 
               map (\<lambda>i. rec_exec i xs) (take n gs) @ 0 \<up> (length gs - n) @ 0 # 0 \<up> length xs @ anything) !
                       (ft + n),  ga := 0]= 
               xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) (take n gs) @ rec_exec (gs ! n) xs # 0 \<up> (length gs - Suc n) @ 0 # 0 \<up> length xs @ anything"
               using a c d e h
-              by(simp add: list_update_append nth_append length_replicate split: if_splits del: list_update.simps(2), auto)
+              by(simp add: list_update_append nth_append 
+                  split: if_splits, auto)
             ultimately show "?thesis"
               by(simp)
           qed
         qed  
       qed
       ultimately show 
-        "{\<lambda>nl. nl =
-          xs @
-          0 # 0 \<up> (ft + length gs) @ anything}
+        "\<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything\<rbrace>
     cn_merge_gs (map rec_ci (take n gs)) ft [+]
-    (case rec_ci (gs ! n) of
-     (gprog, gpara, gn) \<Rightarrow>
-       gprog [+] mv_box gpara (ft + n))
-    {\<lambda>nl. nl =
-          xs @
-          0 \<up> (ft - length xs) @
-          map (\<lambda>i. rec_exec i xs) (take n gs) @
-          rec_exec (gs ! n) xs #
-          0 \<up> (length gs - Suc n) @
-          0 # 0 \<up> length xs @ anything}"
+    (case rec_ci (gs ! n) of (gprog, gpara, gn) \<Rightarrow> gprog [+] mv_box gpara (ft + n))
+    \<lbrace>\<lambda>nl. nl =
+           xs @
+           0 \<up> (ft - length xs) @
+           map (\<lambda>i. rec_exec i xs) (take n gs) @
+           rec_exec (gs ! n) xs # 0 \<up> (length gs - Suc n) @ 0 # 0 \<up> length xs @ anything\<rbrace>"
         by simp
     qed
   next
     case False
     have h: "\<not> n < length gs" by fact
     hence ind': 
-      "{\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything} cn_merge_gs (map rec_ci gs) ft
-        {\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) gs @ 0 \<up> Suc (length xs) @ anything}"
+      "\<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything\<rbrace> cn_merge_gs (map rec_ci gs) ft
+        \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @ map (\<lambda>i. rec_exec i xs) gs @ 0 \<up> Suc (length xs) @ anything\<rbrace>"
       using ind
       by simp
     thus "?thesis"
       using h
       by(simp)
   qed
 qed
 
 lemma compile_cn_gs_correct:
   assumes
     g_cond: "\<forall>g\<in>set gs. terminate g xs \<and>
-  (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow> (\<forall>xc. {\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc} x {\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc}))"
+  (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow> (\<forall>xc. \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc\<rbrace> x \<lbrace>\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc\<rbrace>))"
     and ft: "ft = max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))"
   shows 
-    "{\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything}
+    "\<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft + length gs) @ anything\<rbrace>
     cn_merge_gs (map rec_ci gs) ft
-  {\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @
-                    map (\<lambda>i. rec_exec i xs) gs @ 0 \<up> Suc (length xs) @ anything}"
+  \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (ft - length xs) @
+                    map (\<lambda>i. rec_exec i xs) gs @ 0 \<up> Suc (length xs) @ anything\<rbrace>"
   using assms
   using compile_cn_gs_correct'[of "length gs" gs xs ft ffp anything ]
   apply(auto)
   done
 
 lemma length_mvboxes[simp]: "length (mv_boxes aa ba n) = 3*n"
   by(induct n, auto simp: mv_boxes.simps)
 
 lemma exp_suc: "a\<up>Suc b = a\<up>b @ [a]"
   by(simp add: exp_ind del: replicate.simps)
 
 lemma last_0[simp]: 
   "\<lbrakk>Suc n \<le> ba - aa;  length lm2 = Suc n;
     length lm3 = ba - Suc (aa + n)\<rbrakk>
   \<Longrightarrow> (last lm2 # lm3 @ butlast lm2 @ 0 # lm4) ! (ba - aa) = (0::nat)"
 proof -
   assume h: "Suc n \<le> ba - aa"
     and g: "length lm2 = Suc n" "length lm3 = ba - Suc (aa + n)"
   from h and g have k: "ba - aa = Suc (length lm3 + n)"
     by arith
   from  k show 
     "(last lm2 # lm3 @ butlast lm2 @ 0 # lm4) ! (ba - aa) = 0"
     apply(simp, insert g)
     apply(simp add: nth_append)
     done
 qed
 
 lemma butlast_last[simp]: "length lm1 = aa \<Longrightarrow>
       (lm1 @ 0\<up>n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4) ! (aa + n) = last lm2"
   apply(simp add: nth_append)
   done
 
 lemma arith_as_simp[simp]: "\<lbrakk>Suc n \<le> ba - aa; aa < ba\<rbrakk> \<Longrightarrow> 
                     (ba < Suc (aa + (ba - Suc (aa + n) + n))) = False"
   apply arith
   done
 
 lemma butlast_elem[simp]: "\<lbrakk>Suc n \<le> ba - aa; aa < ba; length lm1 = aa; 
        length lm2 = Suc n; length lm3 = ba - Suc (aa + n)\<rbrakk>
      \<Longrightarrow> (lm1 @ 0\<up>n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4) ! (ba + n) = 0"
   using nth_append[of "lm1 @ (0::'a)\<up>n @ last lm2 # lm3 @ butlast lm2" 
       "(0::'a) # lm4" "ba + n"]
   apply(simp)
   done
 
 lemma update_butlast_eq0[simp]: 
   "\<lbrakk>Suc n \<le> ba - aa; aa < ba; length lm1 = aa; length lm2 = Suc n;
                  length lm3 = ba - Suc (aa + n)\<rbrakk>
   \<Longrightarrow> (lm1 @ 0\<up>n @ last lm2 # lm3 @ butlast lm2 @ (0::nat) # lm4)
   [ba + n := last lm2, aa + n := 0] = 
   lm1 @ 0 # 0\<up>n @ lm3 @ lm2 @ lm4"
   using list_update_append[of "lm1 @ 0\<up>n @ last lm2 # lm3 @ butlast lm2" "0 # lm4" 
       "ba + n" "last lm2"]
   apply(simp add: list_update_append list_update.simps(2-) replicate_Suc_iff_anywhere exp_suc
       del: replicate_Suc)
   apply(cases lm2, simp, simp)
   done
 
 lemma update_butlast_eq1[simp]:
   "\<lbrakk>Suc (length lm1 + n) \<le> ba; length lm2 = Suc n; length lm3 = ba - Suc (length lm1 + n); 
   \<not> ba - Suc (length lm1) < ba - Suc (length lm1 + n); \<not> ba + n - length lm1 < n\<rbrakk>
     \<Longrightarrow> (0::nat) \<up> n @ (last lm2 # lm3 @ butlast lm2 @ 0 # lm4)[ba - length lm1 := last lm2, 0 := 0] =
   0 # 0 \<up> n @ lm3 @ lm2 @ lm4"
   apply(subgoal_tac "ba - length lm1 = Suc n + length lm3", simp add: list_update.simps(2-) list_update_append)
    apply(simp add: replicate_Suc_iff_anywhere exp_suc del: replicate_Suc)
    apply(cases lm2, simp, simp)
   apply(auto)
   done
 
 lemma mv_boxes_correct: 
   "\<lbrakk>aa + n \<le> ba; ba > aa; length lm1 = aa; length lm2 = n; length lm3 = ba - aa - n\<rbrakk>
- \<Longrightarrow> {\<lambda> nl. nl = lm1 @ lm2 @ lm3 @ 0\<up>n @ lm4} (mv_boxes aa ba n) 
-     {\<lambda> nl. nl = lm1 @ 0\<up>n @ lm3 @ lm2 @ lm4}"
+ \<Longrightarrow> \<lbrace>\<lambda> nl. nl = lm1 @ lm2 @ lm3 @ 0\<up>n @ lm4\<rbrace> (mv_boxes aa ba n) 
+     \<lbrace>\<lambda> nl. nl = lm1 @ 0\<up>n @ lm3 @ lm2 @ lm4\<rbrace>"
 proof(induct n arbitrary: lm2 lm3 lm4)
   case 0
   thus "?case"
     by(simp add: mv_boxes.simps abc_Hoare_halt_def, rule_tac  x = 0 in exI, simp add: abc_steps_l.simps)
 next
   case (Suc n)
   have ind: 
     "\<And>lm2 lm3 lm4.
     \<lbrakk>aa + n \<le> ba; aa < ba; length lm1 = aa; length lm2 = n; length lm3 = ba - aa - n\<rbrakk>
-    \<Longrightarrow> {\<lambda>nl. nl = lm1 @ lm2 @ lm3 @ 0 \<up> n @ lm4} mv_boxes aa ba n {\<lambda>nl. nl = lm1 @ 0 \<up> n @ lm3 @ lm2 @ lm4}"
+    \<Longrightarrow> \<lbrace>\<lambda>nl. nl = lm1 @ lm2 @ lm3 @ 0 \<up> n @ lm4\<rbrace> mv_boxes aa ba n \<lbrace>\<lambda>nl. nl = lm1 @ 0 \<up> n @ lm3 @ lm2 @ lm4\<rbrace>"
     by fact
   have h1: "aa + Suc n \<le> ba"  by fact
   have h2: "aa < ba" by fact
   have h3: "length lm1 = aa" by fact
   have h4: "length lm2 = Suc n" by fact 
   have h5: "length lm3 = ba - aa - Suc n" by fact
-  have "{\<lambda>nl. nl = lm1 @ lm2 @ lm3 @ 0 \<up> Suc n @ lm4} mv_boxes aa ba n [+] mv_box (aa + n) (ba + n)
-    {\<lambda>nl. nl = lm1 @ 0 \<up> Suc n @ lm3 @ lm2 @ lm4}"
+  have "\<lbrace>\<lambda>nl. nl = lm1 @ lm2 @ lm3 @ 0 \<up> Suc n @ lm4\<rbrace> mv_boxes aa ba n [+] mv_box (aa + n) (ba + n)
+    \<lbrace>\<lambda>nl. nl = lm1 @ 0 \<up> Suc n @ lm3 @ lm2 @ lm4\<rbrace>"
   proof(rule_tac abc_Hoare_plus_halt)
-    have "{\<lambda>nl. nl = lm1 @ butlast lm2 @ (last lm2 # lm3) @ 0 \<up> n @ (0 # lm4)} mv_boxes aa ba n
-          {\<lambda> nl. nl = lm1 @ 0\<up>n @ (last lm2 # lm3) @ butlast lm2 @ (0 # lm4)}"
+    have "\<lbrace>\<lambda>nl. nl = lm1 @ butlast lm2 @ (last lm2 # lm3) @ 0 \<up> n @ (0 # lm4)\<rbrace> mv_boxes aa ba n
+          \<lbrace>\<lambda> nl. nl = lm1 @ 0\<up>n @ (last lm2 # lm3) @ butlast lm2 @ (0 # lm4)\<rbrace>"
       using h1 h2 h3 h4 h5
       by(rule_tac ind, simp_all)
     moreover have " lm1 @ butlast lm2 @ (last lm2 # lm3) @ 0 \<up> n @ (0 # lm4)
                   = lm1 @ lm2 @ lm3 @ 0 \<up> Suc n @ lm4"
       using h4
       by(simp add: replicate_Suc[THEN sym] exp_suc del: replicate_Suc, 
           cases lm2, simp_all)
-    ultimately show "{\<lambda>nl. nl = lm1 @ lm2 @ lm3 @ 0 \<up> Suc n @ lm4} mv_boxes aa ba n
-          {\<lambda> nl. nl = lm1 @ 0\<up>n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4}"
+    ultimately show "\<lbrace>\<lambda>nl. nl = lm1 @ lm2 @ lm3 @ 0 \<up> Suc n @ lm4\<rbrace> mv_boxes aa ba n
+          \<lbrace>\<lambda> nl. nl = lm1 @ 0\<up>n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4\<rbrace>"
       by (metis append_Cons)
   next
     let ?lm = "lm1 @ 0 \<up> n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4"
-    have "{\<lambda>nl. nl = ?lm} mv_box (aa + n) (ba + n)
-          {\<lambda> nl. nl = ?lm[(ba + n) := ?lm!(aa+n) + ?lm!(ba+n), (aa+n):=0]}"
+    have "\<lbrace>\<lambda>nl. nl = ?lm\<rbrace> mv_box (aa + n) (ba + n)
+          \<lbrace>\<lambda> nl. nl = ?lm[(ba + n) := ?lm!(aa+n) + ?lm!(ba+n), (aa+n):=0]\<rbrace>"
       using h1 h2 h3 h4  h5
       by(rule_tac mv_box_correct, simp_all)
     moreover have "?lm[(ba + n) := ?lm!(aa+n) + ?lm!(ba+n), (aa+n):=0]
                  =  lm1 @ 0 \<up> Suc n @ lm3 @ lm2 @ lm4"
       using h1 h2 h3 h4 h5
       by(auto simp: nth_append list_update_append split: if_splits)
-    ultimately show "{\<lambda>nl. nl = lm1 @ 0 \<up> n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4} mv_box (aa + n) (ba + n)
-          {\<lambda>nl. nl = lm1 @ 0 \<up> Suc n @ lm3 @ lm2 @ lm4}"
+    ultimately show "\<lbrace>\<lambda>nl. nl = lm1 @ 0 \<up> n @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4\<rbrace> mv_box (aa + n) (ba + n)
+          \<lbrace>\<lambda>nl. nl = lm1 @ 0 \<up> Suc n @ lm3 @ lm2 @ lm4\<rbrace>"
       by simp
   qed
   thus "?case"
     by(simp add: mv_boxes.simps)
 qed
 
 lemma update_butlast_eq2[simp]:
   "\<lbrakk>Suc n \<le> aa - length lm1; length lm1 < aa; 
   length lm2 = aa - Suc (length lm1 + n); 
   length lm3 = Suc n; 
   \<not> aa - Suc (length lm1) < aa - Suc (length lm1 + n);
   \<not> aa + n - length lm1 < n\<rbrakk>
   \<Longrightarrow> butlast lm3 @ ((0::nat) # lm2 @ 0 \<up> n @ last lm3 # lm4)[0 := last lm3, aa - length lm1 := 0] = lm3 @ lm2 @ 0 # 0 \<up> n @ lm4"
   apply(subgoal_tac "aa - length lm1 = length lm2 + Suc n")
    apply(simp add: list_update.simps list_update_append)
    apply(simp add: replicate_Suc[THEN sym] exp_suc del: replicate_Suc)
    apply(cases lm3, simp, simp)
   apply(auto)
   done
 
 lemma mv_boxes_correct2:
   "\<lbrakk>n \<le> aa - ba; 
     ba < aa; 
     length (lm1::nat list) = ba;
     length (lm2::nat list) = aa - ba - n; 
     length (lm3::nat list) = n\<rbrakk>
-  \<Longrightarrow>{\<lambda> nl. nl = lm1 @ 0\<up>n @ lm2 @ lm3 @ lm4}
+  \<Longrightarrow>\<lbrace>\<lambda> nl. nl = lm1 @ 0\<up>n @ lm2 @ lm3 @ lm4\<rbrace>
                 (mv_boxes aa ba n) 
-     {\<lambda> nl. nl = lm1 @ lm3 @ lm2 @ 0\<up>n @ lm4}"
+     \<lbrace>\<lambda> nl. nl = lm1 @ lm3 @ lm2 @ 0\<up>n @ lm4\<rbrace>"
 proof(induct n arbitrary: lm2 lm3 lm4)
   case 0
   thus "?case"
     by(simp add: mv_boxes.simps abc_Hoare_halt_def, rule_tac  x = 0 in exI, simp add: abc_steps_l.simps)
 next
   case (Suc n)
   have ind:
     "\<And>lm2 lm3 lm4.
     \<lbrakk>n \<le> aa - ba; ba < aa; length lm1 = ba; length lm2 = aa - ba - n; length lm3 = n\<rbrakk>
-    \<Longrightarrow> {\<lambda>nl. nl = lm1 @ 0 \<up> n @ lm2 @ lm3 @ lm4} mv_boxes aa ba n {\<lambda>nl. nl = lm1 @ lm3 @ lm2 @ 0 \<up> n @ lm4}"
+    \<Longrightarrow> \<lbrace>\<lambda>nl. nl = lm1 @ 0 \<up> n @ lm2 @ lm3 @ lm4\<rbrace> mv_boxes aa ba n \<lbrace>\<lambda>nl. nl = lm1 @ lm3 @ lm2 @ 0 \<up> n @ lm4\<rbrace>"
     by fact
   have h1: "Suc n \<le> aa - ba" by fact
   have h2: "ba < aa" by fact
   have h3: "length lm1 = ba" by fact 
   have h4: "length lm2 = aa - ba - Suc n" by fact
   have h5: "length lm3 = Suc n" by fact
-  have "{\<lambda>nl. nl = lm1 @ 0 \<up> Suc n @ lm2 @ lm3 @ lm4}  mv_boxes aa ba n [+] mv_box (aa + n) (ba + n) 
-    {\<lambda>nl. nl = lm1 @ lm3 @ lm2 @ 0 \<up> Suc n @ lm4}"
+  have "\<lbrace>\<lambda>nl. nl = lm1 @ 0 \<up> Suc n @ lm2 @ lm3 @ lm4\<rbrace>  mv_boxes aa ba n [+] mv_box (aa + n) (ba + n) 
+    \<lbrace>\<lambda>nl. nl = lm1 @ lm3 @ lm2 @ 0 \<up> Suc n @ lm4\<rbrace>"
   proof(rule_tac abc_Hoare_plus_halt)
-    have "{\<lambda> nl. nl = lm1 @ 0 \<up> n @ (0 # lm2) @ (butlast lm3) @ (last lm3 # lm4)} mv_boxes aa ba n
-           {\<lambda> nl. nl = lm1 @ butlast lm3 @ (0 # lm2) @ 0\<up>n @ (last lm3 # lm4)}"
+    have "\<lbrace>\<lambda> nl. nl = lm1 @ 0 \<up> n @ (0 # lm2) @ (butlast lm3) @ (last lm3 # lm4)\<rbrace> mv_boxes aa ba n
+           \<lbrace>\<lambda> nl. nl = lm1 @ butlast lm3 @ (0 # lm2) @ 0\<up>n @ (last lm3 # lm4)\<rbrace>"
       using h1 h2 h3 h4 h5
       by(rule_tac ind, simp_all)
     moreover have "lm1 @ 0 \<up> n @ (0 # lm2) @ (butlast lm3) @ (last lm3 # lm4) 
                    = lm1 @ 0 \<up> Suc n @ lm2 @ lm3 @ lm4"
       using h5
       by(simp add: replicate_Suc_iff_anywhere exp_suc 
           del: replicate_Suc, cases lm3, simp_all)
-    ultimately show "{\<lambda>nl. nl = lm1 @ 0 \<up> Suc n @ lm2 @ lm3 @ lm4} mv_boxes aa ba n
-     {\<lambda> nl. nl = lm1 @ butlast lm3 @ (0 # lm2) @ 0\<up>n @ (last lm3 # lm4)}"
+    ultimately show "\<lbrace>\<lambda>nl. nl = lm1 @ 0 \<up> Suc n @ lm2 @ lm3 @ lm4\<rbrace> mv_boxes aa ba n
+     \<lbrace>\<lambda> nl. nl = lm1 @ butlast lm3 @ (0 # lm2) @ 0\<up>n @ (last lm3 # lm4)\<rbrace>"
       by metis
   next
     thm mv_box_correct
     let ?lm = "lm1 @ butlast lm3 @ (0 # lm2) @ 0 \<up> n @ last lm3 # lm4"
-    have "{\<lambda>nl. nl = ?lm} mv_box (aa + n) (ba + n)
-         {\<lambda>nl. nl = ?lm[ba+n := ?lm!(aa+n)+?lm!(ba+n), (aa+n):=0]}"
+    have "\<lbrace>\<lambda>nl. nl = ?lm\<rbrace> mv_box (aa + n) (ba + n)
+         \<lbrace>\<lambda>nl. nl = ?lm[ba+n := ?lm!(aa+n)+?lm!(ba+n), (aa+n):=0]\<rbrace>"
       using h1 h2 h3 h4 h5
       by(rule_tac mv_box_correct, simp_all)
     moreover have "?lm[ba+n := ?lm!(aa+n)+?lm!(ba+n), (aa+n):=0]
                = lm1 @ lm3 @ lm2 @ 0 \<up> Suc n @ lm4"
       using h1 h2 h3 h4 h5
       by(auto simp: nth_append list_update_append split: if_splits)
-    ultimately show "{\<lambda>nl. nl = lm1 @ butlast lm3 @ (0 # lm2) @ 0 \<up> n @ last lm3 # lm4} mv_box (aa + n) (ba + n)
-     {\<lambda>nl. nl = lm1 @ lm3 @ lm2 @ 0 \<up> Suc n @ lm4}"
+    ultimately show "\<lbrace>\<lambda>nl. nl = lm1 @ butlast lm3 @ (0 # lm2) @ 0 \<up> n @ last lm3 # lm4\<rbrace> mv_box (aa + n) (ba + n)
+     \<lbrace>\<lambda>nl. nl = lm1 @ lm3 @ lm2 @ 0 \<up> Suc n @ lm4\<rbrace>"
       by simp
   qed
   thus "?case"
     by(simp add: mv_boxes.simps)
 qed    
 
 lemma save_paras: 
-  "{\<lambda>nl. nl = xs @ 0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) - length xs) @
-  map (\<lambda>i. rec_exec i xs) gs @ 0 \<up> Suc (length xs) @ anything}
+  "\<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) - length xs) @
+  map (\<lambda>i. rec_exec i xs) gs @ 0 \<up> Suc (length xs) @ anything\<rbrace>
   mv_boxes 0 (Suc (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) + length gs)) (length xs)
-  {\<lambda>nl. nl = 0 \<up> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ map (\<lambda>i. rec_exec i xs) gs @ 0 # xs @ anything}"
+  \<lbrace>\<lambda>nl. nl = 0 \<up> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ map (\<lambda>i. rec_exec i xs) gs @ 0 # xs @ anything\<rbrace>"
 proof -
   let ?ft = "max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))"
-  have "{\<lambda>nl. nl = [] @ xs @ (0\<up>(?ft - length xs) @  map (\<lambda>i. rec_exec i xs) gs @ [0]) @ 
-          0 \<up> (length xs) @ anything} mv_boxes 0 (Suc ?ft + length gs) (length xs) 
-        {\<lambda>nl. nl = [] @ 0 \<up> (length xs) @ (0\<up>(?ft - length xs) @  map (\<lambda>i. rec_exec i xs) gs @ [0]) @ xs @ anything}"
+  have "\<lbrace>\<lambda>nl. nl = [] @ xs @ (0\<up>(?ft - length xs) @  map (\<lambda>i. rec_exec i xs) gs @ [0]) @ 
+          0 \<up> (length xs) @ anything\<rbrace> mv_boxes 0 (Suc ?ft + length gs) (length xs) 
+        \<lbrace>\<lambda>nl. nl = [] @ 0 \<up> (length xs) @ (0\<up>(?ft - length xs) @  map (\<lambda>i. rec_exec i xs) gs @ [0]) @ xs @ anything\<rbrace>"
     by(rule_tac mv_boxes_correct, auto)
   thus "?thesis"
     by(simp add: replicate_merge_anywhere)
 qed
 
 lemma length_le_max_insert_rec_ci[intro]: 
   "length gs \<le> ffp \<Longrightarrow> length gs \<le> max x1 (Max (insert ffp (x2 ` x3 ` set gs)))"
   apply(rule_tac max.coboundedI2)
   apply(simp add: Max_ge_iff)
   done
 
 lemma restore_new_paras:
   "ffp \<ge> length gs 
- \<Longrightarrow> {\<lambda>nl. nl = 0 \<up> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ map (\<lambda>i. rec_exec i xs) gs @ 0 # xs @ anything}
+ \<Longrightarrow> \<lbrace>\<lambda>nl. nl = 0 \<up> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ map (\<lambda>i. rec_exec i xs) gs @ 0 # xs @ anything\<rbrace>
     mv_boxes (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))) 0 (length gs)
-  {\<lambda>nl. nl = map (\<lambda>i. rec_exec i xs) gs @ 0 \<up> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ 0 # xs @ anything}"
+  \<lbrace>\<lambda>nl. nl = map (\<lambda>i. rec_exec i xs) gs @ 0 \<up> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ 0 # xs @ anything\<rbrace>"
 proof -
   let ?ft = "max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))"
   assume j: "ffp \<ge> length gs"
-  hence "{\<lambda> nl. nl = [] @ 0\<up>length gs @ 0\<up>(?ft - length gs) @  map (\<lambda>i. rec_exec i xs) gs @ ((0 # xs) @ anything)}
+  hence "\<lbrace>\<lambda> nl. nl = [] @ 0\<up>length gs @ 0\<up>(?ft - length gs) @  map (\<lambda>i. rec_exec i xs) gs @ ((0 # xs) @ anything)\<rbrace>
        mv_boxes ?ft 0 (length gs)
-        {\<lambda> nl. nl = [] @ map (\<lambda>i. rec_exec i xs) gs @ 0\<up>(?ft - length gs) @ 0\<up>length gs @ ((0 # xs) @ anything)}"
+        \<lbrace>\<lambda> nl. nl = [] @ map (\<lambda>i. rec_exec i xs) gs @ 0\<up>(?ft - length gs) @ 0\<up>length gs @ ((0 # xs) @ anything)\<rbrace>"
     by(rule_tac mv_boxes_correct2, auto)
   moreover have "?ft \<ge> length gs"
     using j
     by(auto)
   ultimately show "?thesis"
     using j
     by(simp add: replicate_merge_anywhere le_add_diff_inverse)
 qed
 
 lemma le_max_insert[intro]: "ffp \<le> max x0 (Max (insert ffp (x1 ` x2 ` set gs)))"
   by (rule max.coboundedI2) auto
 
 declare max_less_iff_conj[simp del]
 
 lemma save_rs:
   "\<lbrakk>far = length gs;
   ffp \<le> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)));
   far < ffp\<rbrakk>
-\<Longrightarrow>  {\<lambda>nl. nl = map (\<lambda>i. rec_exec i xs) gs @
+\<Longrightarrow>  \<lbrace>\<lambda>nl. nl = map (\<lambda>i. rec_exec i xs) gs @
   rec_exec (Cn (length xs) f gs) xs # 0 \<up> max (Suc (length xs))
-  (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ xs @ anything}
+  (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ xs @ anything\<rbrace>
     mv_box far (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))))
-    {\<lambda>nl. nl = map (\<lambda>i. rec_exec i xs) gs @
+    \<lbrace>\<lambda>nl. nl = map (\<lambda>i. rec_exec i xs) gs @
                0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) - length gs) @
-               rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything}"
+               rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything\<rbrace>"
 proof -
   let ?ft = "max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))"
   thm mv_box_correct
   let ?lm= " map (\<lambda>i. rec_exec i xs) gs @ rec_exec (Cn (length xs) f gs) xs # 0 \<up> ?ft @ xs @ anything"
   assume h: "far = length gs" "ffp \<le> ?ft" "far < ffp"
-  hence "{\<lambda> nl. nl = ?lm} mv_box far ?ft {\<lambda> nl. nl = ?lm[?ft := ?lm!far + ?lm!?ft, far := 0]}"
+  hence "\<lbrace>\<lambda> nl. nl = ?lm\<rbrace> mv_box far ?ft \<lbrace>\<lambda> nl. nl = ?lm[?ft := ?lm!far + ?lm!?ft, far := 0]\<rbrace>"
     apply(rule_tac mv_box_correct)
     by( auto)  
   moreover have "?lm[?ft := ?lm!far + ?lm!?ft, far := 0]
     = map (\<lambda>i. rec_exec i xs) gs @
     0 \<up> (?ft - length gs) @
     rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything"
     using h
     apply(simp add: nth_append)
     using list_update_length[of "map (\<lambda>i. rec_exec i xs) gs @ rec_exec (Cn (length xs) f gs) xs #
        0 \<up> (?ft - Suc (length gs))" 0 "0 \<up> length gs @ xs @ anything" "rec_exec (Cn (length xs) f gs) xs"]
     apply(simp add: replicate_merge_anywhere replicate_Suc_iff_anywhere del: replicate_Suc)
     by(simp add: list_update_append list_update.simps replicate_Suc_iff_anywhere del: replicate_Suc)
   ultimately show "?thesis"
     by(simp)
 qed
 
 lemma length_empty_boxes[simp]: "length (empty_boxes n) = 2*n"
   apply(induct n, simp, simp)
   done
 
 lemma empty_one_box_correct:
-  "{\<lambda>nl. nl = 0 \<up> n @ x # lm} [Dec n 2, Goto 0] {\<lambda>nl. nl = 0 # 0 \<up> n @ lm}"
+  "\<lbrace>\<lambda>nl. nl = 0 \<up> n @ x # lm\<rbrace> [Dec n 2, Goto 0] \<lbrace>\<lambda>nl. nl = 0 # 0 \<up> n @ lm\<rbrace>"
 proof(induct x)
   case 0
   thus "?case"
     by(simp add: abc_Hoare_halt_def, 
         rule_tac x = 1 in exI, simp add: abc_steps_l.simps 
         abc_step_l.simps abc_fetch.simps abc_lm_v.simps nth_append abc_lm_s.simps
         replicate_Suc[THEN sym] exp_suc del: replicate_Suc)
 next
   case (Suc x)
-  have "{\<lambda>nl. nl = 0 \<up> n @ x # lm} [Dec n 2, Goto 0] {\<lambda>nl. nl = 0 # 0 \<up> n @ lm}"
+  have "\<lbrace>\<lambda>nl. nl = 0 \<up> n @ x # lm\<rbrace> [Dec n 2, Goto 0] \<lbrace>\<lambda>nl. nl = 0 # 0 \<up> n @ lm\<rbrace>"
     by fact
   then obtain stp where "abc_steps_l (0, 0 \<up> n @ x # lm) [Dec n 2, Goto 0] stp
                       = (Suc (Suc 0), 0 # 0 \<up> n @ lm)"
     apply(auto simp: abc_Hoare_halt_def)
     by (smt abc_final.simps abc_holds_for.elims(2) length_Cons list.size(3))
   moreover have "abc_steps_l (0, 0\<up>n @ Suc x # lm) [Dec n 2, Goto 0] (Suc (Suc 0)) 
         = (0,  0 \<up> n @ x # lm)"
     by(auto simp: abc_steps_l.simps abc_step_l.simps abc_fetch.simps abc_lm_v.simps
         nth_append abc_lm_s.simps list_update.simps list_update_append)
   ultimately have "abc_steps_l (0, 0\<up>n @ Suc x # lm) [Dec n 2, Goto 0] (Suc (Suc 0) + stp) 
                 = (Suc (Suc 0), 0 # 0\<up>n @ lm)"
     by(simp only: abc_steps_add)
   thus "?case"
     apply(simp add: abc_Hoare_halt_def)
     apply(rule_tac x = "Suc (Suc stp)" in exI, simp)
     done
 qed
 
 lemma empty_boxes_correct: 
   "length lm \<ge> n \<Longrightarrow>
-  {\<lambda> nl. nl = lm} empty_boxes n {\<lambda> nl. nl = 0\<up>n @ drop n lm}"
+  \<lbrace>\<lambda> nl. nl = lm\<rbrace> empty_boxes n \<lbrace>\<lambda> nl. nl = 0\<up>n @ drop n lm\<rbrace>"
 proof(induct n)
   case 0
   thus "?case"
     by(simp add: empty_boxes.simps abc_Hoare_halt_def, 
         rule_tac x = 0 in exI, simp add: abc_steps_l.simps)
 next
   case (Suc n)
-  have ind: "n \<le> length lm \<Longrightarrow> {\<lambda>nl. nl = lm} empty_boxes n {\<lambda>nl. nl = 0 \<up> n @ drop n lm}" by fact
+  have ind: "n \<le> length lm \<Longrightarrow> \<lbrace>\<lambda>nl. nl = lm\<rbrace> empty_boxes n \<lbrace>\<lambda>nl. nl = 0 \<up> n @ drop n lm\<rbrace>" by fact
   have h: "Suc n \<le> length lm" by fact
-  have "{\<lambda>nl. nl = lm} empty_boxes n [+] [Dec n 2, Goto 0] {\<lambda>nl. nl = 0 # 0 \<up> n @ drop (Suc n) lm}"
+  have "\<lbrace>\<lambda>nl. nl = lm\<rbrace> empty_boxes n [+] [Dec n 2, Goto 0] \<lbrace>\<lambda>nl. nl = 0 # 0 \<up> n @ drop (Suc n) lm\<rbrace>"
   proof(rule_tac abc_Hoare_plus_halt)
-    show "{\<lambda>nl. nl = lm} empty_boxes n {\<lambda>nl. nl = 0 \<up> n @ drop n lm}"
+    show "\<lbrace>\<lambda>nl. nl = lm\<rbrace> empty_boxes n \<lbrace>\<lambda>nl. nl = 0 \<up> n @ drop n lm\<rbrace>"
       using h
       by(rule_tac ind, simp)
   next
-    show "{\<lambda>nl. nl = 0 \<up> n @ drop n lm} [Dec n 2, Goto 0] {\<lambda>nl. nl = 0 # 0 \<up> n @ drop (Suc n) lm}"
+    show "\<lbrace>\<lambda>nl. nl = 0 \<up> n @ drop n lm\<rbrace> [Dec n 2, Goto 0] \<lbrace>\<lambda>nl. nl = 0 # 0 \<up> n @ drop (Suc n) lm\<rbrace>"
       using empty_one_box_correct[of n "lm ! n" "drop (Suc n) lm"]
       using h
       by(simp add: Cons_nth_drop_Suc)
   qed
   thus "?case"
     by(simp add: empty_boxes.simps)
 qed
 
 lemma insert_dominated[simp]: "length gs \<le> ffp \<Longrightarrow>
     length gs + (max xs (Max (insert ffp (x1 ` x2 ` set gs))) - length gs) =
     max xs (Max (insert ffp (x1 ` x2 ` set gs)))"
   apply(rule_tac le_add_diff_inverse)
   apply(rule_tac max.coboundedI2)
   apply(simp add: Max_ge_iff)
   done
 
 
 lemma clean_paras: 
   "ffp \<ge> length gs \<Longrightarrow>
-  {\<lambda>nl. nl = map (\<lambda>i. rec_exec i xs) gs @
+  \<lbrace>\<lambda>nl. nl = map (\<lambda>i. rec_exec i xs) gs @
   0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) - length gs) @
-  rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything}
+  rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything\<rbrace>
   empty_boxes (length gs)
-  {\<lambda>nl. nl = 0 \<up> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ 
-  rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything}"
+  \<lbrace>\<lambda>nl. nl = 0 \<up> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ 
+  rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything\<rbrace>"
 proof-
   let ?ft = "max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))"
   assume h: "length gs \<le> ffp"
   let ?lm = "map (\<lambda>i. rec_exec i xs) gs @ 0 \<up> (?ft - length gs) @
     rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything"
-  have "{\<lambda> nl. nl = ?lm} empty_boxes (length gs) {\<lambda> nl. nl = 0\<up>length gs @ drop (length gs) ?lm}"
+  have "\<lbrace>\<lambda> nl. nl = ?lm\<rbrace> empty_boxes (length gs) \<lbrace>\<lambda> nl. nl = 0\<up>length gs @ drop (length gs) ?lm\<rbrace>"
     by(rule_tac empty_boxes_correct, simp)
   moreover have "0\<up>length gs @ drop (length gs) ?lm 
            =  0 \<up> ?ft @  rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything"
     using h
     by(simp add: replicate_merge_anywhere)
   ultimately show "?thesis"
     by metis
 qed
 
 
 lemma restore_rs:
-  "{\<lambda>nl. nl = 0 \<up> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ 
-  rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything}
+  "\<lbrace>\<lambda>nl. nl = 0 \<up> max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) @ 
+  rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything\<rbrace>
   mv_box (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))) (length xs)
-  {\<lambda>nl. nl = 0 \<up> length xs @
+  \<lbrace>\<lambda>nl. nl = 0 \<up> length xs @
   rec_exec (Cn (length xs) f gs) xs #
   0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) - (length xs)) @
-  0 \<up> length gs @ xs @ anything}"
+  0 \<up> length gs @ xs @ anything\<rbrace>"
 proof -
   let ?ft = "max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))"
   let ?lm = "0\<up>(length xs) @  0\<up>(?ft - (length xs)) @ rec_exec (Cn (length xs) f gs) xs # 0 \<up> length gs @ xs @ anything"
   thm mv_box_correct
-  have "{\<lambda> nl. nl = ?lm} mv_box ?ft (length xs) {\<lambda> nl. nl = ?lm[length xs := ?lm!?ft + ?lm!(length xs), ?ft := 0]}"
+  have "\<lbrace>\<lambda> nl. nl = ?lm\<rbrace> mv_box ?ft (length xs) \<lbrace>\<lambda> nl. nl = ?lm[length xs := ?lm!?ft + ?lm!(length xs), ?ft := 0]\<rbrace>"
     by(rule_tac mv_box_correct, simp, simp)
   moreover have "?lm[length xs := ?lm!?ft + ?lm!(length xs), ?ft := 0]
                =  0 \<up> length xs @ rec_exec (Cn (length xs) f gs) xs # 0 \<up> (?ft - (length xs)) @ 0 \<up> length gs @ xs @ anything"
     apply(auto simp: list_update_append nth_append) (* ~ 7 sec *)
     apply(cases ?ft, simp_all add: Suc_diff_le list_update.simps)
     apply(simp add: exp_suc replicate_Suc[THEN sym] del: replicate_Suc)
     done
   ultimately show "?thesis"
     by(simp add: replicate_merge_anywhere)
 qed
 
 lemma restore_orgin_paras:
-  "{\<lambda>nl. nl = 0 \<up> length xs @
+  "\<lbrace>\<lambda>nl. nl = 0 \<up> length xs @
   rec_exec (Cn (length xs) f gs) xs #
-  0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) - length xs) @ 0 \<up> length gs @ xs @ anything}
+  0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) - length xs) @ 0 \<up> length gs @ xs @ anything\<rbrace>
   mv_boxes (Suc (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) + length gs)) 0 (length xs)
-  {\<lambda>nl. nl = xs @ rec_exec (Cn (length xs) f gs) xs # 0 \<up> 
-  (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) + length gs) @ anything}"
+  \<lbrace>\<lambda>nl. nl = xs @ rec_exec (Cn (length xs) f gs) xs # 0 \<up> 
+  (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) + length gs) @ anything\<rbrace>"
 proof -
   let ?ft = "max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))"
   thm mv_boxes_correct2
-  have "{\<lambda> nl. nl = [] @ 0\<up>(length xs) @ (rec_exec (Cn (length xs) f gs) xs # 0 \<up> (?ft - length xs) @ 0 \<up> length gs) @ xs @ anything}
+  have "\<lbrace>\<lambda> nl. nl = [] @ 0\<up>(length xs) @ (rec_exec (Cn (length xs) f gs) xs # 0 \<up> (?ft - length xs) @ 0 \<up> length gs) @ xs @ anything\<rbrace>
         mv_boxes (Suc ?ft + length gs) 0 (length xs)
-        {\<lambda> nl. nl = [] @ xs @ (rec_exec (Cn (length xs) f gs) xs # 0 \<up> (?ft - length xs) @ 0 \<up> length gs) @ 0\<up>length xs @ anything}"
+        \<lbrace>\<lambda> nl. nl = [] @ xs @ (rec_exec (Cn (length xs) f gs) xs # 0 \<up> (?ft - length xs) @ 0 \<up> length gs) @ 0\<up>length xs @ anything\<rbrace>"
     by(rule_tac mv_boxes_correct2, auto)
   thus "?thesis"
     by(simp add: replicate_merge_anywhere)
 qed
 
 lemma compile_cn_correct':
   assumes f_ind: 
     "\<And> anything r. rec_exec f (map (\<lambda>g. rec_exec g xs) gs) = rec_exec (Cn (length xs) f gs) xs \<Longrightarrow>
-  {\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ 0 \<up> (ffp - far) @ anything} fap
-                {\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ rec_exec (Cn (length xs) f gs) xs # 0 \<up> (ffp - Suc far) @ anything}"
+  \<lbrace>\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ 0 \<up> (ffp - far) @ anything\<rbrace> fap
+                \<lbrace>\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ rec_exec (Cn (length xs) f gs) xs # 0 \<up> (ffp - Suc far) @ anything\<rbrace>"
     and compile: "rec_ci f = (fap, far, ffp)"
     and term_f: "terminate f (map (\<lambda>g. rec_exec g xs) gs)"
     and g_cond: "\<forall>g\<in>set gs. terminate g xs \<and>
   (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow> 
-  (\<forall>xc. {\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc} x {\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc}))"
+  (\<forall>xc. \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc\<rbrace> x \<lbrace>\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc\<rbrace>))"
   shows 
-    "{\<lambda>nl. nl = xs @ 0 # 0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) + length gs) @ anything}
+    "\<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) + length gs) @ anything\<rbrace>
   cn_merge_gs (map rec_ci gs) (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))) [+]
   (mv_boxes 0 (Suc (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) + length gs)) (length xs) [+]
   (mv_boxes (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))) 0 (length gs) [+]
   (fap [+] (mv_box far (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))) [+]
   (empty_boxes (length gs) [+]
   (mv_box (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))) (length xs) [+]
   mv_boxes (Suc (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) + length gs)) 0 (length xs)))))))
-  {\<lambda>nl. nl = xs @ rec_exec (Cn (length xs) f gs) xs # 
-0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) + length gs) @ anything}"
+  \<lbrace>\<lambda>nl. nl = xs @ rec_exec (Cn (length xs) f gs) xs # 
+0 \<up> (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs))) + length gs) @ anything\<rbrace>"
 proof -
   let ?ft = "max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))"
   let ?A = "cn_merge_gs (map rec_ci gs) ?ft"
   let ?B = "mv_boxes 0 (Suc (?ft+length gs)) (length xs)"
   let ?C = "mv_boxes ?ft 0 (length gs)"
   let ?D = fap
   let ?E = "mv_box far ?ft"
   let ?F = "empty_boxes (length gs)"
   let ?G = "mv_box ?ft (length xs)"
   let ?H = "mv_boxes (Suc (?ft + length gs)) 0 (length xs)"
   let ?P1 = "\<lambda>nl. nl = xs @ 0 # 0 \<up> (?ft + length gs) @ anything"
   let ?S = "\<lambda>nl. nl = xs @ rec_exec (Cn (length xs) f gs) xs # 0 \<up> (?ft + length gs) @ anything"
   let ?Q1 = "\<lambda> nl. nl = xs @ 0\<up>(?ft - length xs) @ map (\<lambda> i. rec_exec i xs) gs @ 0\<up>(Suc (length xs)) @ anything"
-  show "{?P1} (?A [+] (?B [+] (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H))))))) {?S}"
+  show "\<lbrace>?P1\<rbrace> (?A [+] (?B [+] (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H))))))) \<lbrace>?S\<rbrace>"
   proof(rule_tac abc_Hoare_plus_halt)
-    show "{?P1} ?A {?Q1}"
+    show "\<lbrace>?P1\<rbrace> ?A \<lbrace>?Q1\<rbrace>"
       using g_cond
       by(rule_tac compile_cn_gs_correct, auto)
   next
     let ?Q2 = "\<lambda>nl. nl = 0 \<up> ?ft @
                     map (\<lambda>i. rec_exec i xs) gs @ 0 # xs @ anything"
-    show "{?Q1} (?B [+] (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H)))))) {?S}"
+    show "\<lbrace>?Q1\<rbrace> (?B [+] (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H)))))) \<lbrace>?S\<rbrace>"
     proof(rule_tac abc_Hoare_plus_halt)
-      show "{?Q1} ?B {?Q2}"
+      show "\<lbrace>?Q1\<rbrace> ?B \<lbrace>?Q2\<rbrace>"
         by(rule_tac save_paras)
     next
       let ?Q3 = "\<lambda> nl. nl = map (\<lambda>i. rec_exec i xs) gs @ 0\<up>?ft @ 0 # xs @ anything" 
-      show "{?Q2} (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H))))) {?S}"
+      show "\<lbrace>?Q2\<rbrace> (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H))))) \<lbrace>?S\<rbrace>"
       proof(rule_tac abc_Hoare_plus_halt)
         have "ffp \<ge> length gs"
           using compile term_f
           apply(subgoal_tac "length gs = far")
            apply(drule_tac footprint_ge, simp)
           by(drule_tac param_pattern, auto)          
-        thus "{?Q2} ?C {?Q3}"
+        thus "\<lbrace>?Q2\<rbrace> ?C \<lbrace>?Q3\<rbrace>"
           by(erule_tac restore_new_paras)
       next
         let ?Q4 = "\<lambda> nl. nl = map (\<lambda>i. rec_exec i xs) gs @ rec_exec (Cn (length xs) f gs) xs # 0\<up>?ft @ xs @ anything"
         have a: "far = length gs"
           using compile term_f
           by(drule_tac param_pattern, auto)
         have b:"?ft \<ge> ffp"
           by auto
         have c: "ffp > far"
           using compile
           by(erule_tac footprint_ge)
-        show "{?Q3} (?D [+] (?E [+] (?F [+] (?G [+] ?H)))) {?S}"
+        show "\<lbrace>?Q3\<rbrace> (?D [+] (?E [+] (?F [+] (?G [+] ?H)))) \<lbrace>?S\<rbrace>"
         proof(rule_tac abc_Hoare_plus_halt)
-          have "{\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ 0 \<up> (ffp - far) @ 0\<up>(?ft - ffp + far) @ 0 # xs @ anything} fap
-            {\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ rec_exec (Cn (length xs) f gs) xs # 
-            0 \<up> (ffp - Suc far) @ 0\<up>(?ft - ffp + far) @ 0 # xs @ anything}"
+          have "\<lbrace>\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ 0 \<up> (ffp - far) @ 0\<up>(?ft - ffp + far) @ 0 # xs @ anything\<rbrace> fap
+            \<lbrace>\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ rec_exec (Cn (length xs) f gs) xs # 
+            0 \<up> (ffp - Suc far) @ 0\<up>(?ft - ffp + far) @ 0 # xs @ anything\<rbrace>"
             by(rule_tac f_ind, simp add: rec_exec.simps)
-          thus "{?Q3} fap {?Q4}"
+          thus "\<lbrace>?Q3\<rbrace> fap \<lbrace>?Q4\<rbrace>"
             using a b c
             by(simp add: replicate_merge_anywhere,
                 cases "?ft", simp_all add: exp_suc del: replicate_Suc)
         next
           let ?Q5 = "\<lambda>nl. nl = map (\<lambda>i. rec_exec i xs) gs @
                0\<up>(?ft - length gs) @ rec_exec (Cn (length xs) f gs) xs # 0\<up>(length gs)@ xs @ anything"
-          show "{?Q4} (?E [+] (?F [+] (?G [+] ?H))) {?S}"
+          show "\<lbrace>?Q4\<rbrace> (?E [+] (?F [+] (?G [+] ?H))) \<lbrace>?S\<rbrace>"
           proof(rule_tac abc_Hoare_plus_halt)
-            from a b c show "{?Q4} ?E {?Q5}"
+            from a b c show "\<lbrace>?Q4\<rbrace> ?E \<lbrace>?Q5\<rbrace>"
               by(erule_tac save_rs, simp_all)
           next
             let ?Q6 = "\<lambda>nl. nl = 0\<up>?ft @ rec_exec (Cn (length xs) f gs) xs # 0\<up>(length gs)@ xs @ anything"
-            show "{?Q5} (?F [+] (?G [+] ?H)) {?S}"
+            show "\<lbrace>?Q5\<rbrace> (?F [+] (?G [+] ?H)) \<lbrace>?S\<rbrace>"
             proof(rule_tac abc_Hoare_plus_halt)
               have "length gs \<le> ffp" using a b c
                 by simp
-              thus "{?Q5} ?F {?Q6}"
+              thus "\<lbrace>?Q5\<rbrace> ?F \<lbrace>?Q6\<rbrace>"
                 by(erule_tac clean_paras)
             next
               let ?Q7 = "\<lambda>nl. nl = 0\<up>length xs @ rec_exec (Cn (length xs) f gs) xs # 0\<up>(?ft - (length xs)) @ 0\<up>(length gs)@ xs @ anything"
-              show "{?Q6} (?G [+] ?H) {?S}"
+              show "\<lbrace>?Q6\<rbrace> (?G [+] ?H) \<lbrace>?S\<rbrace>"
               proof(rule_tac abc_Hoare_plus_halt)
-                show "{?Q6} ?G {?Q7}"
+                show "\<lbrace>?Q6\<rbrace> ?G \<lbrace>?Q7\<rbrace>"
                   by(rule_tac restore_rs)
               next
-                show "{?Q7} ?H {?S}"
+                show "\<lbrace>?Q7\<rbrace> ?H \<lbrace>?S\<rbrace>"
                   by(rule_tac restore_orgin_paras)
               qed
             qed
           qed
         qed        
       qed
     qed
   qed
 qed
 
 lemma compile_cn_correct:
   assumes termi_f: "terminate f (map (\<lambda>g. rec_exec g xs) gs)"
     and f_ind: "\<And>ap arity fp anything.
   rec_ci f = (ap, arity, fp)
-  \<Longrightarrow> {\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ 0 \<up> (fp - arity) @ anything} ap
-  {\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ rec_exec f (map (\<lambda>g. rec_exec g xs) gs) # 0 \<up> (fp - Suc arity) @ anything}"
+  \<Longrightarrow> \<lbrace>\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ 0 \<up> (fp - arity) @ anything\<rbrace> ap
+  \<lbrace>\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ rec_exec f (map (\<lambda>g. rec_exec g xs) gs) # 0 \<up> (fp - Suc arity) @ anything\<rbrace>"
     and g_cond: 
     "\<forall>g\<in>set gs. terminate g xs \<and>
-  (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow>   (\<forall>xc. {\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc} x {\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc}))"
+  (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow>   (\<forall>xc. \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (xb - xa) @ xc\<rbrace> x \<lbrace>\<lambda>nl. nl = xs @ rec_exec g xs # 0 \<up> (xb - Suc xa) @ xc\<rbrace>))"
     and compile: "rec_ci (Cn n f gs) = (ap, arity, fp)"
     and len: "length xs = n"
-  shows "{\<lambda>nl. nl = xs @ 0 \<up> (fp - arity) @ anything} ap {\<lambda>nl. nl = xs @ rec_exec (Cn n f gs) xs # 0 \<up> (fp - Suc arity) @ anything}"
+  shows "\<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (fp - arity) @ anything\<rbrace> ap \<lbrace>\<lambda>nl. nl = xs @ rec_exec (Cn n f gs) xs # 0 \<up> (fp - Suc arity) @ anything\<rbrace>"
 proof(cases "rec_ci f")
   fix fap far ffp
   assume h: "rec_ci f = (fap, far, ffp)"
-  then have f_newind: "\<And> anything .{\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ 0 \<up> (ffp - far) @ anything} fap
-    {\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ rec_exec f (map (\<lambda>g. rec_exec g xs) gs) # 0 \<up> (ffp - Suc far) @ anything}"
+  then have f_newind: "\<And> anything .\<lbrace>\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ 0 \<up> (ffp - far) @ anything\<rbrace> fap
+    \<lbrace>\<lambda>nl. nl = map (\<lambda>g. rec_exec g xs) gs @ rec_exec f (map (\<lambda>g. rec_exec g xs) gs) # 0 \<up> (ffp - Suc far) @ anything\<rbrace>"
     by(rule_tac f_ind, simp_all)
-  thus "{\<lambda>nl. nl = xs @ 0 \<up> (fp - arity) @ anything} ap {\<lambda>nl. nl = xs @ rec_exec (Cn n f gs) xs # 0 \<up> (fp - Suc arity) @ anything}"
+  thus "\<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (fp - arity) @ anything\<rbrace> ap \<lbrace>\<lambda>nl. nl = xs @ rec_exec (Cn n f gs) xs # 0 \<up> (fp - Suc arity) @ anything\<rbrace>"
     using compile len h termi_f g_cond
     apply(auto simp: rec_ci.simps abc_comp_commute)
     apply(rule_tac compile_cn_correct', simp_all)
     done
 qed
 
+subsubsection \<open>Correctness of compilation for constructor Pr\<close>
+
 lemma mv_box_correct_simp[simp]: 
   "\<lbrakk>length xs = n; ft = max (n+3) (max fft gft)\<rbrakk> 
- \<Longrightarrow> {\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft - n) @ anything} mv_box n ft 
-       {\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft - n) @ anything}"
+ \<Longrightarrow> \<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft - n) @ anything\<rbrace> mv_box n ft 
+       \<lbrace>\<lambda>nl. nl = xs @ 0 # 0 \<up> (ft - n) @ anything\<rbrace>"
   using mv_box_correct[of n ft "xs @ 0 # 0 \<up> (ft - n) @ anything"]
   by(auto)
 
 lemma length_under_max[simp]: "length xs < max (length xs + 3) fft"
   by auto
 
 lemma save_init_rs: 
   "\<lbrakk>length xs = n; ft = max (n+3) (max fft gft)\<rbrakk> 
-     \<Longrightarrow>  {\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (ft - n) @ anything} mv_box n (Suc n) 
-       {\<lambda>nl. nl = xs @ 0 # rec_exec f xs # 0 \<up> (ft - Suc n) @ anything}"
+     \<Longrightarrow>  \<lbrace>\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (ft - n) @ anything\<rbrace> mv_box n (Suc n) 
+       \<lbrace>\<lambda>nl. nl = xs @ 0 # rec_exec f xs # 0 \<up> (ft - Suc n) @ anything\<rbrace>"
   using mv_box_correct[of n "Suc n" "xs @ rec_exec f xs # 0 \<up> (ft - n) @ anything"]
   apply(auto simp: list_update_append list_update.simps nth_append split: if_splits)
   apply(cases "(max (length xs + 3) (max fft gft))", simp_all add: list_update.simps Suc_diff_le)
   done
 
 lemma less_then_max_plus2[simp]: "n + (2::nat) < max (n + 3) x"
   by auto
 
 lemma less_then_max_plus3[simp]: "n < max (n + (3::nat)) x"
   by auto
 
 lemma mv_box_max_plus_3_correct[simp]:
   "length xs = n \<Longrightarrow> 
-  {\<lambda>nl. nl = xs @ x # 0 \<up> (max (n + (3::nat)) (max fft gft) - n) @ anything} mv_box n (max (n + 3) (max fft gft))
-  {\<lambda>nl. nl = xs @ 0 \<up> (max (n + 3) (max fft gft) - n) @ x # anything}"
+  \<lbrace>\<lambda>nl. nl = xs @ x # 0 \<up> (max (n + (3::nat)) (max fft gft) - n) @ anything\<rbrace> mv_box n (max (n + 3) (max fft gft))
+  \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (max (n + 3) (max fft gft) - n) @ x # anything\<rbrace>"
 proof -
   assume h: "length xs = n"
   let ?ft = "max (n+3) (max fft gft)"
   let ?lm = "xs @ x # 0\<up>(?ft - Suc n) @ 0 # anything"
   have g: "?ft > n + 2"
     by simp
   thm mv_box_correct
-  have a: "{\<lambda> nl. nl = ?lm} mv_box n ?ft {\<lambda> nl. nl = ?lm[?ft := ?lm!n + ?lm!?ft, n := 0]}"
+  have a: "\<lbrace>\<lambda> nl. nl = ?lm\<rbrace> mv_box n ?ft \<lbrace>\<lambda> nl. nl = ?lm[?ft := ?lm!n + ?lm!?ft, n := 0]\<rbrace>"
     using h
     by(rule_tac mv_box_correct, auto)
   have b:"?lm = xs @ x # 0 \<up> (max (n + 3) (max fft gft) - n) @ anything"
     by(cases ?ft, simp_all add: Suc_diff_le exp_suc del: replicate_Suc)
   have c: "?lm[?ft := ?lm!n + ?lm!?ft, n := 0] = xs @ 0 \<up> (max (n + 3) (max fft gft) - n) @ x # anything"
     using h g
     apply(auto simp: nth_append list_update_append split: if_splits)
     using list_update_append[of "x # 0 \<up> (max (length xs + 3) (max fft gft) - Suc (length xs))" "0 # anything"
         "max (length xs + 3) (max fft gft) - length xs" "x"]
     apply(auto simp: if_splits)
     apply(simp add: list_update.simps replicate_Suc[THEN sym] del: replicate_Suc)
     done
   from a c show "?thesis"
     using h
     apply(simp)
     using b
     by simp
 qed
 
 lemma max_less_suc_suc[simp]: "max n (Suc n) < Suc (Suc (max (n + 3) x + anything - Suc 0))"
   by arith    
 
 lemma suc_less_plus_3[simp]: "Suc n < max (n + 3) x"
   by arith
 
 lemma mv_box_ok_suc_simp[simp]:
   "length xs = n
- \<Longrightarrow> {\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (max (n + 3) (max fft gft) - Suc n) @ x # anything} mv_box n (Suc n)
-    {\<lambda>nl. nl = xs @ 0 # rec_exec f xs # 0 \<up> (max (n + 3) (max fft gft) - Suc (Suc n)) @ x # anything}"
+ \<Longrightarrow> \<lbrace>\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (max (n + 3) (max fft gft) - Suc n) @ x # anything\<rbrace> mv_box n (Suc n)
+    \<lbrace>\<lambda>nl. nl = xs @ 0 # rec_exec f xs # 0 \<up> (max (n + 3) (max fft gft) - Suc (Suc n)) @ x # anything\<rbrace>"
   using mv_box_correct[of n "Suc n" "xs @ rec_exec f xs # 0 \<up> (max (n + 3) (max fft gft) - Suc n) @ x # anything"]
   apply(simp add: nth_append list_update_append list_update.simps)
   apply(cases "max (n + 3) (max fft gft)", simp_all)
   apply(cases "max (n + 3) (max fft gft) - 1", simp_all add: Suc_diff_le list_update.simps(2))
   done
 
-lemma abc_append_frist_steps_eq_pre: 
+lemma abc_append_first_steps_eq_pre: 
   assumes notfinal: "abc_notfinal (abc_steps_l (0, lm)  A n) A"
     and notnull: "A \<noteq> []"
   shows "abc_steps_l (0, lm) (A @ B) n = abc_steps_l (0, lm) A n"
   using notfinal
 proof(induct n)
   case 0
   thus "?case"
     by(simp add: abc_steps_l.simps)
 next
   case (Suc n)
   have ind: "abc_notfinal (abc_steps_l (0, lm) A n) A \<Longrightarrow> abc_steps_l (0, lm) (A @ B) n = abc_steps_l (0, lm) A n"
     by fact
   have h: "abc_notfinal (abc_steps_l (0, lm) A (Suc n)) A" by fact
   then have a: "abc_notfinal (abc_steps_l (0, lm) A n) A"
     by(simp add: notfinal_Suc)
   then have b: "abc_steps_l (0, lm) (A @ B) n = abc_steps_l (0, lm) A n"
     using ind by simp
   obtain s lm' where c: "abc_steps_l (0, lm) A n = (s, lm')"
     by (metis prod.exhaust)
   then have d: "s < length A \<and> abc_steps_l (0, lm) (A @ B) n = (s, lm')" 
     using a b by simp
   thus "?case"
     using c
     by(simp add: abc_step_red2 abc_fetch.simps abc_step_l.simps nth_append)
 qed
 
 lemma abc_append_first_step_eq_pre: 
   "st < length A
  \<Longrightarrow> abc_step_l (st, lm) (abc_fetch st (A @ B)) = 
     abc_step_l (st, lm) (abc_fetch st A)"
   by(simp add: abc_step_l.simps abc_fetch.simps nth_append)
 
-lemma abc_append_frist_steps_halt_eq': 
+lemma abc_append_first_steps_halt_eq': 
   assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
     and notnull: "A \<noteq> []"
   shows "\<exists> n'. abc_steps_l (0, lm) (A @ B) n' = (length A, lm')"
 proof -
   have "\<exists> n'. abc_notfinal (abc_steps_l (0, lm) A n') A \<and> 
     abc_final (abc_steps_l (0, lm) A (Suc n')) A"
     using assms
     by(rule_tac n = n in abc_before_final, simp_all)
   then obtain na where a:
     "abc_notfinal (abc_steps_l (0, lm) A na) A \<and> 
             abc_final (abc_steps_l (0, lm) A (Suc na)) A" ..
   obtain sa lma where b: "abc_steps_l (0, lm) A na = (sa, lma)"
     by (metis prod.exhaust)
   then have c: "abc_steps_l (0, lm) (A @ B) na = (sa, lma)"
-    using a abc_append_frist_steps_eq_pre[of lm A na B] assms 
+    using a abc_append_first_steps_eq_pre[of lm A na B] assms 
     by simp
   have d: "sa < length A" using b a by simp
   then have e: "abc_step_l (sa, lma) (abc_fetch sa (A @ B)) = 
     abc_step_l (sa, lma) (abc_fetch sa A)"
     by(rule_tac abc_append_first_step_eq_pre)
   from a have "abc_steps_l (0, lm) A (Suc na) = (length A, lm')"
     using final equal_when_halt
     by(cases "abc_steps_l (0, lm) A (Suc na)" , simp)
   then have "abc_steps_l (0, lm) (A @ B) (Suc na) = (length A, lm')"
     using a b c e
     by(simp add: abc_step_red2)
   thus "?thesis"
     by blast
 qed
 
-lemma abc_append_frist_steps_halt_eq: 
+lemma abc_append_first_steps_halt_eq: 
   assumes final: "abc_steps_l (0, lm) A n = (length A, lm')"
   shows "\<exists> n'. abc_steps_l (0, lm) (A @ B) n' = (length A, lm')"
   using final
   apply(cases "A = []")
    apply(rule_tac x = 0 in exI, simp add: abc_steps_l.simps abc_exec_null)
-  apply(rule_tac abc_append_frist_steps_halt_eq', simp_all)
+  apply(rule_tac abc_append_first_steps_halt_eq', simp_all)
   done
 
 lemma suc_suc_max_simp[simp]: "Suc (Suc (max (xs + 3) fft - Suc (Suc ( xs))))
            = max ( xs + 3) fft - ( xs)"
   by arith
 
 lemma contract_dec_ft_length_plus_7[simp]: "\<lbrakk>ft = max (n + 3) (max fft gft); length xs = n\<rbrakk> \<Longrightarrow>
-     {\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ Suc y # anything}
+     \<lbrace>\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ Suc y # anything\<rbrace>
      [Dec ft (length gap + 7)] 
-     {\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ y # anything}"
+     \<lbrace>\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ y # anything\<rbrace>"
   apply (simp add: abc_Hoare_halt_def)
   apply (rule_tac x = 1 in exI)
   apply (auto simp add: max_def)
   apply(auto simp: abc_steps_l.simps abc_step_l.simps abc_fetch.simps nth_append 
       abc_lm_v.simps abc_lm_s.simps list_update_append)
   using list_update_length
     [of "(x - Suc y) # rec_exec (Pr (length xs) f g) (xs @ [x - Suc y]) #
           0 \<up> (max (length xs + 3) (max fft gft) - Suc (Suc (length xs)))" "Suc y" anything y]
      apply (auto simp add: Suc_diff_Suc)
   using numeral_3_eq_3 apply presburger
   using numeral_3_eq_3 apply presburger
   done
 
 lemma adjust_paras': 
-  "length xs = n \<Longrightarrow> {\<lambda>nl. nl = xs @ x # y # anything}  [Inc n] [+] [Dec (Suc n) 2, Goto 0]
-       {\<lambda>nl. nl = xs @ Suc x # 0 # anything}"
+  "length xs = n \<Longrightarrow> \<lbrace>\<lambda>nl. nl = xs @ x # y # anything\<rbrace>  [Inc n] [+] [Dec (Suc n) 2, Goto 0]
+       \<lbrace>\<lambda>nl. nl = xs @ Suc x # 0 # anything\<rbrace>"
 proof(rule_tac abc_Hoare_plus_halt)
   assume "length xs = n"
-  thus "{\<lambda>nl. nl = xs @ x # y # anything} [Inc n] {\<lambda> nl. nl = xs @ Suc x # y # anything}"
+  thus "\<lbrace>\<lambda>nl. nl = xs @ x # y # anything\<rbrace> [Inc n] \<lbrace>\<lambda> nl. nl = xs @ Suc x # y # anything\<rbrace>"
     apply(simp add: abc_Hoare_halt_def)
     apply(rule_tac x = 1 in exI, force simp add: abc_steps_l.simps abc_step_l.simps
         abc_fetch.simps abc_comp.simps
         abc_lm_v.simps abc_lm_s.simps nth_append list_update_append list_update.simps(2))
     done
 next
   assume h: "length xs = n"
-  thus "{\<lambda>nl. nl = xs @ Suc x # y # anything} [Dec (Suc n) 2, Goto 0] {\<lambda>nl. nl = xs @ Suc x # 0 # anything}"
+  thus "\<lbrace>\<lambda>nl. nl = xs @ Suc x # y # anything\<rbrace> [Dec (Suc n) 2, Goto 0] \<lbrace>\<lambda>nl. nl = xs @ Suc x # 0 # anything\<rbrace>"
   proof(induct y)
     case 0
     thus "?case"
       apply(simp add: abc_Hoare_halt_def)
       apply(rule_tac x = 1 in exI, simp add: abc_steps_l.simps abc_step_l.simps abc_fetch.simps
           abc_comp.simps
           abc_lm_v.simps abc_lm_s.simps nth_append list_update_append list_update.simps(2))
       done
   next
     case (Suc y)
     have "length xs = n \<Longrightarrow> 
-      {\<lambda>nl. nl = xs @ Suc x # y # anything} [Dec (Suc n) 2, Goto 0] {\<lambda>nl. nl = xs @ Suc x # 0 # anything}" by fact
+      \<lbrace>\<lambda>nl. nl = xs @ Suc x # y # anything\<rbrace> [Dec (Suc n) 2, Goto 0] \<lbrace>\<lambda>nl. nl = xs @ Suc x # 0 # anything\<rbrace>" by fact
     then obtain stp where 
       "abc_steps_l (0, xs @ Suc x # y # anything) [Dec (Suc n) 2, Goto 0] stp = (2, xs @ Suc x # 0 # anything)"
       using h
       apply(auto simp: abc_Hoare_halt_def numeral_2_eq_2)
       by (metis (mono_tags, lifting) abc_final.simps abc_holds_for.elims(2) length_Cons list.size(3))
     moreover have "abc_steps_l (0, xs @ Suc x # Suc y # anything) [Dec (Suc n) 2, Goto 0] 2 = 
                  (0, xs @ Suc x # y # anything)"
       using h
       by(simp add: abc_steps_l.simps numeral_2_eq_2 abc_step_l.simps abc_fetch.simps
           abc_lm_v.simps abc_lm_s.simps nth_append list_update_append list_update.simps(2))
     ultimately show "?case"
       apply(simp add: abc_Hoare_halt_def)
       by(rule exI[of _ "2 + stp"], simp only: abc_steps_add, simp)
   qed
 qed
 
 lemma adjust_paras: 
-  "length xs = n \<Longrightarrow> {\<lambda>nl. nl = xs @ x # y # anything}  [Inc n, Dec (Suc n) 3, Goto (Suc 0)]
-       {\<lambda>nl. nl = xs @ Suc x # 0 # anything}"
+  "length xs = n \<Longrightarrow> \<lbrace>\<lambda>nl. nl = xs @ x # y # anything\<rbrace>  [Inc n, Dec (Suc n) 3, Goto (Suc 0)]
+       \<lbrace>\<lambda>nl. nl = xs @ Suc x # 0 # anything\<rbrace>"
   using adjust_paras'[of xs n x y anything]
   by(simp add: abc_comp.simps abc_shift.simps numeral_2_eq_2 numeral_3_eq_3)
 
 lemma rec_ci_SucSuc_n[simp]: "\<lbrakk>rec_ci g = (gap, gar, gft); \<forall>y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]);
         length xs = n; Suc y\<le>x\<rbrakk> \<Longrightarrow> gar = Suc (Suc n)"
   by(auto dest:param_pattern elim!:allE[of _ y])
 
 lemma loop_back':  
   assumes h: "length A = length gap + 4" "length xs = n"
     and le: "y \<ge> x"
   shows "\<exists> stp. abc_steps_l (length A, xs @ m # (y - x) # x # anything) (A @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]) stp
      = (length A, xs @ m # y # 0 # anything)"
   using le
 proof(induct x)
   case 0
   thus "?case"
     using h
     by(rule_tac x = 0 in exI,
         auto simp: abc_steps_l.simps abc_step_l.simps abc_fetch.simps nth_append abc_lm_s.simps abc_lm_v.simps)
 next
   case (Suc x)
   have "x \<le> y \<Longrightarrow> \<exists>stp. abc_steps_l (length A, xs @ m # (y - x) # x # anything) (A @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]) stp =
               (length A, xs @ m # y # 0 # anything)" by fact
   moreover have "Suc x \<le> y" by fact
   moreover then have "\<exists> stp. abc_steps_l (length A, xs @ m # (y - Suc x) # Suc x # anything) (A @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]) stp
                 = (length A, xs @ m # (y - x) # x # anything)"
     using h
     apply(rule_tac x = 3 in exI)
     by(simp add: abc_steps_l.simps numeral_3_eq_3 abc_step_l.simps abc_fetch.simps nth_append
         abc_lm_v.simps abc_lm_s.simps list_update_append list_update.simps(2))
   ultimately show "?case"
     apply(auto simp add: abc_steps_add)
     by (metis abc_steps_add)
 qed
 
 
 lemma loop_back:  
   assumes h: "length A = length gap + 4" "length xs = n"
   shows "\<exists> stp. abc_steps_l (length A, xs @ m # 0 # x # anything) (A @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]) stp
      = (0, xs @ m # x # 0 # anything)"
   using loop_back'[of A gap xs n x x m anything] assms
   apply(auto) apply(rename_tac stp)
   apply(rule_tac x = "stp + 1" in exI)
   apply(simp only: abc_steps_add, simp)
   apply(simp add: abc_steps_l.simps abc_step_l.simps abc_fetch.simps nth_append abc_lm_v.simps
       abc_lm_s.simps)
   done
 
 lemma rec_exec_pr_0_simps: "rec_exec (Pr n f g) (xs @ [0]) = rec_exec f xs"
   by(simp add: rec_exec.simps)
 
 lemma rec_exec_pr_Suc_simps: "rec_exec (Pr n f g) (xs @ [Suc y])
           = rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])])"
   apply(induct y)
    apply(simp add: rec_exec.simps)
   apply(simp add: rec_exec.simps)
   done
 
 lemma suc_max_simp[simp]: "Suc (max (n + 3) fft - Suc (Suc (Suc n))) = max (n + 3) fft - Suc (Suc n)"
   by arith
 
 lemma pr_loop:
   assumes code: "code = ([Dec (max (n + 3) (max fft gft)) (length gap + 7)] [+] (gap [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)])) @
     [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]"
     and len: "length xs = n"
-    and g_ind: "\<forall> y<x. (\<forall>anything. {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (gft - gar) @ anything} gap
-  {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (gft - Suc gar) @ anything})"
+    and g_ind: "\<forall> y<x. (\<forall>anything. \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (gft - gar) @ anything\<rbrace> gap
+  \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (gft - Suc gar) @ anything\<rbrace>)"
     and compile_g: "rec_ci g = (gap, gar, gft)"
     and termi_g: "\<forall> y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])])"
     and ft: "ft = max (n + 3) (max fft gft)"
     and less: "Suc y \<le> x"
   shows 
     "\<exists>stp. abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ Suc y # anything)
   code stp = (0, xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0 \<up> (ft - Suc (Suc n)) @ y # anything)"
 proof -
   let ?A = "[Dec  ft (length gap + 7)]"
   let ?B = "gap"
   let ?C = "[Inc n, Dec (Suc n) 3, Goto (Suc 0)]"
   let ?D = "[Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]"
   have "\<exists> stp. abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ Suc y # anything)
             ((?A [+] (?B [+] ?C)) @ ?D) stp = (length (?A [+] (?B [+] ?C)), 
           xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])])
                   # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything)"
   proof -
     have "\<exists> stp. abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ Suc y # anything)
       ((?A [+] (?B [+] ?C))) stp = (length (?A [+] (?B [+] ?C)),  xs @ (x - y) # 0 # 
       rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything)"
     proof -
-      have "{\<lambda> nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ Suc y # anything}
+      have "\<lbrace>\<lambda> nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ Suc y # anything\<rbrace>
         (?A [+] (?B [+] ?C)) 
-        {\<lambda> nl. nl = xs @ (x - y) # 0 # 
-        rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything}"
+        \<lbrace>\<lambda> nl. nl = xs @ (x - y) # 0 # 
+        rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything\<rbrace>"
       proof(rule_tac abc_Hoare_plus_halt)
-        show "{\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ Suc y # anything}
+        show "\<lbrace>\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ Suc y # anything\<rbrace>
           [Dec ft (length gap + 7)] 
-          {\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ y # anything}"
+          \<lbrace>\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ y # anything\<rbrace>"
           using ft len
           by(simp)
       next
         show 
-          "{\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ y # anything} 
+          "\<lbrace>\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ y # anything\<rbrace> 
           ?B [+] ?C
-          {\<lambda>nl. nl = xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything}"
+          \<lbrace>\<lambda>nl. nl = xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything\<rbrace>"
         proof(rule_tac abc_Hoare_plus_halt)
           have a: "gar = Suc (Suc n)" 
             using compile_g termi_g len less
             by simp
           have b: "gft > gar"
             using compile_g
             by(erule_tac footprint_ge)
-          show "{\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ y # anything} gap 
-                {\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 
-                      rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything}"
+          show "\<lbrace>\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ y # anything\<rbrace> gap 
+                \<lbrace>\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 
+                      rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything\<rbrace>"
           proof -
             have 
-              "{\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (gft - gar) @ 0\<up>(ft - gft) @ y # anything} gap
-              {\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 
-              rec_exec g (xs @ [(x - Suc y), rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (gft - Suc gar) @ 0\<up>(ft - gft) @ y # anything}"
+              "\<lbrace>\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (gft - gar) @ 0\<up>(ft - gft) @ y # anything\<rbrace> gap
+              \<lbrace>\<lambda>nl. nl = xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 
+              rec_exec g (xs @ [(x - Suc y), rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (gft - Suc gar) @ 0\<up>(ft - gft) @ y # anything\<rbrace>"
               using g_ind less by simp
             thus "?thesis"
               using a b ft
               by(simp add: replicate_merge_anywhere numeral_3_eq_3)
           qed
         next
-          show "{\<lambda>nl. nl = xs @ (x - Suc y) #
+          show "\<lbrace>\<lambda>nl. nl = xs @ (x - Suc y) #
                     rec_exec (Pr n f g) (xs @ [x - Suc y]) #
-            rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything}
+            rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything\<rbrace>
             [Inc n, Dec (Suc n) 3, Goto (Suc 0)]
-            {\<lambda>nl. nl = xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) 
-                    (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything}"
+            \<lbrace>\<lambda>nl. nl = xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) 
+                    (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything\<rbrace>"
             using len less
             using adjust_paras[of xs n "x - Suc y" " rec_exec (Pr n f g) (xs @ [x - Suc y])"
                 " rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 
               0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything"]
             by(simp add: Suc_diff_Suc)
         qed
       qed
       thus "?thesis"
         apply(simp add: abc_Hoare_halt_def, auto)
         apply(rename_tac na)
         apply(rule_tac x = na in exI, case_tac "abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 
           0 \<up> (ft - Suc (Suc n)) @ Suc y # anything)
              ([Dec ft (length gap + 7)] [+] (gap [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)])) na", simp)
         done
     qed
     then obtain stpa where "abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (ft - Suc (Suc n)) @ Suc y # anything)
             ((?A [+] (?B [+] ?C))) stpa = (length (?A [+] (?B [+] ?C)), 
           xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])])
                   # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything)" ..
     thus "?thesis"
-      by(erule_tac abc_append_frist_steps_halt_eq)
+      by(erule_tac abc_append_first_steps_halt_eq)
   qed
   moreover have 
     "\<exists> stp. abc_steps_l (length (?A [+] (?B [+] ?C)),
     xs @ (x - y) # 0 # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything)
     ((?A [+] (?B [+] ?C)) @ ?D) stp  = (0, xs @ (x - y) # rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) # 
     0 # 0 \<up> (ft - Suc (Suc (Suc n))) @ y # anything)"
     using len
     by(rule_tac loop_back, simp_all)
   moreover have "rec_exec g (xs @ [x - Suc y, rec_exec (Pr n f g) (xs @ [x - Suc y])]) = rec_exec (Pr n f g) (xs @ [x - y])"
     using less
     apply(cases "x - y", simp_all add: rec_exec_pr_Suc_simps)
     apply(rename_tac nat)
     by(subgoal_tac "nat = x - Suc y", simp, arith)    
   ultimately show "?thesis"
     using code ft 
     apply (auto simp add: abc_steps_add replicate_Suc_iff_anywhere)
     apply(rename_tac stp stpa)
     apply(rule_tac x = "stp + stpa" in exI)
     by (simp add: abc_steps_add replicate_Suc_iff_anywhere del: replicate_Suc)
 qed
 
 lemma abc_lm_s_simp0[simp]: 
   "length xs = n \<Longrightarrow> abc_lm_s (xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (max (n + 3) 
   (max fft gft) - Suc (Suc n)) @ 0 # anything) (max (n + 3) (max fft gft)) 0 =
     xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (max (n + 3) (max fft gft) - Suc n) @ anything"
   apply(simp add: abc_lm_s.simps)
   using list_update_length[of "xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (max (n + 3) (max fft gft) - Suc (Suc n))"
       0 anything 0]
   apply(auto simp: Suc_diff_Suc)
   apply(simp add: exp_suc[THEN sym] Suc_diff_Suc  del: replicate_Suc)
   done
 
 lemma index_at_zero_elem[simp]:
   "(xs @ x # re # 0 \<up> (max (length xs + 3)
   (max fft gft) - Suc (Suc (length xs))) @ 0 # anything) !
     max (length xs + 3) (max fft gft) = 0"
   using nth_append_length[of "xs @ x # re #
   0 \<up> (max (length xs + 3) (max fft gft) - Suc (Suc (length xs)))" 0  anything]
   by(simp)
 
 lemma pr_loop_correct:
   assumes less: "y \<le> x" 
     and len: "length xs = n"
     and compile_g: "rec_ci g = (gap, gar, gft)"
     and termi_g: "\<forall> y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])])"
-    and g_ind: "\<forall> y<x. (\<forall>anything. {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (gft - gar) @ anything} gap
-  {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (gft - Suc gar) @ anything})"
-  shows "{\<lambda>nl. nl = xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0 \<up> (max (n + 3) (max fft gft) - Suc (Suc n)) @ y # anything}
+    and g_ind: "\<forall> y<x. (\<forall>anything. \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (gft - gar) @ anything\<rbrace> gap
+  \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (gft - Suc gar) @ anything\<rbrace>)"
+  shows "\<lbrace>\<lambda>nl. nl = xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0 \<up> (max (n + 3) (max fft gft) - Suc (Suc n)) @ y # anything\<rbrace>
    ([Dec (max (n + 3) (max fft gft)) (length gap + 7)] [+] (gap [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)])) @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]
-   {\<lambda>nl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (max (n + 3) (max fft gft) - Suc n) @ anything}" 
+   \<lbrace>\<lambda>nl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (max (n + 3) (max fft gft) - Suc n) @ anything\<rbrace>" 
   using less
 proof(induct y)
   case 0
   thus "?case"
     using len
     apply(simp add: abc_Hoare_halt_def)
     apply(rule_tac x = 1 in exI)
     by(auto simp: abc_steps_l.simps abc_step_l.simps abc_fetch.simps 
         nth_append abc_comp.simps abc_shift.simps, simp add: abc_lm_v.simps)
 next
   case (Suc y)
   let ?ft = "max (n + 3) (max fft gft)"
   let ?C = "[Dec (max (n + 3) (max fft gft)) (length gap + 7)] [+] (gap [+] 
     [Inc n, Dec (Suc n) 3, Goto (Suc 0)]) @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]"
   have ind: "y \<le> x \<Longrightarrow>
-         {\<lambda>nl. nl = xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0 \<up> (?ft - Suc (Suc n)) @ y # anything}
-         ?C {\<lambda>nl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (?ft - Suc n) @ anything}" by fact 
+         \<lbrace>\<lambda>nl. nl = xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0 \<up> (?ft - Suc (Suc n)) @ y # anything\<rbrace>
+         ?C \<lbrace>\<lambda>nl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (?ft - Suc n) @ anything\<rbrace>" by fact 
   have less: "Suc y \<le> x" by fact
   have stp1: 
     "\<exists> stp. abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (?ft - Suc (Suc n)) @ Suc y # anything)
     ?C stp  = (0, xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0 \<up> (?ft - Suc (Suc n)) @ y # anything)"
     using assms less
     by(rule_tac  pr_loop, auto)
   then obtain stp1 where a:
     "abc_steps_l (0, xs @ (x - Suc y) # rec_exec (Pr n f g) (xs @ [x - Suc y]) # 0 \<up> (?ft - Suc (Suc n)) @ Suc y # anything)
    ?C stp1 = (0, xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0 \<up> (?ft - Suc (Suc n)) @ y # anything)" ..
   moreover have 
     "\<exists> stp. abc_steps_l (0, xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0 \<up> (?ft - Suc (Suc n)) @ y # anything)
     ?C stp = (length ?C, xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (?ft - Suc n) @ anything)"
     using ind less
     apply(auto simp: abc_Hoare_halt_def)
     apply(rename_tac na,case_tac "abc_steps_l (0, xs @ (x - y) # rec_exec (Pr n f g) 
       (xs @ [x - y]) # 0 \<up> (?ft - Suc (Suc n)) @ y # anything) ?C na", rule_tac x = na in exI)
     by simp
   then obtain stp2 where b:
     "abc_steps_l (0, xs @ (x - y) # rec_exec (Pr n f g) (xs @ [x - y]) # 0 \<up> (?ft - Suc (Suc n)) @ y # anything)
     ?C stp2 = (length ?C, xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (?ft - Suc n) @ anything)" ..
   from a b show "?case"
     apply(simp add: abc_Hoare_halt_def)
     apply(rule_tac x = "stp1 + stp2" in exI, simp add: abc_steps_add).
 qed
 
 lemma compile_pr_correct':
   assumes termi_g: "\<forall> y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])])"
     and g_ind: 
-    "\<forall> y<x. (\<forall>anything. {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (gft - gar) @ anything} gap
-  {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (gft - Suc gar) @ anything})"
+    "\<forall> y<x. (\<forall>anything. \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (gft - gar) @ anything\<rbrace> gap
+  \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (gft - Suc gar) @ anything\<rbrace>)"
     and termi_f: "terminate f xs"
-    and f_ind: "\<And> anything. {\<lambda>nl. nl = xs @ 0 \<up> (fft - far) @ anything} fap {\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (fft - Suc far) @ anything}"
+    and f_ind: "\<And> anything. \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (fft - far) @ anything\<rbrace> fap \<lbrace>\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (fft - Suc far) @ anything\<rbrace>"
     and len: "length xs = n"
     and compile1: "rec_ci f = (fap, far, fft)"
     and compile2: "rec_ci g = (gap, gar, gft)"
   shows 
-    "{\<lambda>nl. nl = xs @ x # 0 \<up> (max (n + 3) (max fft gft) - n) @ anything}
+    "\<lbrace>\<lambda>nl. nl = xs @ x # 0 \<up> (max (n + 3) (max fft gft) - n) @ anything\<rbrace>
   mv_box n (max (n + 3) (max fft gft)) [+]
   (fap [+] (mv_box n (Suc n) [+]
   ([Dec (max (n + 3) (max fft gft)) (length gap + 7)] [+] (gap [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)]) @
   [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)])))
-  {\<lambda>nl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (max (n + 3) (max fft gft) - Suc n) @ anything}"
+  \<lbrace>\<lambda>nl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (max (n + 3) (max fft gft) - Suc n) @ anything\<rbrace>"
 proof -
   let ?ft = "max (n+3) (max fft gft)"
   let ?A = "mv_box n ?ft"
   let ?B = "fap"
   let ?C = "mv_box n (Suc n)"
   let ?D = "[Dec ?ft (length gap + 7)]"
   let ?E = "gap [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)]"
   let ?F = "[Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length gap + 4)]"
   let ?P = "\<lambda>nl. nl = xs @ x # 0 \<up> (?ft - n) @ anything"
   let ?S = "\<lambda>nl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (?ft - Suc n) @ anything"
   let ?Q1 = "\<lambda>nl. nl = xs @ 0 \<up> (?ft - n) @  x # anything"
-  show "{?P} (?A [+] (?B [+] (?C [+] (?D [+] ?E @ ?F)))) {?S}"
+  show "\<lbrace>?P\<rbrace> (?A [+] (?B [+] (?C [+] (?D [+] ?E @ ?F)))) \<lbrace>?S\<rbrace>"
   proof(rule_tac abc_Hoare_plus_halt)
-    show "{?P} ?A {?Q1}"
+    show "\<lbrace>?P\<rbrace> ?A \<lbrace>?Q1\<rbrace>"
       using len by simp
   next
     let ?Q2 = "\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (?ft - Suc n) @  x # anything"
     have a: "?ft \<ge> fft"
       by arith
     have b: "far = n"
       using compile1 termi_f len
       by(drule_tac param_pattern, auto)
     have c: "fft > far"
       using compile1
       by(simp add: footprint_ge)
-    show "{?Q1} (?B [+] (?C [+] (?D [+] ?E @ ?F))) {?S}"
+    show "\<lbrace>?Q1\<rbrace> (?B [+] (?C [+] (?D [+] ?E @ ?F))) \<lbrace>?S\<rbrace>"
     proof(rule_tac abc_Hoare_plus_halt)
-      have "{\<lambda>nl. nl = xs @ 0 \<up> (fft - far) @ 0\<up>(?ft - fft) @ x # anything} fap 
-            {\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (fft - Suc far) @ 0\<up>(?ft - fft) @ x # anything}"
+      have "\<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (fft - far) @ 0\<up>(?ft - fft) @ x # anything\<rbrace> fap 
+            \<lbrace>\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (fft - Suc far) @ 0\<up>(?ft - fft) @ x # anything\<rbrace>"
         by(rule_tac f_ind)
       moreover have "fft - far + ?ft - fft = ?ft - far"
         using a b c by arith
       moreover have "fft - Suc n + ?ft - fft = ?ft - Suc n"
         using a b c by arith
-      ultimately show "{?Q1} ?B {?Q2}"
+      ultimately show "\<lbrace>?Q1\<rbrace> ?B \<lbrace>?Q2\<rbrace>"
         using b
         by(simp add: replicate_merge_anywhere)
     next
       let ?Q3 = "\<lambda> nl. nl = xs @ 0 # rec_exec f xs # 0\<up>(?ft - Suc (Suc n)) @ x # anything"
-      show "{?Q2} (?C [+] (?D [+] ?E @ ?F)) {?S}"
+      show "\<lbrace>?Q2\<rbrace> (?C [+] (?D [+] ?E @ ?F)) \<lbrace>?S\<rbrace>"
       proof(rule_tac abc_Hoare_plus_halt)
-        show "{?Q2} (?C) {?Q3}"
+        show "\<lbrace>?Q2\<rbrace> (?C) \<lbrace>?Q3\<rbrace>"
           using mv_box_correct[of n "Suc n" "xs @ rec_exec f xs # 0 \<up> (max (n + 3) (max fft gft) - Suc n) @ x # anything"]
           using len
           by(auto)
       next
-        show "{?Q3} (?D [+] ?E @ ?F) {?S}"
+        show "\<lbrace>?Q3\<rbrace> (?D [+] ?E @ ?F) \<lbrace>?S\<rbrace>"
           using pr_loop_correct[of x x xs n g  gap gar gft f fft anything] assms
           by(simp add: rec_exec_pr_0_simps)
       qed
     qed
   qed
 qed 
 
 lemma compile_pr_correct:
   assumes g_ind: "\<forall>y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) \<and>
   (\<forall>x xa xb. rec_ci g = (x, xa, xb) \<longrightarrow>
-  (\<forall>xc. {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (xb - xa) @ xc} x
-  {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (xb - Suc xa) @ xc}))"
+  (\<forall>xc. \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (xb - xa) @ xc\<rbrace> x
+  \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (xb - Suc xa) @ xc\<rbrace>))"
     and termi_f: "terminate f xs"
     and f_ind:
     "\<And>ap arity fp anything.
-  rec_ci f = (ap, arity, fp) \<Longrightarrow> {\<lambda>nl. nl = xs @ 0 \<up> (fp - arity) @ anything} ap {\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (fp - Suc arity) @ anything}"
+  rec_ci f = (ap, arity, fp) \<Longrightarrow> \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (fp - arity) @ anything\<rbrace> ap \<lbrace>\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (fp - Suc arity) @ anything\<rbrace>"
     and len: "length xs = n"
     and compile: "rec_ci (Pr n f g) = (ap, arity, fp)"
-  shows "{\<lambda>nl. nl = xs @ x # 0 \<up> (fp - arity) @ anything} ap {\<lambda>nl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (fp - Suc arity) @ anything}"
+  shows "\<lbrace>\<lambda>nl. nl = xs @ x # 0 \<up> (fp - arity) @ anything\<rbrace> ap \<lbrace>\<lambda>nl. nl = xs @ x # rec_exec (Pr n f g) (xs @ [x]) # 0 \<up> (fp - Suc arity) @ anything\<rbrace>"
 proof(cases "rec_ci f", cases "rec_ci g")
   fix fap far fft gap gar gft
   assume h: "rec_ci f = (fap, far, fft)" "rec_ci g = (gap, gar, gft)"
   have g: 
     "\<forall>y<x. (terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) \<and>
-     (\<forall>anything. {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (gft - gar) @ anything} gap
-    {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (gft - Suc gar) @ anything}))"
+     (\<forall>anything. \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (gft - gar) @ anything\<rbrace> gap
+    \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (gft - Suc gar) @ anything\<rbrace>))"
     using g_ind h
     by(auto)
   hence termi_g: "\<forall> y<x. terminate g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])])"
     by simp
   from g have g_newind: 
-    "\<forall> y<x. (\<forall>anything. {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (gft - gar) @ anything} gap
-    {\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (gft - Suc gar) @ anything})"
+    "\<forall> y<x. (\<forall>anything. \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # 0 \<up> (gft - gar) @ anything\<rbrace> gap
+    \<lbrace>\<lambda>nl. nl = xs @ y # rec_exec (Pr n f g) (xs @ [y]) # rec_exec g (xs @ [y, rec_exec (Pr n f g) (xs @ [y])]) # 0 \<up> (gft - Suc gar) @ anything\<rbrace>)"
     by auto
-  have f_newind: "\<And> anything. {\<lambda>nl. nl = xs @ 0 \<up> (fft - far) @ anything} fap {\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (fft - Suc far) @ anything}"
+  have f_newind: "\<And> anything. \<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (fft - far) @ anything\<rbrace> fap \<lbrace>\<lambda>nl. nl = xs @ rec_exec f xs # 0 \<up> (fft - Suc far) @ anything\<rbrace>"
     using h
     by(rule_tac f_ind, simp)
   show "?thesis"
     using termi_f termi_g h compile
     apply(simp add: rec_ci.simps abc_comp_commute, auto)
     using g_newind f_newind len
     by(rule_tac compile_pr_correct', simp_all)
 qed
 
+subsubsection \<open>Correctness of compilation for constructor Mn\<close>
+
 fun mn_ind_inv ::
   "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> bool"
   where
     "mn_ind_inv (as, lm') ss x rsx suf_lm lm = 
            (if as = ss then lm' = lm @ x # rsx # suf_lm
             else if as = ss + 1 then 
                  \<exists>y. (lm' = lm @ x # y # suf_lm) \<and> y \<le> rsx
             else if as = ss + 2 then 
                  \<exists>y. (lm' = lm @ x # y # suf_lm) \<and> y \<le> rsx
             else if as = ss + 3 then lm' = lm @ x # 0 # suf_lm
             else if as = ss + 4 then lm' = lm @ Suc x # 0 # suf_lm
             else if as = 0 then lm' = lm @ Suc x # 0 # suf_lm
             else False
 )"
 
 fun mn_stage1 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "mn_stage1 (as, lm) ss n = 
             (if as = 0 then 0 
              else if as = ss + 4 then 1
              else if as = ss + 3 then 2
              else if as = ss + 2 \<or> as = ss + 1 then 3
              else if as = ss then 4
              else 0
 )"
 
 fun mn_stage2 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "mn_stage2 (as, lm) ss n = 
             (if as = ss + 1 \<or> as = ss + 2 then (lm ! (Suc n))
              else 0)"
 
 fun mn_stage3 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "mn_stage3 (as, lm) ss n = (if as = ss + 2 then 1 else 0)"
 
 
 fun mn_measure :: "((nat \<times> nat list) \<times> nat \<times> nat) \<Rightarrow>
                                                 (nat \<times> nat \<times> nat)"
   where
     "mn_measure ((as, lm), ss, n) = 
      (mn_stage1 (as, lm) ss n, mn_stage2 (as, lm) ss n,
                                        mn_stage3 (as, lm) ss n)"
 
 definition mn_LE :: "(((nat \<times> nat list) \<times> nat \<times> nat) \<times>
                      ((nat \<times> nat list) \<times> nat \<times> nat)) set"
   where "mn_LE \<equiv> (inv_image lex_triple mn_measure)"
 
 lemma wf_mn_le[intro]: "wf mn_LE"
   by(auto intro:wf_inv_image wf_lex_triple simp: mn_LE_def)
 
 declare mn_ind_inv.simps[simp del]
 
 lemma put_in_tape_small_enough0[simp]: 
   "0 < rsx \<Longrightarrow> 
  \<exists>y. (xs @ x # rsx # anything)[Suc (length xs) := rsx - Suc 0] = xs @ x # y # anything \<and> y \<le> rsx"
   apply(rule_tac x = "rsx - 1" in exI)
   apply(simp add: list_update_append list_update.simps)
   done
 
 lemma put_in_tape_small_enough1[simp]: 
   "\<lbrakk>y \<le> rsx; 0 < y\<rbrakk>
             \<Longrightarrow> \<exists>ya. (xs @ x # y # anything)[Suc (length xs) := y - Suc 0] = xs @ x # ya # anything \<and> ya \<le> rsx"
   apply(rule_tac x = "y - 1" in exI)
   apply(simp add: list_update_append list_update.simps)
   done
 
 lemma abc_comp_null[simp]: "(A [+] B = []) = (A = [] \<and> B = [])"
   by(auto simp: abc_comp.simps abc_shift.simps)
 
 lemma rec_ci_not_null[simp]: "(rec_ci f \<noteq> ([], a, b))"
 proof(cases f)
   case (Cn x41 x42 x43)
   then show ?thesis
     by(cases "rec_ci x42", auto simp: mv_box.simps rec_ci.simps rec_ci_id.simps)
 next
   case (Pr x51 x52 x53)
   then show ?thesis 
     apply(cases "rec_ci x52", cases "rec_ci x53")
     by (auto simp: mv_box.simps rec_ci.simps rec_ci_id.simps)
 next
   case (Mn x61 x62)
   then show ?thesis 
     by(cases "rec_ci x62") (auto simp: rec_ci.simps rec_ci_id.simps)
 qed (auto simp: rec_ci_z_def rec_ci_s_def rec_ci.simps addition.simps rec_ci_id.simps)
 
 
 lemma mn_correct:
   assumes compile: "rec_ci rf = (fap, far, fft)"
     and ge: "0 < rsx"
     and len: "length xs = arity"
     and B: "B = [Dec (Suc arity) (length fap + 5), Dec (Suc arity) (length fap + 3), Goto (Suc (length fap)), Inc arity, Goto 0]"
     and f: "f = (\<lambda> stp. (abc_steps_l (length fap, xs @ x # rsx # anything) (fap @ B) stp, (length fap), arity)) "
     and P: "P =(\<lambda> ((as, lm), ss, arity). as = 0)"
     and Q: "Q = (\<lambda> ((as, lm), ss, arity). mn_ind_inv (as, lm) (length fap) x rsx anything xs)"
   shows "\<exists> stp. P (f stp) \<and> Q (f stp)"
 proof(rule_tac halt_lemma2)
   show "wf mn_LE"
     using wf_mn_le by simp
 next
   show "Q (f 0)"
     by(auto simp: Q f abc_steps_l.simps mn_ind_inv.simps)
 next
   have "fap \<noteq> []"
     using compile by auto
   thus "\<not> P (f 0)"
     by(auto simp: f P abc_steps_l.simps)
 next
   have "fap \<noteq> []"
     using compile by auto
   then have "\<lbrakk>\<not> P (f stp); Q (f stp)\<rbrakk> \<Longrightarrow> Q (f (Suc stp)) \<and> (f (Suc stp), f stp) \<in> mn_LE" for stp
     using ge len
     apply(cases "(abc_steps_l (length fap, xs @ x # rsx # anything) (fap @ B) stp)")
     apply(simp add: abc_step_red2  B f P Q)
     apply(auto split:if_splits simp add:abc_steps_l.simps  mn_ind_inv.simps abc_steps_zero B abc_fetch.simps nth_append)
     by(auto simp: mn_LE_def lex_triple_def lex_pair_def 
         abc_step_l.simps abc_steps_l.simps mn_ind_inv.simps
         abc_lm_v.simps abc_lm_s.simps nth_append abc_fetch.simps
         split: if_splits)    
   thus "\<forall>stp. \<not> P (f stp) \<and> Q (f stp) \<longrightarrow> Q (f (Suc stp)) \<and> (f (Suc stp), f stp) \<in> mn_LE"
     by(auto)
 qed
 
 lemma abc_Hoare_haltE:
-  "{\<lambda> nl. nl = lm1} p {\<lambda> nl. nl = lm2}
+  "\<lbrace>\<lambda> nl. nl = lm1\<rbrace> p \<lbrace>\<lambda> nl. nl = lm2\<rbrace>
     \<Longrightarrow> \<exists> stp. abc_steps_l (0, lm1) p stp = (length p, lm2)"
   by(auto simp:abc_Hoare_halt_def elim!: abc_holds_for.elims)
 
 lemma mn_loop:
   assumes B:  "B = [Dec (Suc arity) (length fap + 5), Dec (Suc arity) (length fap + 3), Goto (Suc (length fap)), Inc arity, Goto 0]"
     and ft: "ft = max (Suc arity) fft"
     and len: "length xs = arity"
     and far: "far = Suc arity"
-    and ind: " (\<forall>xc. ({\<lambda>nl. nl = xs @ x # 0 \<up> (fft - far) @ xc} fap
-    {\<lambda>nl. nl = xs @ x # rec_exec f (xs @ [x]) # 0 \<up> (fft - Suc far) @ xc}))"
+    and ind: " (\<forall>xc. (\<lbrace>\<lambda>nl. nl = xs @ x # 0 \<up> (fft - far) @ xc\<rbrace> fap
+    \<lbrace>\<lambda>nl. nl = xs @ x # rec_exec f (xs @ [x]) # 0 \<up> (fft - Suc far) @ xc\<rbrace>))"
     and exec_less: "rec_exec f (xs @ [x]) > 0"
     and compile: "rec_ci f = (fap, far, fft)"
   shows "\<exists> stp > 0. abc_steps_l (0, xs @ x # 0 \<up> (ft - Suc arity) @ anything) (fap @ B) stp =
     (0, xs @ Suc x # 0 \<up> (ft - Suc arity) @ anything)"
 proof -
   have "\<exists> stp. abc_steps_l (0, xs @ x # 0 \<up> (ft - Suc arity) @ anything) (fap @ B) stp =
     (length fap, xs @ x # rec_exec f (xs @ [x]) # 0 \<up> (ft - Suc (Suc arity)) @ anything)"
   proof -
     have "\<exists> stp. abc_steps_l (0, xs @ x # 0 \<up> (ft - Suc arity) @ anything) fap stp =
       (length fap, xs @ x # rec_exec f (xs @ [x]) # 0 \<up> (ft - Suc (Suc arity)) @ anything)"
     proof -
-      have "{\<lambda>nl. nl = xs @ x # 0 \<up> (fft - far) @ 0\<up>(ft - fft) @ anything} fap 
-            {\<lambda>nl. nl = xs @ x # rec_exec f (xs @ [x]) # 0 \<up> (fft - Suc far) @ 0\<up>(ft - fft) @ anything}"
+      have "\<lbrace>\<lambda>nl. nl = xs @ x # 0 \<up> (fft - far) @ 0\<up>(ft - fft) @ anything\<rbrace> fap 
+            \<lbrace>\<lambda>nl. nl = xs @ x # rec_exec f (xs @ [x]) # 0 \<up> (fft - Suc far) @ 0\<up>(ft - fft) @ anything\<rbrace>"
         using ind by simp
       moreover have "fft > far"
         using compile
         by(erule_tac footprint_ge)
       ultimately show "?thesis"
         using ft far
         apply(drule_tac abc_Hoare_haltE)
         by(simp add: replicate_merge_anywhere max_absorb2)
     qed
     then obtain stp where "abc_steps_l (0, xs @ x # 0 \<up> (ft - Suc arity) @ anything) fap stp =
       (length fap, xs @ x # rec_exec f (xs @ [x]) # 0 \<up> (ft - Suc (Suc arity)) @ anything)" ..
     thus "?thesis"
-      by(erule_tac abc_append_frist_steps_halt_eq)
+      by(erule_tac abc_append_first_steps_halt_eq)
   qed
   moreover have 
     "\<exists> stp > 0. abc_steps_l (length fap, xs @ x # rec_exec f (xs @ [x]) # 0 \<up> (ft - Suc (Suc arity)) @ anything) (fap @ B) stp =
     (0, xs @ Suc x # 0 # 0 \<up> (ft - Suc (Suc arity)) @ anything)"
     using mn_correct[of f fap far fft "rec_exec f (xs @ [x])" xs arity B
         "(\<lambda>stp. (abc_steps_l (length fap, xs @ x # rec_exec f (xs @ [x]) # 0 \<up> (ft - Suc (Suc arity)) @ anything) (fap @ B) stp, length fap, arity))"     
         x "0 \<up> (ft - Suc (Suc arity)) @ anything" "(\<lambda>((as, lm), ss, arity). as = 0)" 
         "(\<lambda>((as, lm), ss, aritya). mn_ind_inv (as, lm) (length fap) x (rec_exec f (xs @ [x])) (0 \<up> (ft - Suc (Suc arity)) @ anything) xs) "]  
       B compile  exec_less len
     apply(subgoal_tac "fap \<noteq> []", auto)
     apply(rename_tac stp y)
     apply(rule_tac x = stp in exI, auto simp: mn_ind_inv.simps)
     by(case_tac "stp", simp_all add: abc_steps_l.simps)
   moreover have "fft > far"
     using compile
     by(erule_tac footprint_ge)
   ultimately show "?thesis"
     using ft far
     apply(auto) apply(rename_tac stp1 stp2)
     by(rule_tac x = "stp1 + stp2" in exI, 
         simp add: abc_steps_add replicate_Suc[THEN sym] diff_Suc_Suc del: replicate_Suc)
 qed
 
 lemma mn_loop_correct': 
   assumes B:  "B = [Dec (Suc arity) (length fap + 5), Dec (Suc arity) (length fap + 3), Goto (Suc (length fap)), Inc arity, Goto 0]"
     and ft: "ft = max (Suc arity) fft"
     and len: "length xs = arity"
-    and ind_all: "\<forall>i\<le>x. (\<forall>xc. ({\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc} fap
-    {\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc}))"
+    and ind_all: "\<forall>i\<le>x. (\<forall>xc. (\<lbrace>\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc\<rbrace> fap
+    \<lbrace>\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc\<rbrace>))"
     and exec_ge: "\<forall> i\<le>x. rec_exec f (xs @ [i]) > 0"
     and compile: "rec_ci f = (fap, far, fft)"
     and far: "far = Suc arity"
   shows "\<exists> stp > x. abc_steps_l (0, xs @ 0 # 0 \<up> (ft - Suc arity) @ anything) (fap @ B) stp = 
                (0, xs @ Suc x # 0 \<up> (ft - Suc arity) @ anything)"
   using ind_all exec_ge
 proof(induct x)
   case 0
   thus "?case"
     using assms
     by(rule_tac mn_loop, simp_all)
 next
   case (Suc x)
-  have ind': "\<lbrakk>\<forall>i\<le>x. \<forall>xc. {\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc} fap {\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc};
+  have ind': "\<lbrakk>\<forall>i\<le>x. \<forall>xc. \<lbrace>\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc\<rbrace> fap \<lbrace>\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc\<rbrace>;
                \<forall>i\<le>x. 0 < rec_exec f (xs @ [i])\<rbrakk> \<Longrightarrow> 
             \<exists>stp > x. abc_steps_l (0, xs @ 0 # 0 \<up> (ft - Suc arity) @ anything) (fap @ B) stp = (0, xs @ Suc x # 0 \<up> (ft - Suc arity) @ anything)" by fact
   have exec_ge: "\<forall>i\<le>Suc x. 0 < rec_exec f (xs @ [i])" by fact
-  have ind_all: "\<forall>i\<le>Suc x. \<forall>xc. {\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc} fap 
-    {\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc}" by fact
+  have ind_all: "\<forall>i\<le>Suc x. \<forall>xc. \<lbrace>\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc\<rbrace> fap 
+    \<lbrace>\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc\<rbrace>" by fact
   have ind: "\<exists>stp > x. abc_steps_l (0, xs @ 0 # 0 \<up> (ft - Suc arity) @ anything) (fap @ B) stp =
     (0, xs @ Suc x # 0 \<up> (ft - Suc arity) @ anything)" using ind' exec_ge ind_all by simp
   have stp: "\<exists> stp > 0. abc_steps_l (0, xs @ Suc x # 0 \<up> (ft - Suc arity) @ anything) (fap @ B) stp =
     (0, xs @ Suc (Suc x) # 0 \<up> (ft - Suc arity) @ anything)"
     using ind_all exec_ge B ft len far compile
     by(rule_tac mn_loop, simp_all)
   from ind stp show "?case"
     apply(auto simp add: abc_steps_add)
     apply(rename_tac stp1 stp2)
     by(rule_tac x = "stp1 + stp2" in exI, simp add: abc_steps_add)
 qed
 
 lemma mn_loop_correct: 
   assumes B:  "B = [Dec (Suc arity) (length fap + 5), Dec (Suc arity) (length fap + 3), Goto (Suc (length fap)), Inc arity, Goto 0]"
     and ft: "ft = max (Suc arity) fft"
     and len: "length xs = arity"
-    and ind_all: "\<forall>i\<le>x. (\<forall>xc. ({\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc} fap
-    {\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc}))"
+    and ind_all: "\<forall>i\<le>x. (\<forall>xc. (\<lbrace>\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc\<rbrace> fap
+    \<lbrace>\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc\<rbrace>))"
     and exec_ge: "\<forall> i\<le>x. rec_exec f (xs @ [i]) > 0"
     and compile: "rec_ci f = (fap, far, fft)"
     and far: "far = Suc arity"
   shows "\<exists> stp. abc_steps_l (0, xs @ 0 # 0 \<up> (ft - Suc arity) @ anything) (fap @ B) stp = 
                (0, xs @ Suc x # 0 \<up> (ft - Suc arity) @ anything)"
 proof -
   have "\<exists>stp>x. abc_steps_l (0, xs @ 0 # 0 \<up> (ft - Suc arity) @ anything) (fap @ B) stp = (0, xs @ Suc x # 0 \<up> (ft - Suc arity) @ anything)"
     using assms
     by(rule_tac mn_loop_correct', simp_all)
   thus "?thesis"
     by(auto)
 qed
 
 lemma compile_mn_correct': 
   assumes B:  "B = [Dec (Suc arity) (length fap + 5), Dec (Suc arity) (length fap + 3), Goto (Suc (length fap)), Inc arity, Goto 0]"
     and ft: "ft = max (Suc arity) fft"
     and len: "length xs = arity"
     and termi_f: "terminate f (xs @ [r])"
-    and f_ind: "\<And>anything. {\<lambda>nl. nl = xs @ r # 0 \<up> (fft - far) @ anything} fap 
-        {\<lambda>nl. nl = xs @ r # 0 # 0 \<up> (fft - Suc far) @ anything}"
-    and ind_all: "\<forall>i < r. (\<forall>xc. ({\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc} fap
-    {\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc}))"
+    and f_ind: "\<And>anything. \<lbrace>\<lambda>nl. nl = xs @ r # 0 \<up> (fft - far) @ anything\<rbrace> fap 
+        \<lbrace>\<lambda>nl. nl = xs @ r # 0 # 0 \<up> (fft - Suc far) @ anything\<rbrace>"
+    and ind_all: "\<forall>i < r. (\<forall>xc. (\<lbrace>\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc\<rbrace> fap
+    \<lbrace>\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc\<rbrace>))"
     and exec_less: "\<forall> i<r. rec_exec f (xs @ [i]) > 0"
     and exec: "rec_exec f (xs @ [r]) = 0"
     and compile: "rec_ci f = (fap, far, fft)"
-  shows "{\<lambda>nl. nl = xs @ 0 \<up> (max (Suc arity) fft - arity) @ anything}
+  shows "\<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (max (Suc arity) fft - arity) @ anything\<rbrace>
     fap @ B
-    {\<lambda>nl. nl = xs @ rec_exec (Mn arity f) xs # 0 \<up> (max (Suc arity) fft - Suc arity) @ anything}"
+    \<lbrace>\<lambda>nl. nl = xs @ rec_exec (Mn arity f) xs # 0 \<up> (max (Suc arity) fft - Suc arity) @ anything\<rbrace>"
 proof -
   have a: "far = Suc arity"
     using len compile termi_f
     by(drule_tac param_pattern, auto)
   have b: "fft > far"
     using compile
     by(erule_tac footprint_ge)
   have "\<exists> stp. abc_steps_l (0, xs @ 0 # 0 \<up> (ft - Suc arity) @ anything) (fap @ B) stp = 
     (0, xs @ r # 0 \<up> (ft - Suc arity) @ anything)"
     using assms a
     apply(cases r, rule_tac x = 0 in exI, simp add: abc_steps_l.simps, simp)
     by(rule_tac mn_loop_correct, auto)  
   moreover have 
     "\<exists> stp. abc_steps_l (0, xs @ r # 0 \<up> (ft - Suc arity) @ anything) (fap @ B) stp = 
     (length fap, xs @ r # rec_exec f (xs @ [r]) # 0 \<up> (ft - Suc (Suc arity)) @ anything)"
   proof -
     have "\<exists> stp. abc_steps_l (0, xs @ r # 0 \<up> (ft - Suc arity) @ anything) fap stp =
       (length fap, xs @ r # rec_exec f (xs @ [r]) # 0 \<up> (ft - Suc (Suc arity)) @ anything)"
     proof -
-      have "{\<lambda>nl. nl = xs @ r # 0 \<up> (fft - far) @ 0\<up>(ft - fft) @ anything} fap 
-            {\<lambda>nl. nl = xs @ r # rec_exec f (xs @ [r]) # 0 \<up> (fft - Suc far) @ 0\<up>(ft - fft) @ anything}"
+      have "\<lbrace>\<lambda>nl. nl = xs @ r # 0 \<up> (fft - far) @ 0\<up>(ft - fft) @ anything\<rbrace> fap 
+            \<lbrace>\<lambda>nl. nl = xs @ r # rec_exec f (xs @ [r]) # 0 \<up> (fft - Suc far) @ 0\<up>(ft - fft) @ anything\<rbrace>"
         using f_ind exec by simp
       thus "?thesis"
         using ft a b
         apply(drule_tac abc_Hoare_haltE)
         by(simp add: replicate_merge_anywhere max_absorb2)
     qed
     then obtain stp where "abc_steps_l (0, xs @ r # 0 \<up> (ft - Suc arity) @ anything) fap stp =
       (length fap, xs @ r # rec_exec f (xs @ [r]) # 0 \<up> (ft - Suc (Suc arity)) @ anything)" ..
     thus "?thesis"
-      by(erule_tac abc_append_frist_steps_halt_eq)
+      by(erule_tac abc_append_first_steps_halt_eq)
   qed
   moreover have 
     "\<exists> stp. abc_steps_l (length fap, xs @ r # rec_exec f (xs @ [r]) # 0 \<up> (ft - Suc (Suc arity)) @ anything) (fap @ B) stp = 
              (length fap + 5, xs @ r # rec_exec f (xs @ [r]) # 0 \<up> (ft - Suc (Suc arity)) @ anything)"
     using ft a b len B exec
     apply(rule_tac x = 1 in exI, auto)
     by(auto simp: abc_steps_l.simps B abc_step_l.simps 
         abc_fetch.simps nth_append max_absorb2 abc_lm_v.simps abc_lm_s.simps)
   moreover have "rec_exec (Mn (length xs) f) xs = r"
     using exec exec_less
     apply(auto simp: rec_exec.simps Least_def)
     thm the_equality
     apply(rule_tac the_equality, auto)
      apply(metis exec_less less_not_refl3 linorder_not_less)
     by (metis le_neq_implies_less less_not_refl3)
   ultimately show "?thesis"
     using ft a b len B exec
     apply(auto simp: abc_Hoare_halt_def)
     apply(rename_tac stp1 stp2 stp3)
     apply(rule_tac x = "stp1 + stp2 + stp3"  in exI)
     by(simp add: abc_steps_add replicate_Suc_iff_anywhere max_absorb2 Suc_diff_Suc del: replicate_Suc)
 qed
 
 lemma compile_mn_correct:
   assumes len: "length xs = n"
     and termi_f: "terminate f (xs @ [r])"
     and f_ind: "\<And>ap arity fp anything. rec_ci f = (ap, arity, fp) \<Longrightarrow> 
-  {\<lambda>nl. nl = xs @ r # 0 \<up> (fp - arity) @ anything} ap {\<lambda>nl. nl = xs @ r # 0 # 0 \<up> (fp - Suc arity) @ anything}"
+  \<lbrace>\<lambda>nl. nl = xs @ r # 0 \<up> (fp - arity) @ anything\<rbrace> ap \<lbrace>\<lambda>nl. nl = xs @ r # 0 # 0 \<up> (fp - Suc arity) @ anything\<rbrace>"
     and exec: "rec_exec f (xs @ [r]) = 0"
     and ind_all: 
     "\<forall>i<r. terminate f (xs @ [i]) \<and>
   (\<forall>x xa xb. rec_ci f = (x, xa, xb) \<longrightarrow> 
-  (\<forall>xc. {\<lambda>nl. nl = xs @ i # 0 \<up> (xb - xa) @ xc} x {\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (xb - Suc xa) @ xc})) \<and>
+  (\<forall>xc. \<lbrace>\<lambda>nl. nl = xs @ i # 0 \<up> (xb - xa) @ xc\<rbrace> x \<lbrace>\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (xb - Suc xa) @ xc\<rbrace>)) \<and>
   0 < rec_exec f (xs @ [i])"
     and compile: "rec_ci (Mn n f) = (ap, arity, fp)"
-  shows "{\<lambda>nl. nl = xs @ 0 \<up> (fp - arity) @ anything} ap 
-  {\<lambda>nl. nl = xs @ rec_exec (Mn n f) xs # 0 \<up> (fp - Suc arity) @ anything}"
+  shows "\<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (fp - arity) @ anything\<rbrace> ap 
+  \<lbrace>\<lambda>nl. nl = xs @ rec_exec (Mn n f) xs # 0 \<up> (fp - Suc arity) @ anything\<rbrace>"
 proof(cases "rec_ci f")
   fix fap far fft
   assume h: "rec_ci f = (fap, far, fft)"
   hence f_newind: 
-    "\<And>anything. {\<lambda>nl. nl = xs @ r # 0 \<up> (fft - far) @ anything} fap 
-        {\<lambda>nl. nl = xs @ r # 0 # 0 \<up> (fft - Suc far) @ anything}"
+    "\<And>anything. \<lbrace>\<lambda>nl. nl = xs @ r # 0 \<up> (fft - far) @ anything\<rbrace> fap 
+        \<lbrace>\<lambda>nl. nl = xs @ r # 0 # 0 \<up> (fft - Suc far) @ anything\<rbrace>"
     by(rule_tac f_ind, simp)
   have newind_all: 
-    "\<forall>i < r. (\<forall>xc. ({\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc} fap
-    {\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc}))"
+    "\<forall>i < r. (\<forall>xc. (\<lbrace>\<lambda>nl. nl = xs @ i # 0 \<up> (fft - far) @ xc\<rbrace> fap
+    \<lbrace>\<lambda>nl. nl = xs @ i # rec_exec f (xs @ [i]) # 0 \<up> (fft - Suc far) @ xc\<rbrace>))"
     using ind_all h
     by(auto)
   have all_less: "\<forall> i<r. rec_exec f (xs @ [i]) > 0"
     using ind_all by auto
   show "?thesis"
     using h compile f_newind newind_all all_less len termi_f exec
     apply(auto simp: rec_ci.simps)
     by(rule_tac compile_mn_correct', auto)
 qed
 
+subsubsection \<open>Correctness of entire compilation process rec\_ci\<close>
+
 lemma recursive_compile_correct:
   "\<lbrakk>terminate recf args; rec_ci recf = (ap, arity, fp)\<rbrakk>
-  \<Longrightarrow> {\<lambda> nl. nl = args @ 0\<up>(fp - arity) @ anything} ap 
-         {\<lambda> nl. nl = args@ rec_exec recf args # 0\<up>(fp - Suc arity) @ anything}"
+  \<Longrightarrow> \<lbrace>\<lambda> nl. nl = args @ 0\<up>(fp - arity) @ anything\<rbrace> ap 
+         \<lbrace>\<lambda> nl. nl = args@ rec_exec recf args # 0\<up>(fp - Suc arity) @ anything\<rbrace>"
   apply(induct arbitrary: ap arity fp anything rule: terminate.induct)
        apply(simp_all add: compile_s_correct compile_z_correct compile_id_correct 
       compile_cn_correct compile_pr_correct compile_mn_correct)
   done
 
 definition dummy_abc :: "nat \<Rightarrow> abc_inst list"
   where
     "dummy_abc k = [Inc k, Dec k 0, Goto 3]"
 
 definition abc_list_crsp:: "nat list \<Rightarrow> nat list \<Rightarrow> bool"
   where
     "abc_list_crsp xs ys = (\<exists> n. xs = ys @ 0\<up>n \<or> ys = xs @ 0\<up>n)"
 
 lemma abc_list_crsp_simp1[intro]: "abc_list_crsp (lm @ 0\<up>m) lm"
   by(auto simp: abc_list_crsp_def)
 
 
 lemma abc_list_crsp_lm_v: 
   "abc_list_crsp lma lmb \<Longrightarrow> abc_lm_v lma n = abc_lm_v lmb n"
   by(auto simp: abc_list_crsp_def abc_lm_v.simps 
       nth_append)
 
 
 lemma abc_list_crsp_elim: 
   "\<lbrakk>abc_list_crsp lma lmb; \<exists> n. lma = lmb @ 0\<up>n \<or> lmb = lma @ 0\<up>n \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
   by(auto simp: abc_list_crsp_def)
 
 lemma abc_list_crsp_simp[simp]: 
   "\<lbrakk>abc_list_crsp lma lmb; m < length lma; m < length lmb\<rbrakk> \<Longrightarrow>
           abc_list_crsp (lma[m := n]) (lmb[m := n])"
   by(auto simp: abc_list_crsp_def list_update_append)
 
 lemma abc_list_crsp_simp2[simp]: 
   "\<lbrakk>abc_list_crsp lma lmb; m < length lma; \<not> m < length lmb\<rbrakk> \<Longrightarrow> 
   abc_list_crsp (lma[m := n]) (lmb @ 0 \<up> (m - length lmb) @ [n])"
   apply(auto simp: abc_list_crsp_def list_update_append)
   apply(rename_tac N)
   apply(rule_tac x = "N + length lmb - Suc m" in exI)
   apply(rule_tac disjI1)
   apply(simp add: upd_conv_take_nth_drop min_absorb1)
   done
 
 lemma abc_list_crsp_simp3[simp]:
   "\<lbrakk>abc_list_crsp lma lmb; \<not> m < length lma; m < length lmb\<rbrakk> \<Longrightarrow> 
   abc_list_crsp (lma @ 0 \<up> (m - length lma) @ [n]) (lmb[m := n])"
   apply(auto simp: abc_list_crsp_def list_update_append)
   apply(rename_tac N)
   apply(rule_tac x = "N + length lma - Suc m" in exI)
   apply(rule_tac disjI2)
   apply(simp add: upd_conv_take_nth_drop min_absorb1)
   done
 
 lemma abc_list_crsp_simp4[simp]: "\<lbrakk>abc_list_crsp lma lmb; \<not> m < length lma; \<not> m < length lmb\<rbrakk> \<Longrightarrow> 
   abc_list_crsp (lma @ 0 \<up> (m - length lma) @ [n]) (lmb @ 0 \<up> (m - length lmb) @ [n])"
   by(auto simp: abc_list_crsp_def list_update_append replicate_merge_anywhere)
 
 lemma abc_list_crsp_lm_s: 
   "abc_list_crsp lma lmb \<Longrightarrow> 
       abc_list_crsp (abc_lm_s lma m n) (abc_lm_s lmb m n)"
   by(auto simp: abc_lm_s.simps)
 
 lemma abc_list_crsp_step: 
   "\<lbrakk>abc_list_crsp lma lmb; abc_step_l (aa, lma) i = (a, lma'); 
     abc_step_l (aa, lmb) i = (a', lmb')\<rbrakk>
     \<Longrightarrow> a' = a \<and> abc_list_crsp lma' lmb'"
   apply(cases i, auto simp: abc_step_l.simps 
       abc_list_crsp_lm_s abc_list_crsp_lm_v 
       split: abc_inst.splits if_splits)
   done
 
 lemma abc_list_crsp_steps: 
   "\<lbrakk>abc_steps_l (0, lm @ 0\<up>m) aprog stp = (a, lm'); aprog \<noteq> []\<rbrakk> 
       \<Longrightarrow> \<exists> lma. abc_steps_l (0, lm) aprog stp = (a, lma) \<and> 
                                           abc_list_crsp lm' lma"
 proof(induct stp arbitrary: a lm')
   case (Suc stp)
-  then show ?case using [[simproc del: defined_all]] apply(cases "abc_steps_l (0, lm @ 0\<up>m) aprog stp", simp add: abc_step_red)
+  then show ?case using [[simproc del: defined_all]]  apply(cases "abc_steps_l (0, lm @ 0\<up>m) aprog stp", simp add: abc_step_red)
   proof -
     fix stp a lm' aa b
     assume ind:
       "\<And>a lm'. aa = a \<and> b = lm' \<Longrightarrow> 
      \<exists>lma. abc_steps_l (0, lm) aprog stp = (a, lma) \<and>
                                           abc_list_crsp lm' lma"
       and h: "abc_step_l (aa, b) (abc_fetch aa aprog) = (a, lm')" 
       "abc_steps_l (0, lm @ 0\<up>m) aprog stp = (aa, b)" 
       "aprog \<noteq> []"
     have "\<exists>lma. abc_steps_l (0, lm) aprog stp = (aa, lma) \<and> 
               abc_list_crsp b lma"
       apply(rule_tac ind, simp)
       done
     from this obtain lma where g2: 
       "abc_steps_l (0, lm) aprog stp = (aa, lma) \<and> 
      abc_list_crsp b lma"   ..
     hence g3: "abc_steps_l (0, lm) aprog (Suc stp)
           = abc_step_l (aa, lma) (abc_fetch aa aprog)"
       apply(rule_tac abc_step_red, simp)
       done
+
     show "\<exists>lma. abc_steps_l (0, lm) aprog (Suc stp) = (a, lma) \<and> abc_list_crsp lm' lma"
       using g2 g3 h
       apply(auto)
       apply(cases "abc_step_l (aa, b) (abc_fetch aa aprog)",
           cases "abc_step_l (aa, lma) (abc_fetch aa aprog)", simp)
       apply(rule_tac abc_list_crsp_step, auto)
       done
   qed
 qed (force simp add: abc_steps_l.simps)
 
 lemma list_crsp_simp2: "abc_list_crsp (lm1 @ 0\<up>n) lm2 \<Longrightarrow> abc_list_crsp lm1 lm2"
 proof(induct n)
   case 0
   thus "?case"
     by(auto simp: abc_list_crsp_def)
 next
   case (Suc n)
   have ind: "abc_list_crsp (lm1 @ 0 \<up> n) lm2 \<Longrightarrow> abc_list_crsp lm1 lm2" by fact
   have h: "abc_list_crsp (lm1 @ 0 \<up> Suc n) lm2" by fact
   then have "abc_list_crsp (lm1 @ 0 \<up> n) lm2"
-    apply(auto simp only: exp_suc abc_list_crsp_def del: replicate_Suc)
+    apply(auto simp only: exp_suc abc_list_crsp_def )
      apply (metis Suc_pred append_eq_append_conv
         append_eq_append_conv2 butlast_append butlast_snoc length_replicate list.distinct(1)
         neq0_conv replicate_Suc replicate_Suc_iff_anywhere replicate_app_Cons_same 
         replicate_empty self_append_conv self_append_conv2)
     apply (auto,metis replicate_Suc)
     .
   thus "?case"
     using ind
     by auto
 qed
 
 lemma recursive_compile_correct_norm': 
   "\<lbrakk>rec_ci f = (ap, arity, ft);  
     terminate f args\<rbrakk>
   \<Longrightarrow> \<exists> stp rl. (abc_steps_l (0, args) ap stp) = (length ap, rl) \<and> abc_list_crsp (args @ [rec_exec f args]) rl"
   using recursive_compile_correct[of f args ap arity ft "[]"]
   apply(auto simp: abc_Hoare_halt_def)
   apply(rename_tac n)
   apply(rule_tac x = n in exI)
   apply(case_tac "abc_steps_l (0, args @ 0 \<up> (ft - arity)) ap n", auto)
   apply(drule_tac abc_list_crsp_steps, auto)
   apply(rule_tac list_crsp_simp2, auto)
   done
 
 lemma find_exponent_rec_exec[simp]:
   assumes a: "args @ [rec_exec f args] = lm @ 0 \<up> n"
     and b: "length args < length lm"
   shows "\<exists>m. lm = args @ rec_exec f args # 0 \<up> m"
   using assms
   apply(cases n, simp)
    apply(rule_tac x = 0 in exI, simp)
   apply(drule_tac length_equal, simp)
   done
 
 lemma find_exponent_complex[simp]: 
   "\<lbrakk>args @ [rec_exec f args] = lm @ 0 \<up> n; \<not> length args < length lm\<rbrakk>
   \<Longrightarrow> \<exists>m. (lm @ 0 \<up> (length args - length lm) @ [Suc 0])[length args := 0] =
   args @ rec_exec f args # 0 \<up> m"
   apply(cases n, simp_all add: exp_suc list_update_append list_update.simps del: replicate_Suc)
    apply(subgoal_tac "length args = Suc (length lm)", simp)
     apply(rule_tac x = "Suc (Suc 0)" in exI, simp)
    apply(drule_tac length_equal, simp, auto)
   done
 
 lemma compile_append_dummy_correct: 
   assumes compile: "rec_ci f = (ap, ary, fp)"
     and termi: "terminate f args"
-  shows "{\<lambda> nl. nl = args} (ap [+] dummy_abc (length args)) {\<lambda> nl. (\<exists> m. nl = args @ rec_exec f args # 0\<up>m)}"
+  shows "\<lbrace>\<lambda> nl. nl = args\<rbrace> (ap [+] dummy_abc (length args)) \<lbrace>\<lambda> nl. (\<exists> m. nl = args @ rec_exec f args # 0\<up>m)\<rbrace>"
 proof(rule_tac abc_Hoare_plus_halt)
-  show "{\<lambda>nl. nl = args} ap {\<lambda> nl. abc_list_crsp (args @ [rec_exec f args]) nl}"
+  show "\<lbrace>\<lambda>nl. nl = args\<rbrace> ap \<lbrace>\<lambda> nl. abc_list_crsp (args @ [rec_exec f args]) nl\<rbrace>"
     using compile termi recursive_compile_correct_norm'[of f ap ary fp args]
     apply(auto simp: abc_Hoare_halt_def)
     by (metis abc_final.simps abc_holds_for.simps)
 next
-  show "{abc_list_crsp (args @ [rec_exec f args])} dummy_abc (length args) 
-    {\<lambda>nl. \<exists>m. nl = args @ rec_exec f args # 0 \<up> m}"
+  show "\<lbrace>abc_list_crsp (args @ [rec_exec f args])\<rbrace> dummy_abc (length args) 
+    \<lbrace>\<lambda>nl. \<exists>m. nl = args @ rec_exec f args # 0 \<up> m\<rbrace>"
     apply(auto simp: dummy_abc_def abc_Hoare_halt_def)
     apply(rule_tac x = 3 in exI)
     by(force simp: abc_steps_l.simps abc_list_crsp_def abc_step_l.simps numeral_3_eq_3 abc_fetch.simps
         abc_lm_v.simps nth_append abc_lm_s.simps)
 qed
 
 lemma cn_merge_gs_split: 
   "\<lbrakk>i < length gs; rec_ci (gs!i) = (ga, gb, gc)\<rbrakk> \<Longrightarrow> 
   cn_merge_gs (map rec_ci gs) p =  cn_merge_gs (map rec_ci (take i gs)) p [+] (ga [+] 
        mv_box gb (p + i)) [+]  cn_merge_gs (map rec_ci (drop (Suc i) gs)) (p + Suc i)"
 proof(induct i arbitrary: gs p)
   case 0
   then show ?case by(cases gs; simp)
 next
   case (Suc i)
   then show ?case 
     by(cases gs, simp, cases "rec_ci (hd gs)", 
         simp add: abc_comp_commute[THEN sym])
 qed
 
 lemma cn_unhalt_case:
   assumes compile1: "rec_ci (Cn n f gs) = (ap, ar, ft) \<and> length args = ar"
     and g: "i < length gs"
     and compile2: "rec_ci (gs!i) = (gap, gar, gft) \<and> gar = length args"
-    and g_unhalt: "\<And> anything. {\<lambda> nl. nl = args @ 0\<up>(gft - gar) @ anything} gap \<up>"
+    and g_unhalt: "\<And> anything. \<lbrace>\<lambda> nl. nl = args @ 0\<up>(gft - gar) @ anything\<rbrace> gap \<up>"
     and g_ind: "\<And> apj arj ftj j anything. \<lbrakk>j < i; rec_ci (gs!j) = (apj, arj, ftj)\<rbrakk> 
-  \<Longrightarrow> {\<lambda> nl. nl = args @ 0\<up>(ftj - arj) @ anything} apj {\<lambda> nl. nl = args @ rec_exec (gs!j) args # 0\<up>(ftj - Suc arj) @ anything}"
+  \<Longrightarrow> \<lbrace>\<lambda> nl. nl = args @ 0\<up>(ftj - arj) @ anything\<rbrace> apj \<lbrace>\<lambda> nl. nl = args @ rec_exec (gs!j) args # 0\<up>(ftj - Suc arj) @ anything\<rbrace>"
     and all_termi: "\<forall> j<i. terminate (gs!j) args"
-  shows "{\<lambda> nl. nl = args @ 0\<up>(ft - ar) @ anything} ap \<up>"
+  shows "\<lbrace>\<lambda> nl. nl = args @ 0\<up>(ft - ar) @ anything\<rbrace> ap \<up>"
   using compile1
   apply(cases "rec_ci f", auto simp: rec_ci.simps abc_comp_commute)
 proof(rule_tac abc_Hoare_plus_unhalt1)
   fix fap far fft
   let ?ft = "max (Suc (length args)) (Max (insert fft ((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs)))"
   let ?Q = "\<lambda>nl. nl = args @ 0\<up> (?ft - length args) @ map (\<lambda>i. rec_exec i args) (take i gs) @ 
     0\<up>(length gs - i) @ 0\<up> Suc (length args) @ anything"
   have "cn_merge_gs (map rec_ci gs) ?ft = 
     cn_merge_gs (map rec_ci (take i gs)) ?ft [+] (gap [+] 
     mv_box gar (?ft + i)) [+]  cn_merge_gs (map rec_ci (drop (Suc i) gs)) (?ft + Suc i)"
     using g compile2 cn_merge_gs_split by simp
-  thus "{\<lambda>nl. nl = args @ 0 # 0 \<up> (?ft + length gs) @ anything} (cn_merge_gs (map rec_ci gs) ?ft) \<up>"
+  thus "\<lbrace>\<lambda>nl. nl = args @ 0 # 0 \<up> (?ft + length gs) @ anything\<rbrace> (cn_merge_gs (map rec_ci gs) ?ft) \<up>"
   proof(simp, rule_tac abc_Hoare_plus_unhalt1, rule_tac abc_Hoare_plus_unhalt2, 
       rule_tac abc_Hoare_plus_unhalt1)
     let ?Q_tmp = "\<lambda>nl. nl = args @ 0\<up> (gft - gar) @ 0\<up>(?ft - (length args) - (gft -gar)) @ map (\<lambda>i. rec_exec i args) (take i gs) @ 
       0\<up>(length gs - i) @ 0\<up> Suc (length args) @ anything"
-    have a: "{?Q_tmp} gap \<up>"
+    have a: "\<lbrace>?Q_tmp\<rbrace> gap \<up>"
       using g_unhalt[of "0 \<up> (?ft - (length args) - (gft - gar)) @
         map (\<lambda>i. rec_exec i args) (take i gs) @ 0 \<up> (length gs - i) @ 0 \<up> Suc (length args) @ anything"]
       by simp
     moreover have "?ft \<ge> gft"
       using g compile2
       apply(rule_tac max.coboundedI2, rule_tac Max_ge, simp, rule_tac insertI2)
       apply(rule_tac  x = "rec_ci (gs ! i)" in image_eqI, simp)
       by(rule_tac x = "gs!i"  in image_eqI, simp, simp)
     then have b:"?Q_tmp = ?Q"
       using compile2
       apply(rule_tac arg_cong)
       by(simp add: replicate_merge_anywhere)
-    thus "{?Q} gap \<up>"
+    thus "\<lbrace>?Q\<rbrace> gap \<up>"
       using a by simp
   next
-    show "{\<lambda>nl. nl = args @ 0 # 0 \<up> (?ft + length gs) @ anything} 
+    show "\<lbrace>\<lambda>nl. nl = args @ 0 # 0 \<up> (?ft + length gs) @ anything\<rbrace> 
       cn_merge_gs (map rec_ci (take i gs)) ?ft
-       {\<lambda>nl. nl = args @ 0 \<up> (?ft - length args) @
-      map (\<lambda>i. rec_exec i args) (take i gs) @ 0 \<up> (length gs - i) @ 0 \<up> Suc (length args) @ anything}"
+       \<lbrace>\<lambda>nl. nl = args @ 0 \<up> (?ft - length args) @
+      map (\<lambda>i. rec_exec i args) (take i gs) @ 0 \<up> (length gs - i) @ 0 \<up> Suc (length args) @ anything\<rbrace>"
       using all_termi
       by(rule_tac compile_cn_gs_correct', auto simp: set_conv_nth intro:g_ind)
   qed
 qed
 
 
 
 lemma mn_unhalt_case':
   assumes compile: "rec_ci f = (a, b, c)"
     and all_termi: "\<forall>i. terminate f (args @ [i]) \<and> 0 < rec_exec f (args @ [i])"
     and B: "B = [Dec (Suc (length args)) (length a + 5), Dec (Suc (length args)) (length a + 3), 
   Goto (Suc (length a)), Inc (length args), Goto 0]"
-  shows "{\<lambda>nl. nl = args @ 0 \<up> (max (Suc (length args)) c - length args) @ anything}
+  shows "\<lbrace>\<lambda>nl. nl = args @ 0 \<up> (max (Suc (length args)) c - length args) @ anything\<rbrace>
   a @ B \<up>"
 proof(rule_tac abc_Hoare_unhaltI, auto)
   fix n
   have a:  "b = Suc (length args)"
     using all_termi compile
     apply(erule_tac x = 0 in allE)
     by(auto, drule_tac param_pattern,auto)
   moreover have b: "c > b"
     using compile by(elim footprint_ge)
   ultimately have c: "max (Suc (length args)) c = c" by arith
   have "\<exists> stp > n. abc_steps_l (0, args @ 0 # 0\<up>(c - Suc (length args)) @ anything) (a @ B) stp
          = (0, args @ Suc n # 0\<up>(c - Suc (length args)) @ anything)"
     using assms a b c
   proof(rule_tac mn_loop_correct', auto)
     fix i xc
-    show "{\<lambda>nl. nl = args @ i # 0 \<up> (c - Suc (length args)) @ xc} a 
-      {\<lambda>nl. nl = args @ i # rec_exec f (args @ [i]) # 0 \<up> (c - Suc (Suc (length args))) @ xc}"
+    show "\<lbrace>\<lambda>nl. nl = args @ i # 0 \<up> (c - Suc (length args)) @ xc\<rbrace> a 
+      \<lbrace>\<lambda>nl. nl = args @ i # rec_exec f (args @ [i]) # 0 \<up> (c - Suc (Suc (length args))) @ xc\<rbrace>"
       using all_termi recursive_compile_correct[of f "args @ [i]" a b c xc] compile a
       by(simp)
   qed
   then obtain stp where d: "stp > n \<and> abc_steps_l (0, args @ 0 # 0\<up>(c - Suc (length args)) @ anything) (a @ B) stp
          = (0, args @ Suc n # 0\<up>(c - Suc (length args)) @ anything)" ..
   then obtain d where e: "stp = n + Suc d"
     by (metis add_Suc_right less_iff_Suc_add)
   obtain s nl where f: "abc_steps_l (0, args @ 0 # 0\<up>(c - Suc (length args)) @ anything) (a @ B) n = (s, nl)"
     by (metis prod.exhaust)
   have g: "s < length (a @ B)"
     using d e f
     apply(rule_tac classical, simp only: abc_steps_add)
     by(simp add: halt_steps2 leI)
   from f g show "abc_notfinal (abc_steps_l (0, args @ 0 \<up> 
     (max (Suc (length args)) c - length args) @ anything) (a @ B) n) (a @ B)"
     using c b a
     by(simp add: replicate_Suc_iff_anywhere Suc_diff_Suc del: replicate_Suc)
 qed
 
 lemma mn_unhalt_case: 
   assumes compile: "rec_ci (Mn n f) = (ap, ar, ft) \<and> length args = ar"
     and all_term: "\<forall> i. terminate f (args @ [i]) \<and> rec_exec f (args @ [i]) > 0"
-  shows "{\<lambda> nl. nl = args @ 0\<up>(ft - ar) @ anything} ap \<up> "
+  shows "\<lbrace> (\<lambda> nl. nl = args @ 0\<up>(ft - ar) @ anything) \<rbrace> ap \<up> "
   using assms
   apply(cases "rec_ci f", auto simp: rec_ci.simps abc_comp_commute)
   by(rule_tac mn_unhalt_case', simp_all)
 
+section \<open>Compilers composed: Compiling Recursive Functions into Turing Machines\<close>
+
 fun tm_of_rec :: "recf \<Rightarrow> instr list"
   where "tm_of_rec recf = (let (ap, k, fp) = rec_ci recf in
                          let tp = tm_of (ap [+] dummy_abc k) in 
-                           tp @ (shift (mopup k) (length tp div 2)))"
+                           tp @ (shift (mopup_n_tm k) (length tp div 2)))"
 
 lemma recursive_compile_to_tm_correct1: 
   assumes  compile: "rec_ci recf = (ap, ary, fp)"
     and termi: " terminate recf args"
     and tp: "tp = tm_of (ap [+] dummy_abc (length args))"
   shows "\<exists> stp m l. steps0 (Suc 0, Bk # Bk # ires, <args> @ Bk\<up>rn)
-  (tp @ shift (mopup (length args)) (length tp div 2)) stp = (0, Bk\<up>m @ Bk # Bk # ires, Oc\<up>Suc (rec_exec recf args) @ Bk\<up>l)"
+  (tp @ shift (mopup_n_tm (length args)) (length tp div 2)) stp = (0, Bk\<up>m @ Bk # Bk # ires, Oc\<up>Suc (rec_exec recf args) @ Bk\<up>l)"
 proof -
-  have "{\<lambda>nl. nl = args} ap [+] dummy_abc (length args) {\<lambda>nl. \<exists>m. nl = args @ rec_exec recf args # 0 \<up> m}"
+  have "\<lbrace>\<lambda>nl. nl = args\<rbrace> ap [+] dummy_abc (length args) \<lbrace>\<lambda>nl. \<exists>m. nl = args @ rec_exec recf args # 0 \<up> m\<rbrace>"
     using compile termi compile
     by(rule_tac compile_append_dummy_correct, auto)
   then obtain stp m where h: "abc_steps_l (0, args) (ap [+] dummy_abc (length args)) stp = 
     (length (ap [+] dummy_abc (length args)), args @ rec_exec recf args # 0\<up>m) "
     apply(simp add: abc_Hoare_halt_def, auto)
     apply(rename_tac n)
     by(case_tac "abc_steps_l (0, args) (ap [+] dummy_abc (length args)) n", auto)
   thus "?thesis"
     using assms tp compile_correct_halt[OF refl refl _ h _ _ refl]
     by(auto simp: crsp.simps start_of.simps abc_lm_v.simps)
 qed
 
 lemma recursive_compile_to_tm_correct2: 
   assumes termi: " terminate recf args"
   shows "\<exists> stp m l. steps0 (Suc 0, [Bk, Bk], <args>) (tm_of_rec recf) stp = 
                      (0, Bk\<up>Suc (Suc m), Oc\<up>Suc (rec_exec recf args) @ Bk\<up>l)"
-proof(cases "rec_ci recf", simp add: tm_of_rec.simps)
+proof(cases "rec_ci recf", simp )
   fix ap ar fp
   assume "rec_ci recf = (ap, ar, fp)"
   thus "\<exists>stp m l. steps0 (Suc 0, [Bk, Bk], <args>) 
-    (tm_of (ap [+] dummy_abc ar) @ shift (mopup ar) (sum_list (layout_of (ap [+] dummy_abc ar)))) stp =
+    (tm_of (ap [+] dummy_abc ar) @ shift (mopup_n_tm ar) (sum_list (layout_of (ap [+] dummy_abc ar)))) stp =
     (0, Bk # Bk # Bk \<up> m, Oc # Oc \<up> rec_exec recf args @ Bk \<up> l)"
     using recursive_compile_to_tm_correct1[of recf ap ar fp args "tm_of (ap [+] dummy_abc (length args))" "[]" 0]
       assms param_pattern[of recf args ap ar fp]
     by(simp add: replicate_Suc[THEN sym] replicate_Suc_iff_anywhere del: replicate_Suc, 
         simp add: exp_suc del: replicate_Suc)
 qed
 
 lemma recursive_compile_to_tm_correct3: 
   assumes termi: "terminate recf args"
-  shows "{\<lambda> tp. tp =([Bk, Bk], <args>)} (tm_of_rec recf) 
-         {\<lambda> tp. \<exists> k l. tp = (Bk\<up> k, <rec_exec recf args> @ Bk \<up> l)}"
+  shows "\<lbrace>\<lambda> tp. tp =([Bk, Bk], <args>)\<rbrace> (tm_of_rec recf) 
+         \<lbrace>\<lambda> tp. \<exists> k l. tp = (Bk\<up> k, <rec_exec recf args> @ Bk \<up> l)\<rbrace>"
   using recursive_compile_to_tm_correct2[OF assms]
   apply(auto simp add: Hoare_halt_def ) apply(rename_tac stp M l)
   apply(rule_tac x = stp in exI)
   apply(auto simp add: tape_of_nat_def)
   apply(rule_tac x = "Suc (Suc M)" in exI)
   apply(simp)
   done 
 
+subsection \<open>Appending the mopup TM\<close>
+
 lemma list_all_suc_many[simp]:
   "list_all (\<lambda>(acn, s). s \<le> Suc (Suc (Suc (Suc (Suc (Suc (2 * n))))))) xs \<Longrightarrow>
   list_all (\<lambda>(acn, s). s \<le> Suc (Suc (Suc (Suc (Suc (Suc (Suc (Suc (2 * n))))))))) xs"
 proof(induct xs)
   case (Cons a xs)
   then show ?case by(cases a, simp)
 qed simp
 
 
 lemma shift_append: "shift (xs @ ys) n = shift xs n @ shift ys n"
   apply(simp add: shift.simps)
   done
 
-lemma length_shift_mopup[simp]: "length (shift (mopup n) ss) = 4 * n + 12"
-  apply(auto simp: mopup.simps shift_append mopup_b_def)
+lemma length_shift_mopup[simp]: "length (shift (mopup_n_tm n) ss) = 4 * n + 12"
+  apply(auto simp: mopup_n_tm.simps shift_append mopup_b_def)
   done
 
 lemma length_tm_even[intro]: "length (tm_of ap) mod 2 = 0"
   apply(simp add: tm_of.simps)
   done
 
 lemma tms_of_at_index[simp]: "k < length ap \<Longrightarrow> tms_of ap ! k  = 
  ci (layout_of ap) (start_of (layout_of ap) k) (ap ! k)"
   apply(simp add: tms_of.simps tpairs_of.simps)
   done
 
 lemma start_of_suc_inc:
   "\<lbrakk>k < length ap; ap ! k = Inc n\<rbrakk> \<Longrightarrow> start_of (layout_of ap) (Suc k) =
                         start_of (layout_of ap) k + 2 * n + 9"
   apply(rule_tac start_of_Suc1, auto simp: abc_fetch.simps)
   done
 
 lemma start_of_suc_dec:
   "\<lbrakk>k < length ap; ap ! k = (Dec n e)\<rbrakk> \<Longrightarrow> start_of (layout_of ap) (Suc k) =
                         start_of (layout_of ap) k + 2 * n + 16"
   apply(rule_tac start_of_Suc2, auto simp: abc_fetch.simps)
   done
 
 lemma inc_state_all_le:
   "\<lbrakk>k < length ap; ap ! k = Inc n; 
        (a, b) \<in> set (shift (shift tinc_b (2 * n)) 
                             (start_of (layout_of ap) k - Suc 0))\<rbrakk>
        \<Longrightarrow> b \<le> start_of (layout_of ap) (length ap)"
   apply(subgoal_tac "b \<le> start_of (layout_of ap) (Suc k)")
    apply(subgoal_tac "start_of (layout_of ap) (Suc k) \<le> start_of (layout_of ap) (length ap) ")
     apply(arith)
    apply(cases "Suc k = length ap", simp)
    apply(rule_tac start_of_less, simp)
   apply(auto simp: tinc_b_def shift.simps start_of_suc_inc length_of.simps )
   done
 
 lemma findnth_le[elim]: 
   "(a, b) \<in> set (shift (findnth n) (start_of (layout_of ap) k - Suc 0))
   \<Longrightarrow> b \<le> Suc (start_of (layout_of ap) k + 2 * n)"
   apply(induct n, force simp add: shift.simps)
   apply(simp add: shift_append, auto)
   apply(auto simp: shift.simps)
   done
 
 lemma findnth_state_all_le1:
   "\<lbrakk>k < length ap; ap ! k = Inc n;
   (a, b) \<in> 
   set (shift (findnth n) (start_of (layout_of ap) k - Suc 0))\<rbrakk> 
   \<Longrightarrow> b \<le> start_of (layout_of ap) (length ap)"
   apply(subgoal_tac "b \<le> start_of (layout_of ap) (Suc k)")
    apply(subgoal_tac "start_of (layout_of ap) (Suc k) \<le> start_of (layout_of ap) (length ap) ")
     apply(arith)
    apply(cases "Suc k = length ap", simp)
    apply(rule_tac start_of_less, simp)
   apply(subgoal_tac "b \<le> start_of (layout_of ap) k + 2*n + 1 \<and> 
      start_of (layout_of ap) k + 2*n + 1 \<le>  start_of (layout_of ap) (Suc k)", auto)
   apply(auto simp: tinc_b_def shift.simps length_of.simps  start_of_suc_inc)
   done
 
 lemma start_of_eq: "length ap < as \<Longrightarrow> start_of (layout_of ap) as = start_of (layout_of ap) (length ap)"
 proof(induct as)
   case (Suc as)
   then show ?case 
     apply(cases "length ap < as", simp add: start_of.simps)
     apply(subgoal_tac "as = length ap")
      apply(simp add: start_of.simps)
     apply arith
     done
 qed simp
 
 lemma start_of_all_le: "start_of (layout_of ap) as \<le> start_of (layout_of ap) (length ap)"
   apply(subgoal_tac "as > length ap \<or> as = length ap \<or> as < length ap", 
       auto simp: start_of_eq start_of_less)
   done
 
 lemma findnth_state_all_le2: 
   "\<lbrakk>k < length ap; 
   ap ! k = Dec n e;
   (a, b) \<in> set (shift (findnth n) (start_of (layout_of ap) k - Suc 0))\<rbrakk>
   \<Longrightarrow> b \<le> start_of (layout_of ap) (length ap)"
   apply(subgoal_tac "b \<le> start_of (layout_of ap) k + 2*n + 1 \<and> 
      start_of (layout_of ap) k + 2*n + 1 \<le>  start_of (layout_of ap) (Suc k) \<and>
       start_of (layout_of ap) (Suc k) \<le> start_of (layout_of ap) (length ap)", auto)
    apply(subgoal_tac "start_of (layout_of ap) (Suc k) = 
   start_of  (layout_of ap)  k + 2*n + 16", simp)
    apply(simp add: start_of_suc_dec)
   apply(rule_tac start_of_all_le)
   done
 
 lemma dec_state_all_le[simp]:
   "\<lbrakk>k < length ap; ap ! k = Dec n e; 
   (a, b) \<in> set (shift (shift tdec_b (2 * n))
   (start_of (layout_of ap) k - Suc 0))\<rbrakk>
        \<Longrightarrow> b \<le> start_of (layout_of ap) (length ap)"
   apply(subgoal_tac "2*n + start_of (layout_of ap) k + 16 \<le> start_of (layout_of ap) (length ap) \<and> start_of (layout_of ap) k > 0")
    prefer 2
    apply(subgoal_tac "start_of (layout_of ap) (Suc k) = start_of (layout_of ap) k + 2*n + 16
                  \<and> start_of (layout_of ap) (Suc k) \<le> start_of (layout_of ap) (length ap)")
     apply(simp, rule_tac conjI)
     apply(simp add: start_of_suc_dec)
    apply(rule_tac start_of_all_le)
   apply(auto simp: tdec_b_def shift.simps)
   done
 
 lemma tms_any_less: 
   "\<lbrakk>k < length ap; (a, b) \<in> set (tms_of ap ! k)\<rbrakk> \<Longrightarrow> 
   b \<le> start_of (layout_of ap) (length ap)"
   apply(cases "ap!k", auto simp: tms_of.simps tpairs_of.simps ci.simps shift_append adjust.simps)
       apply(erule_tac findnth_state_all_le1, simp_all)
      apply(erule_tac inc_state_all_le, simp_all)
     apply(erule_tac findnth_state_all_le2, simp_all)
    apply(rule_tac start_of_all_le)
   apply(rule_tac start_of_all_le)
   done
 
 lemma concat_in: "i < length (concat xs) \<Longrightarrow> 
   \<exists>k < length xs. concat xs ! i \<in> set (xs ! k)"
 proof(induct xs rule: rev_induct)
   case (snoc x xs)
   then show ?case
     apply(cases "i < length (concat xs)", simp)
      apply(erule_tac exE, rule_tac x = k in exI)
      apply(simp add: nth_append)
     apply(rule_tac x = "length xs" in exI, simp)
     apply(simp add: nth_append)
     done 
 qed auto
 
 declare length_concat[simp]
 
 lemma in_tms: "i < length (tm_of ap) \<Longrightarrow> \<exists> k < length ap. (tm_of ap ! i) \<in> set (tms_of ap ! k)"
   apply(simp only: tm_of.simps)
   using concat_in[of i "tms_of ap"]
   apply(auto)
   done
 
 lemma all_le_start_of: "list_all (\<lambda>(acn, s). 
   s \<le> start_of (layout_of ap) (length ap)) (tm_of ap)"
   apply(simp only: list_all_length)
   apply(rule_tac allI, rule_tac impI)
   apply(drule_tac in_tms, auto elim: tms_any_less)
   done
 
 lemma length_ci: 
   "\<lbrakk>k < length ap; length (ci ly y (ap ! k)) = 2 * qa\<rbrakk>
       \<Longrightarrow> layout_of ap ! k = qa"
   apply(cases "ap ! k")
     apply(auto simp: layout_of.simps ci.simps 
       length_of.simps tinc_b_def tdec_b_def length_findnth adjust.simps)
   done
 
 lemma ci_even[intro]: "length (ci ly y i) mod 2 = 0"
   apply(cases i, auto simp: ci.simps length_findnth
       tinc_b_def adjust.simps tdec_b_def)
   done
 
 lemma sum_list_ci_even[intro]: "sum_list (map (length \<circ> (\<lambda>(x, y). ci ly x y)) zs) mod 2 = 0"
 proof(induct zs rule: rev_induct)
   case (snoc x xs)
   then show ?case 
     apply(cases x, simp)
     apply(subgoal_tac "length (ci ly (fst x) (snd x)) mod 2 = 0")
      apply(auto)
     done
 qed (simp)
 
 lemma zip_pre:
   "(length ys) \<le> length ap \<Longrightarrow>
   zip ys ap = zip ys (take (length ys) (ap::'a list))"
 proof(induct ys arbitrary: ap)
   case (Cons a ys)
   from Cons(2) have z:"ap = aa # list \<Longrightarrow> zip (a # ys) ap = zip (a # ys) (take (length (a # ys)) ap)"
     for aa list using Cons(1)[of list] by simp
   thus ?case by (cases ap;simp)
 qed simp
 
 lemma length_start_of_tm: "start_of (layout_of ap) (length ap) = Suc (length (tm_of ap)  div 2)"
   using tpa_states[of "tm_of ap"  "length ap" ap]
   by(simp add: tm_of.simps)
 
 lemma list_all_add_6E[elim]: "list_all (\<lambda>(acn, s). s \<le> Suc q) xs
         \<Longrightarrow> list_all (\<lambda>(acn, s). s \<le> q + (2 * n + 6)) xs"
   by(auto simp: list_all_length)
 
 lemma mopup_b_12[simp]: "length mopup_b = 12"
   by(simp add: mopup_b_def)
 
 lemma mp_up_all_le: "list_all  (\<lambda>(acn, s). s \<le> q + (2 * n + 6)) 
   [(R, Suc (Suc (2 * n + q))), (R, Suc (2 * n + q)), 
-  (L, 5 + 2 * n + q), (W0, Suc (Suc (Suc (2 * n + q)))), (R, 4 + 2 * n + q),
-  (W0, Suc (Suc (Suc (2 * n + q)))), (R, Suc (Suc (2 * n + q))),
-  (W0, Suc (Suc (Suc (2 * n + q)))), (L, 5 + 2 * n + q),
+  (L, 5 + 2 * n + q), (WB, Suc (Suc (Suc (2 * n + q)))), (R, 4 + 2 * n + q),
+  (WB, Suc (Suc (Suc (2 * n + q)))), (R, Suc (Suc (2 * n + q))),
+  (WB, Suc (Suc (Suc (2 * n + q)))), (L, 5 + 2 * n + q),
   (L, 6 + 2 * n + q), (R, 0),  (L, 6 + 2 * n + q)]"
   by(auto)
 
 lemma mopup_le6[simp]: "(a, b) \<in> set (mopup_a n) \<Longrightarrow> b \<le> 2 * n + 6"
-  by(induct n, auto simp: mopup_a.simps)
+  by(induct n, auto )
 
-lemma shift_le2[simp]: "(a, b) \<in> set (shift (mopup n) x)
-  \<Longrightarrow> b \<le> (2 * x + length (mopup n)) div 2"
-  apply(auto simp: mopup.simps shift_append shift.simps)
+lemma shift_le2[simp]: "(a, b) \<in> set (shift (mopup_n_tm n) x)
+  \<Longrightarrow> b \<le> (2 * x + length (mopup_n_tm n)) div 2"
+  apply(auto simp: mopup_n_tm.simps shift_append shift.simps)
   apply(auto simp: mopup_b_def)
   done
 
-lemma mopup_ge2[intro]: " 2 \<le> x + length (mopup n)"
-  apply(simp add: mopup.simps)
+lemma mopup_ge2[intro]: " 2 \<le> x + length (mopup_n_tm n)"
+  apply(simp add: mopup_n_tm.simps)
   done
 
-lemma mopup_even[intro]: " (2 * x + length (mopup n)) mod 2 = 0"
-  by(auto simp: mopup.simps)
+lemma mopup_even[intro]: " (2 * x + length (mopup_n_tm n)) mod 2 = 0"
+  by(auto simp: mopup_n_tm.simps)
 
 lemma mopup_div_2[simp]: "b \<le> Suc x
-          \<Longrightarrow> b \<le> (2 * x + length (mopup n)) div 2"
-  by(auto simp: mopup.simps)
+          \<Longrightarrow> b \<le> (2 * x + length (mopup_n_tm n)) div 2"
+  by(auto simp: mopup_n_tm.simps)
 
-lemma wf_tm_from_abacus: assumes "tp = tm_of ap"
-  shows "tm_wf0 (tp @ shift (mopup n) (length tp div 2))"
+subsection \<open>A Turing Machine with mopup code appended is composable\<close>
+
+lemma composable_tm_from_abacus: assumes "tp = tm_of ap"
+  shows "composable_tm0 (tp @ shift (mopup_n_tm n) (length tp div 2))"
 proof -
-  have "is_even (length (mopup n))" for n using tm_wf.simps by blast
-  moreover have "(aa, ba) \<in> set (mopup n) \<Longrightarrow> ba \<le> length (mopup n) div 2" for aa ba
-    by (metis (no_types, lifting) add_cancel_left_right case_prodD tm_wf.simps wf_mopup)
-  moreover have "(\<forall>x\<in>set (tm_of ap). case x of (acn, s) \<Rightarrow> s \<le> Suc (sum_list (layout_of ap))) \<Longrightarrow>
-           (a, b) \<in> set (tm_of ap) \<Longrightarrow> b \<le> sum_list (layout_of ap) + length (mopup n) div 2"
-    for a b s
-    by (metis (no_types, lifting) add_Suc add_cancel_left_right case_prodD div_mult_mod_eq le_SucE mult_2_right not_numeral_le_zero tm_wf.simps trans_le_add1 wf_mopup)
+  have "is_even (length (mopup_n_tm n))" for n using composable_tm.simps by blast
+  moreover have "(aa, ba) \<in> set (mopup_n_tm n) \<Longrightarrow> ba \<le> length (mopup_n_tm n) div 2" for aa ba
+    by (metis (no_types, lifting) add_cancel_left_right case_prodD composable_tm.simps composable_mopup_n_tm)
+  moreover have "(\<forall>x\<in>set (tm_of ap). case x of (acn, s::nat) \<Rightarrow> s \<le> Suc (sum_list (layout_of ap))) \<Longrightarrow>
+           (a, b) \<in> set (tm_of ap) \<Longrightarrow> b \<le> sum_list (layout_of ap) + length (mopup_n_tm n) div 2"
+    for a b and s::nat
+    by (metis (no_types, lifting) add_Suc add_cancel_left_right case_prodD div_mult_mod_eq le_SucE mult_2_right
+               not_numeral_le_zero composable_tm.simps trans_le_add1 composable_mopup_n_tm)
   ultimately show ?thesis unfolding assms
-    using length_start_of_tm[of ap] all_le_start_of[of ap] tm_wf.simps 
+    using length_start_of_tm[of ap] all_le_start_of[of ap] composable_tm.simps 
     by(auto simp: List.list_all_iff shift.simps)
 qed
 
-lemma wf_tm_from_recf:
+subsection \<open>A Turing Machine with mopup code appended is composable\<close>
+
+lemma composable_tm_from_recf:
   assumes compile: "tp = tm_of_rec recf"
-  shows "tm_wf0 tp"
+  shows "composable_tm0 tp"
 proof -
   obtain a b c where "rec_ci recf = (a, b, c)"
     by (metis prod_cases3)
   thus "?thesis"
     using compile
-    using wf_tm_from_abacus[of "tm_of (a [+] dummy_abc b)" "(a [+] dummy_abc b)" b]
+    using composable_tm_from_abacus[of "tm_of (a [+] dummy_abc b)" "(a [+] dummy_abc b)" b]
     by simp
 qed
 
-end
\ No newline at end of file
+end
diff --git a/thys/Universal_Turing_Machine/SemiIdTM.thy b/thys/Universal_Turing_Machine/SemiIdTM.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/SemiIdTM.thy
@@ -0,0 +1,312 @@
+(* Title: thys/SemiIdTM.thy
+   Author: Franz Regensburger (FABR) 02/2022
+ *)
+
+section \<open>SemiId: Turing machines acting as partial identity functions\<close>
+
+theory SemiIdTM
+  imports Turing_Hoare
+begin
+
+(* Cleanup the global simpset *)
+
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+
+subsection \<open>The Turing Machine tm\_semi\_id\_eq0\<close>
+
+(* ---------------------------------------------------------- *)
+(* Machine tm_semi_id_eq0                                     *)
+(* ---------------------------------------------------------- *)
+(*
+The machine tm_semi_id_eq0
+terminates on: Oc \<up> 1 with result Oc \<up> 1, which is the numeral <0>
+
+     loops on: []      which is the empty input
+     loops on: Oc \<up> n, where n \<ge> 2
+*)
+
+text \<open>
+  If the input is @{term "Oc\<up>1"} the machine @{term "tm_semi_id_eq0"} will reach the
+  final state in a standard configuration with output identical to its input.
+  For other inputs @{term "Oc\<up>n"} with @{term "1 \<noteq> (n::nat)"} it will 
+  loop forever.
+
+  Please note that our short notation  @{term "<n::nat>"} means @{term "Oc\<up>(n+1)"}
+  where @{term "0 \<le> (n::nat)"}.
+\<close>
+
+definition tm_semi_id_eq0 :: "instr list"
+  where
+    "tm_semi_id_eq0 \<equiv> [(WB, 1), (R, 2), (L, 0), (L, 1)]"
+
+(* ------ Important properties used in subsequent theories ------ *)
+
+lemma composable_tm0_tm_semi_id_eq0[intro, simp]: "composable_tm0 tm_semi_id_eq0"
+  by (auto simp: composable_tm.simps tm_semi_id_eq0_def)
+
+lemma tm_semi_id_eq0_loops_aux: 
+  "(steps0 (1, [], [Oc, Oc]) tm_semi_id_eq0 stp = (1, [], [Oc, Oc])) \<or> 
+   (steps0 (1, [], [Oc, Oc]) tm_semi_id_eq0 stp = (2, Oc # [], [Oc]))"
+  by (induct stp) (auto simp: steps.simps step.simps tm_semi_id_eq0_def numeral_eqs_upto_12)
+
+lemma tm_semi_id_eq0_loops_aux': 
+  "(steps0 (1, [], [Oc, Oc] @ (Bk \<up> q)) tm_semi_id_eq0 stp = (1, [], [Oc,Oc] @ Bk \<up> q)) \<or> 
+   (steps0 (1, [], [Oc, Oc] @ (Bk \<up> q)) tm_semi_id_eq0 stp = (2, Oc # [], [Oc] @ (Bk \<up> q)))"
+  by (induct stp) (auto simp: steps.simps step.simps tm_semi_id_eq0_def numeral_eqs_upto_12)
+
+lemma tm_semi_id_eq0_loops_aux'': 
+  "(steps0 (1, [], [Oc, Oc] @ (Oc \<up> q) @ (Bk \<up> q)) tm_semi_id_eq0 stp = (1, [], [Oc,Oc] @ (Oc \<up> q) @ Bk \<up> q)) \<or> 
+   (steps0 (1, [], [Oc, Oc] @ (Oc \<up> q) @ (Bk \<up> q)) tm_semi_id_eq0 stp = (2, Oc # [], [Oc] @ (Oc \<up> q) @ (Bk \<up> q)))"
+  by (induct stp) (auto simp: steps.simps step.simps tm_semi_id_eq0_def numeral_eqs_upto_12)
+
+lemma tm_semi_id_eq0_loops_aux''': 
+  "(steps0 (1, [], []) tm_semi_id_eq0 stp = (1, [], [])) \<or> 
+   (steps0 (1, [], []) tm_semi_id_eq0 stp = (1, [], [Bk]))"
+  by (induct stp) (auto simp: steps.simps step.simps tm_semi_id_eq0_def numeral_eqs_upto_12)
+
+(* ------ Auxiliary properties for clarification           ------ *)
+
+lemma "<0::nat> = [Oc]" by (simp add: tape_of_nat_def)
+lemma "Oc\<up>(0+1) = [Oc]" by (simp)
+lemma "<n::nat> = Oc\<up>(n+1)" by (auto simp add: tape_of_nat_def)
+lemma "<1::nat> = [Oc, Oc]" by (simp add: tape_of_nat_def)
+
+subsubsection \<open>The machine tm\_semi\_id\_eq0 in action\<close>
+
+(* steps0 (1, [], []) tm_semi_id_eq0 n loops forever in state 1 *)
+lemma "steps0 (1, [], []) tm_semi_id_eq0 0 = (1, [], [])"   by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_eq0_def)
+lemma "steps0 (1, [], []) tm_semi_id_eq0 1 = (1, [], [Bk])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_eq0_def)
+lemma "steps0 (1, [], []) tm_semi_id_eq0 2 = (1, [], [Bk])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_eq0_def)
+lemma "steps0 (1, [], []) tm_semi_id_eq0 3 = (1, [], [Bk])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_eq0_def)
+
+(*     steps0 (1, [], [Oc]) tm_semi_id_eq0 n terminates after 2 steps with final configuration "(0, [], [Oc])" *)
+lemma "steps0 (1, [], [Oc]) tm_semi_id_eq0 0 = (1, [], [Oc])" by (simp add: step.simps steps.simps tm_semi_id_eq0_def)
+lemma "steps0 (1, [], [Oc]) tm_semi_id_eq0 1 = (2, [Oc], [])" by (simp add: step.simps steps.simps tm_semi_id_eq0_def)
+lemma "steps0 (1, [], [Oc]) tm_semi_id_eq0 2 = (0, [], [Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_eq0_def)
+
+(* steps0 (1, [], [Oc, Oc]) tm_semi_id_eq0 loops forever *)
+lemma "steps0 (1, [], [Oc, Oc]) tm_semi_id_eq0 0 = (1, [], [Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_eq0_def)
+lemma "steps0 (1, [], [Oc, Oc]) tm_semi_id_eq0 1 = (2, [Oc], [Oc])"   by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_eq0_def)
+lemma "steps0 (1, [], [Oc, Oc]) tm_semi_id_eq0 2 = (1, [], [Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_eq0_def)
+lemma "steps0 (1, [], [Oc, Oc]) tm_semi_id_eq0 3 = (2, [Oc], [Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_eq0_def)
+lemma "steps0 (1, [], [Oc, Oc]) tm_semi_id_eq0 4 = (1, [], [Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_eq0_def)
+
+subsection \<open>The Turing Machine tm\_semi\_id\_gt0\<close>
+
+(* ---------------------------------------------------------- *)
+(* Machine tm_semi_id_gt0                                     *)
+(* ---------------------------------------------------------- *)
+(*
+The machine tm_semi_id_gt0 (aka dither) has behaviour that is complementary
+to the behaviour of tm_semi_id_eq0.
+
+The machine tm_semi_id_gt0
+terminates on: Oc \<up> n  with result Oc \<up> n for 1 < n
+
+     loops on: []     , which is the empty input
+     loops on: Oc \<up> 1 , which is the numeral <0>
+*)
+
+text \<open>
+  If the input is @{term "Oc\<up>0"} or @{term "Oc\<up>1"} the machine @{term "tm_semi_id_gt0"}
+  (aka dither) will loop forever.
+  For other non-blank inputs @{term "Oc\<up>n"} with @{term  "1 < (n::nat)"} it will 
+  reach the final state in a standard configuration with output identical to its input.
+
+  Please note that our short notation  @{term "<n::nat>"} means @{term "Oc\<up>(n+1)"}
+  where @{term "0 \<le> (n::nat)"}.
+\<close>
+
+definition tm_semi_id_gt0 :: "instr list"
+  where
+    "tm_semi_id_gt0 \<equiv> [(WB, 1), (R, 2), (L, 1), (L, 0)]"
+
+(* ------ Important properties used in subsequent theories ------ *)
+
+lemma tm_semi_id_gt0[intro, simp]: "composable_tm0 tm_semi_id_gt0"
+  by (auto simp: composable_tm.simps tm_semi_id_gt0_def)
+
+lemma tm_semi_id_gt0_loops_aux: 
+  "(steps0 (1, [], [Oc]) tm_semi_id_gt0 stp = (1, [], [Oc])) \<or> 
+   (steps0 (1, [], [Oc]) tm_semi_id_gt0 stp = (2, Oc # [], []))"
+  by (induct stp) (auto simp: steps.simps step.simps tm_semi_id_gt0_def numeral_eqs_upto_12)
+
+lemma tm_semi_id_gt0_loops_aux': 
+  "(steps0 (1, [], [Oc] @ Bk \<up> n) tm_semi_id_gt0 stp = (1, [], [Oc] @ Bk \<up> n)) \<or> 
+   (steps0 (1, [], [Oc] @ Bk \<up> n) tm_semi_id_gt0 stp = (2, Oc # [], Bk \<up> n))"
+  by (induct stp) (auto simp: steps.simps step.simps tm_semi_id_gt0_def numeral_eqs_upto_12)
+
+lemma tm_semi_id_gt0_loops_aux''': 
+  "(steps0 (1, [], []) tm_semi_id_gt0 stp = (1, [], [])) \<or> 
+   (steps0 (1, [], []) tm_semi_id_gt0 stp = (1, [], [Bk]))"
+  by (induct stp) (auto simp: steps.simps step.simps tm_semi_id_gt0_def numeral_eqs_upto_12)
+
+subsubsection \<open>The machine tm\_semi\_id\_gt0 in action\<close>
+
+(* steps0 (1, [], []) tm_semi_id_gt0 n loops forever in state 1 *)
+lemma "steps0 (1, [], []) tm_semi_id_gt0 0 = (1, [], [])"   by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+lemma "steps0 (1, [], []) tm_semi_id_gt0 1 = (1, [], [Bk])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+lemma "steps0 (1, [], []) tm_semi_id_gt0 2 = (1, [], [Bk])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+lemma "steps0 (1, [], []) tm_semi_id_gt0 3 = (1, [], [Bk])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+
+(* steps0 (1, [], [Oc]) tm_semi_id_gt0 n loops forever; it dithers between states 1 and 2 *)
+lemma "steps0 (1, [], [Oc]) tm_semi_id_gt0 0 = (1, [], [Oc])" by (simp add: step.simps steps.simps tm_semi_id_gt0_def)
+lemma "steps0 (1, [], [Oc]) tm_semi_id_gt0 1 = (2, [Oc], [])" by (simp add: step.simps steps.simps tm_semi_id_gt0_def)
+lemma "steps0 (1, [], [Oc]) tm_semi_id_gt0 2 = (1, [], [Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+lemma "steps0 (1, [], [Oc]) tm_semi_id_gt0 3 = (2, [Oc], [])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+lemma "steps0 (1, [], [Oc]) tm_semi_id_gt0 4 = (1, [], [Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+
+(* steps0 (1, [], [Oc, Oc]) tm_semi_id_gt0 n terminates after 2 steps with final configuration "(0, [], [Oc, Oc])" *)
+lemma "steps0 (1, [], [Oc, Oc]) tm_semi_id_gt0 0 = (1, [], [Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+lemma "steps0 (1, [], [Oc, Oc]) tm_semi_id_gt0 1 = (2, [Oc], [Oc])"   by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+lemma "steps0 (1, [], [Oc, Oc]) tm_semi_id_gt0 2 = (0, [], [Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+lemma "steps0 (1, [], [Oc, Oc]) tm_semi_id_gt0 3 = (0, [], [Oc, Oc])" by (simp add: step.simps steps.simps numeral_eqs_upto_12 tm_semi_id_gt0_def)
+
+
+subsection \<open>Properties of the SemiId machines\<close>
+
+(*
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+*)
+
+text \<open>Using Hoare style rules is more elegant since they allow for compositional
+ reasoning. Therefore, its preferable to use them, if the program that we reason about
+ can be decomposed appropriately.\<close>
+
+subsubsection \<open>Proving properties of tm\_semi\_id\_eq0 with Hoare Rules\<close>
+
+lemma tm_semi_id_eq0_loops_Nil:
+  shows "\<lbrace>\<lambda>tap. tap = ([], [])\<rbrace> tm_semi_id_eq0 \<up>"
+  apply(rule Hoare_unhaltI)
+  using tm_semi_id_eq0_loops_aux'''
+  apply(auto simp add: numeral_eqs_upto_12 tape_of_nat_def)
+  by (metis Suc_neq_Zero is_final_eq)
+
+lemma tm_semi_id_eq0_loops:
+  shows "\<lbrace>\<lambda>tap. tap = ([], <1::nat>)\<rbrace> tm_semi_id_eq0 \<up>"
+  apply(rule Hoare_unhaltI)
+  using tm_semi_id_eq0_loops_aux
+  apply(auto simp add: numeral_eqs_upto_12 tape_of_nat_def)
+  by (metis Suc_neq_Zero is_final_eq)
+
+lemma tm_semi_id_eq0_loops':
+  shows "\<lbrace>\<lambda>tap. \<exists>l. tap = ([], [Oc, Oc] @ Bk\<up> l)\<rbrace> tm_semi_id_eq0 \<up>"
+  apply(rule Hoare_unhaltI)
+  using tm_semi_id_eq0_loops_aux'
+  apply(auto simp add: numeral_eqs_upto_12 tape_of_nat_def )
+  by (metis Suc_neq_Zero is_final_eq)
+
+lemma tm_semi_id_eq0_loops'':
+  shows "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk\<up>k, [Oc, Oc] @ Bk\<up> l)\<rbrace> tm_semi_id_eq0 \<up>"
+  apply(rule Hoare_unhaltI)
+  using tm_semi_id_eq0_loops_aux'
+  apply(auto simp add: numeral_eqs_upto_12 tape_of_nat_def)
+  by (metis is_final_del_Bks Zero_neq_Suc is_final_eq)
+
+
+
+lemma tm_semi_id_eq0_halts_aux:
+  shows "steps0 (1, Bk \<up> m, [Oc]) tm_semi_id_eq0 2 = (0, Bk \<up> m, [Oc])"
+  unfolding tm_semi_id_eq0_def
+  by (simp add: steps.simps step.simps numeral_eqs_upto_12)
+
+lemma tm_semi_id_eq0_halts_aux':
+  shows "steps0 (1, Bk \<up> m, [Oc]@Bk \<up> n) tm_semi_id_eq0 2 = (0, Bk \<up> m, [Oc]@Bk \<up> n)"
+  unfolding tm_semi_id_eq0_def
+  by (simp add: steps.simps step.simps numeral_eqs_upto_12)
+
+lemma tm_semi_id_eq0_halts:
+  shows "\<lbrace>\<lambda>tap. tap = ([], <0::nat>)\<rbrace> tm_semi_id_eq0 \<lbrace>\<lambda>tap. tap = ([], <0::nat>)\<rbrace>"
+  apply(rule Hoare_haltI)
+  using tm_semi_id_eq0_halts_aux
+  apply(auto simp add: tape_of_nat_def)
+  by (metis (full_types) holds_for.simps is_finalI  replicate_0)
+
+lemma tm_semi_id_eq0_halts':
+  shows "\<lbrace>\<lambda>tap. \<exists>l. tap = ([], [Oc] @ Bk\<up> l)\<rbrace> tm_semi_id_eq0 \<lbrace>\<lambda>tap. \<exists>l. tap = ([], [Oc] @ Bk\<up> l)\<rbrace>"
+  apply(rule Hoare_haltI)
+  using tm_semi_id_eq0_halts_aux'
+  apply(auto simp add: tape_of_nat_def)
+  by (metis (mono_tags, lifting) holds_for.simps is_finalI numeral_1_eq_Suc_0 numeral_One replicate_0)
+
+lemma tm_semi_id_eq0_halts'':
+  shows "\<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk\<up> k, [Oc] @ Bk\<up> l) \<rbrace> tm_semi_id_eq0 \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk\<up> k, [Oc] @ Bk\<up> l) \<rbrace>"
+  apply(rule Hoare_haltI)
+  using tm_semi_id_eq0_halts_aux'
+  apply(auto simp add: tape_of_nat_def)
+  by (metis (mono_tags, lifting) holds_for.simps is_finalI numeral_1_eq_Suc_0 numeral_One)
+
+subsubsection \<open>Proving properties of tm\_semi\_id\_gt0 with Hoare Rules\<close>
+
+lemma tm_semi_id_gt0_loops_Nil:
+  shows "\<lbrace>\<lambda>tap. tap = ([], [])\<rbrace> tm_semi_id_gt0 \<up>"
+  apply(rule Hoare_unhaltI)
+  using tm_semi_id_gt0_loops_aux'''
+  apply(auto simp add: numeral_eqs_upto_12 tape_of_nat_def)
+  by (metis Suc_neq_Zero is_final_eq)
+
+lemma tm_semi_id_gt0_loops:
+  shows "\<lbrace>\<lambda>tap. tap = ([], <0::nat>)\<rbrace> tm_semi_id_gt0 \<up>"
+  apply(rule Hoare_unhaltI)
+  using tm_semi_id_gt0_loops_aux
+  apply(auto simp add: numeral_eqs_upto_12 tape_of_nat_def)
+  by (metis Suc_neq_Zero is_final_eq)
+
+lemma tm_semi_id_gt0_loops':
+  shows "\<lbrace>\<lambda>tap. \<exists>l. tap = ([], [Oc] @ Bk\<up> l)\<rbrace> tm_semi_id_gt0 \<up>"
+  apply(rule Hoare_unhaltI)
+  using tm_semi_id_gt0_loops_aux'
+  apply(auto simp add: numeral_eqs_upto_12 tape_of_nat_def)
+  by (metis Suc_neq_Zero is_final_eq)
+
+lemma tm_semi_id_gt0_loops'':
+  shows "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk\<up>k, [Oc] @ Bk\<up> l)\<rbrace> tm_semi_id_gt0 \<up>"
+  apply(rule Hoare_unhaltI)
+  using tm_semi_id_gt0_loops_aux'
+  apply(auto simp add: numeral_eqs_upto_12 tape_of_nat_def)
+  by (metis is_final_del_Bks Zero_neq_Suc is_final_eq)
+
+lemma tm_semi_id_gt0_halts_aux:
+  shows "steps0 (1, Bk \<up> m, [Oc, Oc]) tm_semi_id_gt0 2 = (0, Bk \<up> m, [Oc, Oc])"
+  unfolding tm_semi_id_gt0_def
+  by (simp add: steps.simps step.simps numeral_eqs_upto_12)
+
+lemma tm_semi_id_gt0_halts_aux':
+  shows "steps0 (1, Bk \<up> m, [Oc, Oc]@Bk \<up> n) tm_semi_id_gt0 2 = (0, Bk \<up> m, [Oc, Oc]@Bk \<up> n)"
+  unfolding tm_semi_id_gt0_def
+  by (simp add: steps.simps step.simps numeral_eqs_upto_12)
+
+lemma tm_semi_id_gt0_halts:
+  shows "\<lbrace>\<lambda>tap. tap = ([], <1::nat>)\<rbrace> tm_semi_id_gt0 \<lbrace>\<lambda>tap. tap = ([], <1::nat>)\<rbrace>"
+  apply(rule Hoare_haltI)
+  using tm_semi_id_gt0_halts_aux
+  apply(auto simp add: tape_of_nat_def)
+  by (metis (full_types) empty_replicate holds_for.simps is_final_eq numeral_2_eq_2)
+
+lemma tm_semi_id_gt0_halts':
+  shows "\<lbrace>\<lambda>tap. \<exists>l. tap = ([], [Oc, Oc] @ Bk\<up> l)\<rbrace> tm_semi_id_gt0 \<lbrace>\<lambda>tap. \<exists>l. tap = ([], [Oc, Oc] @ Bk\<up> l)\<rbrace>"
+  apply(rule Hoare_haltI)
+  using tm_semi_id_gt0_halts_aux'
+  apply(auto simp add: tape_of_nat_def)
+  by (metis (mono_tags, lifting) Suc_1 holds_for.simps is_finalI numeral_1_eq_Suc_0 numeral_One replicate_0)
+
+lemma tm_semi_id_gt0_halts'':
+  shows "\<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk\<up> k, [Oc, Oc] @ Bk\<up> l)\<rbrace> tm_semi_id_gt0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk\<up> k, [Oc, Oc] @ Bk\<up> l)\<rbrace>"
+  apply(rule Hoare_haltI)
+  using tm_semi_id_gt0_halts_aux'
+  apply(auto simp add: tape_of_nat_def)
+  by (metis (mono_tags, lifting) Suc_1 holds_for.simps is_finalI numeral_1_eq_Suc_0 numeral_One)
+
+end
diff --git a/thys/Universal_Turing_Machine/SimpleGoedelEncoding.thy b/thys/Universal_Turing_Machine/SimpleGoedelEncoding.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/SimpleGoedelEncoding.thy
@@ -0,0 +1,265 @@
+(* Title: thys/SimpleGoedelEncoding.thy
+   Author: Franz Regensburger (FABR) 02/2022
+
+   - For the proof of the undecidability of the special halting problems K1 and K0
+     we need some arbitrary injective encoding from Turing machines into the
+     natural numbers.
+ *)
+
+section \<open>Halting Problems: do Turing Machines for deciding Termination exist?\<close>
+
+text \<open>In this section we will show that there cannot exist Turing Machines that are able
+to decide the termination of some other arbitrary Turing Machine.\<close>
+
+subsection \<open>A simple Gödel Encoding for Turing machines\<close>
+
+theory SimpleGoedelEncoding
+  imports
+     Turing_HaltingConditions
+    "HOL-Library.Nat_Bijection"
+begin
+
+(* -------------------------------------------------------------------------- *)
+
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+
+subsubsection \<open>Some general results on injective functions and their inversion\<close>
+
+lemma dec_is_inv_on_A:
+   "dec = (\<lambda>w. (if (\<exists>t\<in>A. enc t = w) then (THE t. t\<in>A \<and> enc t = w) else (SOME t. t \<in> A)))
+    \<Longrightarrow> dec = (\<lambda>w. (if (\<exists>t\<in>A. enc t = w) then (the_inv_into A enc) w else (SOME t. t \<in> A)))"
+  by (auto simp add: the_inv_into_def)
+
+lemma encode_decode_A_eq:
+  "\<lbrakk> inj_on (enc::'a \<Rightarrow>'b) (A::'a set);
+     (dec::'b \<Rightarrow> 'a) = (\<lambda>w. (if (\<exists>t\<in>A. enc t = w)
+                             then (THE t. t\<in>A \<and> enc t = w)
+                             else (SOME t. t \<in> A)))
+   \<rbrakk> \<Longrightarrow> \<forall>M\<in>A. dec(enc M) = M"
+proof
+  fix M
+  assume inj_enc: "inj_on enc A"
+    and dec_def: "dec = (\<lambda>w. if \<exists>t\<in>A. enc t = w then THE t. t \<in> A \<and> enc t = w else SOME t. t \<in> A)"
+    and M_in_A: "M \<in> A"
+  show "dec (enc M) = M"
+  proof -
+    from dec_def have
+      dec_def': "dec = (\<lambda>w. (if (\<exists>t\<in>A. enc t = w) then (the_inv_into A enc) w else (SOME t. t \<in> A)))"
+      by (rule dec_is_inv_on_A)
+    from M_in_A have "\<exists>t\<in>A. enc t = (enc M)" by auto
+    with M_in_A inj_enc and dec_def' show "dec (enc M) = M" by (auto simp add: the_inv_into_f_f)
+  qed
+qed
+
+lemma decode_encode_A_eq:
+  "\<lbrakk> inj_on (enc::'a \<Rightarrow>'b) (A::'a set);
+    dec = (\<lambda>w. (if (\<exists>t\<in>A. enc t = w) then (THE t. t\<in>A \<and> enc t = w) else (SOME t. t \<in> A)))\<rbrakk>
+  \<Longrightarrow> \<forall>w. w \<in> enc`A \<longrightarrow> enc(dec(w)) = w"
+proof 
+  fix w
+  assume inj_enc: "inj_on enc A"
+    and dec_def: "dec = (\<lambda>w. if \<exists>t\<in>A. enc t = w then THE t. t \<in> A \<and> enc t = w else SOME t. t \<in> A)"
+  show "w \<in> enc ` A \<longrightarrow> enc (dec w) = w"
+  proof
+    assume "w \<in> enc ` A"
+    from dec_def have
+      dec_def': "dec = (\<lambda>w. (if (\<exists>t\<in>A. enc t = w) then (the_inv_into A enc) w else (SOME t. t \<in> A)))"
+      by (rule dec_is_inv_on_A)
+    with \<open>w \<in> enc ` A\<close> and inj_enc
+    show "enc (dec w) = w" 
+      by (auto simp add: the_inv_into_f_f)
+  qed
+qed
+
+lemma dec_in_A:
+  "\<lbrakk>inj_on (enc::'a \<Rightarrow>'b) (A::'a set);
+   dec = (\<lambda>w. if \<exists>t\<in>A. enc t = w then THE t. t \<in> A \<and> enc t = w else SOME t. t \<in> A);
+   A \<noteq> {} \<rbrakk>
+  \<Longrightarrow> \<forall>w. dec w \<in> A"
+proof
+  fix w
+  assume inj_enc: "inj_on enc A"
+    and dec_def: "dec = (\<lambda>w. if \<exists>t\<in>A. enc t = w then THE t. t \<in> A \<and> enc t = w else SOME t. t \<in> A)"
+    and not_empty_A: "A \<noteq> {}"
+  show "dec w \<in> A"
+  proof (cases "\<exists>t\<in>A. enc t = w")
+    assume "\<exists>t\<in>A. enc t = w"
+    from dec_def have
+      dec_def': "dec = (\<lambda>w. (if (\<exists>t\<in>A. enc t = w) then (the_inv_into A enc) w else (SOME t. t \<in> A)))"
+      by (rule dec_is_inv_on_A)
+    with \<open>\<exists>t\<in>A. enc t = w\<close> inj_enc show ?thesis by (auto simp add: the_inv_into_f_f)
+  next
+    assume "\<not>(\<exists>t\<in>A. enc t = w)"
+    from dec_def have
+      dec_def': "dec = (\<lambda>w. (if (\<exists>t\<in>A. enc t = w) then (the_inv_into A enc) w else (SOME t. t \<in> A)))"
+      by (rule dec_is_inv_on_A)
+    with \<open>\<not>(\<exists>t\<in>A. enc t = w)\<close> have "dec w = (SOME t. t \<in> A)" by auto
+    from not_empty_A have "\<exists>x. x \<in> A" by auto
+    then have "(SOME t. t \<in> A) \<in> A" by (rule someI_ex)
+    with \<open>dec w = (SOME t. t \<in> A)\<close> show ?thesis by auto
+  qed
+qed
+
+subsubsection \<open>An injective encoding of Turing Machines into the natural number\<close>
+
+text \<open>
+  We define an injective encoding function from Turing machines to natural numbers.
+  This encoding function is only used for the proof of the undecidability of
+  the special halting problem K where we use a locale that postulates the existence of
+  some injective encoding of the Turing machines into the natural numbers.
+\<close>
+
+fun tm_to_nat_list ::  "tprog0 \<Rightarrow> nat list"
+  where
+    "tm_to_nat_list []              = []" |
+    "tm_to_nat_list ((WB  ,s) # is) = 0 # s #  tm_to_nat_list is" |
+    "tm_to_nat_list ((WO  ,s) # is) = 1 # s #  tm_to_nat_list is" |
+    "tm_to_nat_list ((L   ,s) # is) = 2 # s #  tm_to_nat_list is" |
+    "tm_to_nat_list ((R   ,s) # is) = 3 # s #  tm_to_nat_list is" |
+    "tm_to_nat_list ((Nop ,s) # is) = 4 # s #  tm_to_nat_list is"
+
+lemma prefix_tm_to_nat_list_cons:
+ "\<exists>u v. tm_to_nat_list (x#xs) = u # v # tm_to_nat_list xs"
+proof (cases x)
+  case (Pair a b)
+  then show ?thesis by (cases a)(auto)
+qed
+
+lemma tm_to_nat_list_cons_is_not_nil: "tm_to_nat_list (x#xs) \<noteq> tm_to_nat_list []"
+proof
+  assume "tm_to_nat_list (x # xs) = tm_to_nat_list []"
+  moreover have "\<exists>u v. tm_to_nat_list (x#xs) = u # v # tm_to_nat_list xs"
+    by (rule prefix_tm_to_nat_list_cons)
+  ultimately show False by auto
+qed
+
+lemma inj_in_fst_arg_tm_to_nat_list:
+ "tm_to_nat_list (x # xs) = tm_to_nat_list (y # xs) \<Longrightarrow> x = y"
+proof (cases x, cases y)
+  case (Pair a b)
+  fix a1 s1 a2 s2
+  assume "tm_to_nat_list (x # xs) = tm_to_nat_list (y # xs)"
+  and "x = (a1, s1)" and "y = (a2, s2)"
+  then show ?thesis by  (cases a1; cases a2)(auto)
+qed
+
+lemma inj_tm_to_nat_list: "tm_to_nat_list xs = tm_to_nat_list ys \<longrightarrow> xs = ys"
+proof (induct xs ys rule:  list_induct2')
+  case 1
+  then show ?case by blast
+next
+  case (2 x xs)
+  then show ?case
+  proof
+    assume "tm_to_nat_list (x # xs) = tm_to_nat_list []"
+    then have False using tm_to_nat_list_cons_is_not_nil by auto
+    then show "x # xs = []" by auto
+  qed
+next
+  case (3 y ys)
+  then show ?case
+  proof
+    assume "tm_to_nat_list [] = tm_to_nat_list (y # ys)"
+    then have "tm_to_nat_list (y # ys) = tm_to_nat_list []" by (rule sym)
+    then have False using tm_to_nat_list_cons_is_not_nil by auto
+    then show "[] = y # ys" by auto
+  qed
+next
+  case (4 x xs y ys)
+  then have IH: "tm_to_nat_list xs = tm_to_nat_list ys \<longrightarrow> xs = ys" .
+  show ?case
+  proof
+    assume A: "tm_to_nat_list (x # xs) = tm_to_nat_list (y # ys)"
+    have "\<exists>u v. tm_to_nat_list (x#xs) = u # v # tm_to_nat_list xs"
+      by (rule prefix_tm_to_nat_list_cons)
+    then obtain u1 v1 where w_u1_v1: "tm_to_nat_list (x#xs) = u1 # v1 # tm_to_nat_list xs"
+      by blast
+    have "\<exists>u v. tm_to_nat_list (y#ys) = u # v # tm_to_nat_list ys"
+      by (rule prefix_tm_to_nat_list_cons)
+    then obtain u2 v2 where w_u2_v2: "tm_to_nat_list (y#ys) = u2 # v2 # tm_to_nat_list ys"
+      by blast
+    from A and w_u1_v1 and w_u2_v2 have "tm_to_nat_list xs = tm_to_nat_list ys" by auto
+    with IH have "xs = ys" by auto
+    moreover with A have "x=y" using inj_in_fst_arg_tm_to_nat_list by auto
+    ultimately show "x # xs = y # ys" by auto
+  qed
+qed
+
+definition tm_to_nat ::  "tprog0 \<Rightarrow> nat"
+  where "tm_to_nat = (list_encode \<circ> tm_to_nat_list)"
+
+theorem inj_tm_to_nat: "inj tm_to_nat"
+  unfolding tm_to_nat_def
+proof  (rule inj_compose)
+  show "inj list_encode" by (rule inj_list_encode)
+next
+  show "inj tm_to_nat_list"
+    unfolding inj_def by (auto simp add: inj_tm_to_nat_list)
+qed
+
+(* --- For demo purposes in classes we provide some inverse functions, explicitly --- *)
+
+(* Note:
+ * For cases where we argument list cannot be the image of nat_list_to_tm
+ * we choose some arbitrary but fixed value.
+ * Here we choose [(Nop, 0)].
+ * However, any instruction list would do the job, we.g. [].
+ *)
+
+fun nat_list_to_tm      :: "nat list \<Rightarrow> tprog0"
+  where
+    "nat_list_to_tm  [] =  []"
+  | "nat_list_to_tm  [ac] = [(Nop, 0)]"
+  | "nat_list_to_tm  (ac # s # ns) = (
+           if ac < 5
+           then ([WB,WO,L,R,Nop]!ac ,s) # nat_list_to_tm ns
+           else [(Nop, 0)])"
+
+(* -- *)
+
+lemma  nat_list_to_tm_is_inv_of_tm_to_nat_list: "nat_list_to_tm (tm_to_nat_list ns) = ns"
+proof (induct ns)
+  case Nil
+  then show ?case by auto
+next
+  case (Cons a ns)
+  fix instr ns
+  assume IV: "nat_list_to_tm (tm_to_nat_list ns) = ns"
+  show "nat_list_to_tm (tm_to_nat_list (instr # ns)) = instr # ns"
+  proof (cases instr)
+    case (Pair ac s)
+    then have "instr = (ac, s)" .
+    with Pair IV show "nat_list_to_tm (tm_to_nat_list (instr # ns)) = instr # ns"
+      by (cases ac; cases s) auto
+  qed
+qed
+
+definition nat_to_tm ::  "nat \<Rightarrow> tprog0"
+  where "nat_to_tm = (nat_list_to_tm \<circ> list_decode)"
+
+(* The function nat_to_tm is an explicit witness for the function ct2,
+   which we define by non-constructive logic in theory HaltingProblems_K_H
+   by
+
+    definition c2t :: "nat \<Rightarrow> instr list"
+      where
+        "c2t = (\<lambda>n. if (\<exists>p. t2c p = n)
+                   then (THE  p. t2c p = n)
+                   else (SOME p. True) )"  <-- some arbitrary but fixed value
+*)    
+   
+(* Compare the next lemma to
+    lemma c2t_comp_t2c_eq: "c2t (t2c p) = p"
+   in theory HaltingProblems_K_H
+ *)
+
+lemma nat_to_tm_is_inv_of_tm_to_nat: "nat_to_tm (tm_to_nat tm) = tm"
+  by (simp add: nat_list_to_tm_is_inv_of_tm_to_nat_list nat_to_tm_def tm_to_nat_def)
+
+end
diff --git a/thys/Universal_Turing_Machine/StrongCopyTM.thy b/thys/Universal_Turing_Machine/StrongCopyTM.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/StrongCopyTM.thy
@@ -0,0 +1,5696 @@
+(* Title: thys/StrongCopyTM.thy
+   Author: Franz Regensburger (FABR) 02/2022
+ *)
+
+subsubsection \<open>A Turing machine that duplicates its input iff the input is a single numeral\<close>
+
+theory StrongCopyTM
+  imports
+    WeakCopyTM
+begin
+
+text \<open>If we run \<open>tm_strong_copy\<close> on a single numeral, it behaves like the original weak version \<open>tm_weak_copy\<close>.
+However, if we run the strong machine on an empty list, the result is an empty list.
+If we run the machine on a list with more than two numerals, this
+strong variant will just return the first numeral of the list (a singleton list).
+
+Thus, the result will be a list of two numerals only if we run it on a singleton list.
+
+This is exactly the property, we need for the reduction of problem \<open>K1\<close> to problem \<open>H1\<close>.
+\<close>
+
+(* ---------- tm_skip_first_arg ---------- *)
+
+(*
+let
+tm_skip_first_arg = from_raw [
+  (L,0),(R,2),     --  1  on Bk stop and delegate to tm_erase_right_then_dblBk_left, on Oc investigate further
+  (R,3),(R,2),     --  2  'go right until Bk': on Bk check for further args, on Oc continue loop 'go right until Bk'
+  (L,4),(WO,0),    --  3  on 2nd Bk go for OK path, on Oc delegate to tm_erase_right_then_dblBk_left
+  --
+  (L,5),(L,5),     --  4  skip 1st Bk
+  --
+  (R,0),(L,5)      --  5  'go left until Bk': on 2nd Bk stop, on Oc continue loop 'go left until Bk'
+  ]
+*)
+
+definition 
+  tm_skip_first_arg :: "instr list"
+  where
+    "tm_skip_first_arg \<equiv>
+    [ (L,0),(R,2), (R,3),(R,2), (L,4),(WO,0), (L,5),(L,5), (R,0),(L,5) ]"
+
+(* Prove partial correctness and termination for tm_skip_first_arg *)
+
+(* ERROR case: length nl = 0 *)
+
+lemma tm_skip_first_arg_correct_Nil:
+  "\<lbrace>\<lambda>tap. tap = ([], [])\<rbrace> tm_skip_first_arg \<lbrace>\<lambda>tap. tap = ([], [Bk]) \<rbrace>"
+proof -
+  have "steps0 (1, [], []) tm_skip_first_arg 1 = (0::nat, [], [Bk])"
+    by (simp add: step.simps steps.simps numeral_eqs_upto_12  tm_skip_first_arg_def)
+  then show ?thesis
+    by (smt Hoare_haltI holds_for.simps is_final_eq)
+qed
+
+corollary tm_skip_first_arg_correct_Nil':
+  "length nl = 0
+   \<Longrightarrow>  \<lbrace>\<lambda>tap. tap = ([], <nl::nat list> )\<rbrace> tm_skip_first_arg \<lbrace>\<lambda>tap. tap = ([], [Bk]) \<rbrace>"
+  using tm_skip_first_arg_correct_Nil
+  by (simp add: tm_skip_first_arg_correct_Nil )
+
+(*  OK cases: length nl = 1 *)
+
+(*
+ctxrunTM tm_skip_first_arg (1, [], [Oc])
+
+0: [] _1_ [Oc]
+=> 
+1: [Oc] _2_ []
+=> 
+2: [Oc,Bk] _3_ []
+=> 
+3: [Oc] _4_ [Bk]
+=> 
+4: [] _5_ [Oc,Bk]
+=> 
+5: [] _5_ [Bk,Oc,Bk]
+=> 
+6: [Bk] _0_ [Oc,Bk]
+
+ctxrunTM tm_skip_first_arg (1, [], [Oc, Oc, Oc, Oc])
+
+0: [] _1_ [Oc,Oc,Oc,Oc]
+=> 
+1: [Oc] _2_ [Oc,Oc,Oc]
+=> 
+2: [Oc,Oc] _2_ [Oc,Oc]
+=> 
+3: [Oc,Oc,Oc] _2_ [Oc]
+=> 
+4: [Oc,Oc,Oc,Oc] _2_ []
+=> 
+5: [Oc,Oc,Oc,Oc,Bk] _3_ []
+=> 
+6: [Oc,Oc,Oc,Oc] _4_ [Bk]
+=> 
+7: [Oc,Oc,Oc] _5_ [Oc,Bk]
+=> 
+8: [Oc,Oc] _5_ [Oc,Oc,Bk]
+=> 
+9: [Oc] _5_ [Oc,Oc,Oc,Bk]
+=> 
+10: [] _5_ [Oc,Oc,Oc,Oc,Bk]
+=> 
+11: [] _5_ [Bk,Oc,Oc,Oc,Oc,Bk]
+=> 
+12: [Bk] _0_ [Oc,Oc,Oc,Oc,Bk]
+
+*)
+
+fun 
+  inv_tm_skip_first_arg_len_eq_1_s0 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_skip_first_arg_len_eq_1_s1 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_skip_first_arg_len_eq_1_s2 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_skip_first_arg_len_eq_1_s3 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_skip_first_arg_len_eq_1_s4 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_skip_first_arg_len_eq_1_s5 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_skip_first_arg_len_eq_1_s0 n (l, r) = (
+      l = [Bk] \<and> r = Oc \<up> (Suc n) @ [Bk])"
+  | "inv_tm_skip_first_arg_len_eq_1_s1 n (l, r) = ( 
+      l = [] \<and> r = Oc \<up> Suc n)"
+  | "inv_tm_skip_first_arg_len_eq_1_s2 n (l, r) = 
+      (\<exists>n1 n2. l = Oc \<up> (Suc n1) \<and> r = Oc \<up> n2 \<and> Suc n1 + n2 = Suc n)"
+  | "inv_tm_skip_first_arg_len_eq_1_s3 n (l, r) = (
+      l = Bk # Oc \<up> (Suc n) \<and> r = [])"
+  | "inv_tm_skip_first_arg_len_eq_1_s4 n (l, r) = ( 
+      l = Oc \<up> (Suc n) \<and> r = [Bk])"
+  | "inv_tm_skip_first_arg_len_eq_1_s5 n (l, r) = 
+       (\<exists>n1 n2. (l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n) \<or>
+                (l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n) \<or>
+                (l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n) )"
+
+
+fun inv_tm_skip_first_arg_len_eq_1 :: "nat \<Rightarrow> config \<Rightarrow> bool"
+  where
+    "inv_tm_skip_first_arg_len_eq_1 n (s, tap) = 
+        (if s = 0 then inv_tm_skip_first_arg_len_eq_1_s0 n tap else
+         if s = 1 then inv_tm_skip_first_arg_len_eq_1_s1 n tap else
+         if s = 2 then inv_tm_skip_first_arg_len_eq_1_s2 n tap else
+         if s = 3 then inv_tm_skip_first_arg_len_eq_1_s3 n tap else
+         if s = 4 then inv_tm_skip_first_arg_len_eq_1_s4 n tap else
+         if s = 5 then inv_tm_skip_first_arg_len_eq_1_s5 n tap 
+         else False)"
+
+lemma tm_skip_first_arg_len_eq_1_cases: 
+  fixes s::nat
+  assumes "inv_tm_skip_first_arg_len_eq_1 n (s,l,r)"
+    and "s=0 \<Longrightarrow> P"
+    and "s=1 \<Longrightarrow> P"
+    and "s=2 \<Longrightarrow> P"
+    and "s=3 \<Longrightarrow> P"
+    and "s=4 \<Longrightarrow> P"
+    and "s=5 \<Longrightarrow> P"
+  shows "P"
+proof -
+  have "s < 6"
+  proof (rule ccontr)
+    assume "\<not> s < 6"
+    with \<open>inv_tm_skip_first_arg_len_eq_1 n (s,l,r)\<close> show False by auto
+  qed
+  then have "s = 0 \<or> s = 1 \<or> s = 2 \<or> s = 3  \<or> s = 4 \<or> s = 5" by auto
+  with assms show ?thesis by auto
+qed
+
+lemma inv_tm_skip_first_arg_len_eq_1_step: 
+  assumes "inv_tm_skip_first_arg_len_eq_1 n cf" 
+  shows "inv_tm_skip_first_arg_len_eq_1 n (step0 cf tm_skip_first_arg)"
+proof (cases cf)
+  case (fields s l r)
+  then have cf_cases: "cf = (s, l, r)" .
+  show "inv_tm_skip_first_arg_len_eq_1 n (step0 cf tm_skip_first_arg)"
+  proof (rule tm_skip_first_arg_len_eq_1_cases)
+    from cf_cases and assms
+    show "inv_tm_skip_first_arg_len_eq_1 n (s, l, r)" by auto
+  next
+    assume "s = 0"
+    with cf_cases and assms
+    show ?thesis by (auto simp add: tm_skip_first_arg_def)
+  next
+    assume "s = 1"
+    show ?thesis
+    proof -
+      have "inv_tm_skip_first_arg_len_eq_1 n (step0 (1, l, r) tm_skip_first_arg)"
+      proof (cases r)
+        case Nil
+        then have "r = []" .
+        with assms and cf_cases and \<open>s = 1\<close> show ?thesis
+          by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+      next
+        case (Cons a rs)
+        then have "r = a # rs" .
+        show ?thesis
+        proof (cases a)
+        next
+          case Bk
+          then have "a = Bk" .
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 1\<close>
+          show ?thesis 
+            by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+        next
+          case Oc
+          then have "a = Oc" .
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 1\<close>
+          show ?thesis
+            by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+        qed
+      qed
+      with cf_cases and \<open>s=1\<close> show ?thesis by auto
+    qed
+  next
+    assume "s = 2"
+    show ?thesis
+    proof -
+      have "inv_tm_skip_first_arg_len_eq_1 n (step0 (2, l, r) tm_skip_first_arg)"
+      proof (cases r)
+        case Nil
+        then have "r = []" .
+        with assms and cf_cases and \<open>s = 2\<close>
+        have "inv_tm_skip_first_arg_len_eq_1_s2 n (l, r)" by auto
+        then have "(\<exists>n1 n2. l = Oc \<up> (Suc n1) \<and> r = Oc \<up> n2 \<and> Suc n1 + n2 = Suc n)"
+          by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+
+        then obtain n1 n2 where
+          w_n1_n2: "l = Oc \<up> (Suc n1) \<and> r = Oc \<up> n2 \<and> Suc n1 + n2 = Suc n" by blast
+
+        with \<open>r = []\<close> have "n2 = 0" by auto 
+
+        then have "step0 (2, Oc \<up> (Suc n1),  Oc \<up> n2) tm_skip_first_arg = (3, Bk # Oc \<up> (Suc n1), [])"
+          by (simp add:  tm_skip_first_arg_def step.simps steps.simps numeral_eqs_upto_12)
+
+        moreover with \<open>n2 = 0\<close> and w_n1_n2
+        have "inv_tm_skip_first_arg_len_eq_1 n (3, Bk # Oc \<up> (Suc n1), [])" 
+          by fastforce
+        ultimately show ?thesis using  w_n1_n2
+          by auto
+      next
+        case (Cons a rs)
+        then have "r = a # rs" .
+        show ?thesis
+        proof (cases a)
+          case Bk (* not possible due to invariant in state 2 *)
+          then have "a = Bk" .
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 2\<close>
+          show ?thesis 
+            by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+        next
+          case Oc
+          then have "a = Oc" .
+
+          with assms and cf_cases and \<open>s = 2\<close>
+          have "inv_tm_skip_first_arg_len_eq_1_s2 n (l, r)" by auto
+          then have "\<exists>n1 n2. l = Oc \<up> (Suc n1) \<and> r = Oc \<up> n2 \<and> Suc n1 + n2 = Suc n"
+            by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+          then obtain n1 n2 where
+            w_n1_n2: "l = Oc \<up> (Suc n1) \<and> r = Oc \<up> n2 \<and> Suc n1 + n2 = Suc n" by blast
+
+          with \<open>r = a # rs\<close> and \<open>a = Oc\<close> have "Oc # rs = Oc \<up> n2" by auto
+          then have "n2 > 0" by (meson Cons_replicate_eq)
+
+          then have "step0 (2, Oc \<up> (Suc n1),  Oc \<up> n2) tm_skip_first_arg = (2, Oc # Oc \<up> (Suc n1), Oc \<up> (n2-1))"
+            by (simp add:  tm_skip_first_arg_def step.simps steps.simps numeral_eqs_upto_12)
+
+          moreover have "inv_tm_skip_first_arg_len_eq_1 n (2, Oc # Oc \<up> (Suc n1), Oc \<up> (n2-1))"
+          proof -
+            from \<open>n2 > 0\<close> and w_n1_n2
+            have "Oc # Oc \<up> (Suc n1) =  Oc \<up> (Suc (Suc n1)) \<and> Oc \<up> (n2-1) = Oc \<up> (n2-1) \<and>
+              Suc (Suc n1) + (n2-1) = Suc n" by auto
+            then have "(\<exists>n1' n2'. Oc # Oc \<up> (Suc n1) =  Oc \<up> (Suc n1') \<and> Oc \<up> (n2-1) = Oc \<up> n2' \<and>
+              Suc n1' + n2' = Suc n)" by auto
+            then show "inv_tm_skip_first_arg_len_eq_1 n (2, Oc # Oc \<up> (Suc n1), Oc \<up> (n2-1))"
+              by auto
+          qed
+          ultimately show ?thesis
+            using  assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 2\<close> and w_n1_n2
+            by auto
+        qed
+      qed
+      with cf_cases and \<open>s=2\<close> show ?thesis by auto
+    qed
+  next
+    assume "s = 3"
+    show ?thesis
+    proof -
+      have "inv_tm_skip_first_arg_len_eq_1 n (step0 (3, l, r) tm_skip_first_arg)"
+      proof (cases r)
+        case Nil
+        then have "r = []" .
+        with assms and cf_cases and \<open>s = 3\<close>
+        have "inv_tm_skip_first_arg_len_eq_1_s3 n (l, r)" by auto
+        then have "l = Bk # Oc \<up> (Suc n) \<and> r = []"
+          by auto
+        then 
+        have "step0 (3, Bk # Oc \<up> (Suc n), []) tm_skip_first_arg = (4, Oc \<up> (Suc n), [Bk])"
+          by (simp add:  tm_skip_first_arg_def step.simps steps.simps numeral_eqs_upto_12)
+        moreover
+        have "inv_tm_skip_first_arg_len_eq_1 n (4, Oc \<up> (Suc n), [Bk])" 
+          by fastforce
+        ultimately show ?thesis
+          using \<open>l = Bk # Oc \<up> (Suc n) \<and> r = []\<close> by auto
+      next
+        case (Cons a rs) (* not possible due to invariant in state 3 *)
+        then have "r = a # rs" .
+
+        with assms and cf_cases and \<open>s = 3\<close>
+        have "inv_tm_skip_first_arg_len_eq_1_s3 n (l, r)" by auto
+        then have "l = Bk # Oc \<up> (Suc n) \<and> r = []"
+          by auto
+
+        with \<open>r = a # rs\<close> have False by auto
+        then show ?thesis by auto
+      qed
+      with cf_cases and \<open>s=3\<close> show ?thesis by auto
+    qed
+  next
+    assume "s = 4"
+    show ?thesis
+    proof -
+      have "inv_tm_skip_first_arg_len_eq_1 n (step0 (4, l, r) tm_skip_first_arg)"
+      proof (cases r)
+        case Nil  (* not possible due to invariant in state 4 *)
+        then have "r = []" .
+        with assms and cf_cases and \<open>s = 4\<close> show ?thesis
+          by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+      next
+        case (Cons a rs)
+        then have "r = a # rs" .
+        show ?thesis
+        proof (cases a)
+        next
+          case Bk
+          then have "a = Bk" .
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 4\<close>
+          have "inv_tm_skip_first_arg_len_eq_1_s4 n (l, r)" by auto
+          then have "l = Oc \<up> (Suc n) \<and> r = [Bk]" by auto
+
+          then have F0: "step0 (4,  Oc \<up> (Suc n), [Bk]) tm_skip_first_arg = (5, Oc \<up> n, Oc \<up> (Suc 0) @ [Bk])"
+            by (simp add:  tm_skip_first_arg_def step.simps steps.simps numeral_eqs_upto_12)
+          moreover
+          have "inv_tm_skip_first_arg_len_eq_1_s5 n (Oc \<up> n, Oc \<up> (Suc 0) @ [Bk])"
+          proof (cases n)
+            case 0
+            then have "n=0" .
+            then have "inv_tm_skip_first_arg_len_eq_1_s5 0 ([], Oc \<up> (Suc 0) @ [Bk])"
+              by auto
+            moreover with \<open>n=0\<close> have "(5, Oc \<up> n, Oc \<up> (Suc 0) @ [Bk]) = (5, [], Oc \<up> (Suc 0) @ [Bk])" by auto
+            ultimately show ?thesis by auto
+          next
+            case (Suc n')
+            then have "n = Suc n'" .
+            then have "(5, Oc \<up> n, Oc \<up> (Suc 0) @ [Bk]) = (5, Oc \<up> Suc n', Oc \<up> (Suc 0) @ [Bk])" by auto
+            with \<open>n=Suc n'\<close> have "Suc n' + Suc 0 = Suc n" by arith
+            then have "(Oc \<up> Suc n' = Oc \<up> Suc n' \<and> Oc \<up> (Suc 0) @ [Bk] = Oc \<up> Suc 0 @ [Bk] \<and> Suc n' + Suc 0 = Suc n)" by auto
+            with \<open>(5, Oc \<up> n, Oc \<up> (Suc 0) @ [Bk]) = (5, Oc \<up> Suc n', Oc \<up> (Suc 0) @ [Bk])\<close>
+            show ?thesis
+              by (simp add: Suc \<open>Suc n' + Suc 0 = Suc n\<close>)
+          qed
+          then have "inv_tm_skip_first_arg_len_eq_1 n (5, Oc \<up> n, Oc \<up> (Suc 0) @ [Bk])" by auto
+          ultimately show ?thesis
+            using \<open>l = Oc \<up> (Suc n) \<and> r = [Bk]\<close> by auto
+        next
+          case Oc (* not possible due to invariant in state 4 *)
+          then have "a = Oc" . 
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 4\<close>
+          show ?thesis 
+            by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+        qed
+      qed
+      with cf_cases and \<open>s=4\<close> show ?thesis by auto
+    qed
+  next
+    assume "s = 5"
+    show ?thesis
+    proof -
+      have "inv_tm_skip_first_arg_len_eq_1 n (step0 (5, l, r) tm_skip_first_arg)"
+      proof (cases r)
+        case Nil  (* not possible due to invariant in state 5 *)
+        then have "r = []" .
+        with assms and cf_cases and \<open>s = 5\<close> show ?thesis
+          by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+      next
+        case (Cons a rs)
+        then have "r = a # rs" .
+        show ?thesis
+        proof (cases a)
+
+          case Bk
+          then have "a = Bk" .
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 5\<close>
+          have "inv_tm_skip_first_arg_len_eq_1_s5 n (l, r)" by auto
+          then have "\<exists>n1 n2. (l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n) \<or>
+                             (l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n) \<or>
+                             (l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n)" 
+            by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+          then obtain n1 n2 where
+            w_n1_n2: "(l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n) \<or>
+                      (l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n) \<or>
+                      (l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n)" by blast
+
+          with \<open>a = Bk\<close> and \<open>r = a # rs\<close>
+          have "l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n"            
+            by auto
+
+          then have "step0 (5, [], Bk#Oc \<up> Suc n2 @ [Bk]) tm_skip_first_arg = (0, [Bk], Oc \<up> Suc n2 @ [Bk])"
+            by (simp add:  tm_skip_first_arg_def step.simps steps.simps numeral_eqs_upto_12)
+
+          moreover have "inv_tm_skip_first_arg_len_eq_1 n (0, [Bk], Oc \<up> Suc n @ [Bk])"
+          proof - 
+            have  "inv_tm_skip_first_arg_len_eq_1_s0 n ([Bk], Oc \<up> Suc n @ [Bk])"
+              by (simp)
+            then show "inv_tm_skip_first_arg_len_eq_1 n (0, [Bk], Oc \<up> Suc n @ [Bk])"
+              by auto
+          qed
+          ultimately show ?thesis
+            using  assms and \<open>a = Bk\<close> and \<open>r = a # rs\<close> and cf_cases and \<open>s = 5\<close>
+              and \<open>l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n\<close>
+            by (simp)
+        next
+          case Oc
+          then have "a = Oc" .
+          with assms and \<open>r = a # rs\<close> and cf_cases and \<open>s = 5\<close>
+          have "inv_tm_skip_first_arg_len_eq_1_s5 n (l, r)" by auto
+          then have "\<exists>n1 n2. (l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n) \<or>
+                             (l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n) \<or>
+                             (l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n)" 
+            by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+          then obtain n1 n2 where
+            w_n1_n2: "(l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n) \<or>
+                      (l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n) \<or>
+                      (l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n)" by blast
+
+          with \<open>a = Oc\<close> and \<open>r = a # rs\<close>
+          have "(l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n) \<or>
+                (l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n)" by auto
+
+          then show ?thesis
+          proof
+            assume "l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n"
+            then have "step0 (5, l, r) tm_skip_first_arg = (5, Oc \<up> n1 , Oc \<up> Suc (Suc n2) @ [Bk])"
+              by (simp add:  tm_skip_first_arg_def step.simps steps.simps numeral_eqs_upto_12)
+
+            moreover have "inv_tm_skip_first_arg_len_eq_1 n (5, Oc \<up> n1 , Oc \<up> Suc (Suc n2) @ [Bk])"
+            proof -
+              from \<open>l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n\<close> 
+              have  "inv_tm_skip_first_arg_len_eq_1_s5 n (Oc \<up> n1, Oc \<up> Suc (Suc n2) @ [Bk])"
+                by (cases n1) auto
+              then show "inv_tm_skip_first_arg_len_eq_1 n (5, Oc \<up> n1 , Oc \<up> Suc (Suc n2) @ [Bk])"
+                by auto
+            qed
+            ultimately show "inv_tm_skip_first_arg_len_eq_1 n (step0 (5, l, r) tm_skip_first_arg)"
+              by auto
+          next
+            assume "l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n"
+            then have "step0 (5, l, r) tm_skip_first_arg = (5, [], Bk # Oc \<up> Suc n2 @ [Bk])"
+              by (simp add:  tm_skip_first_arg_def step.simps steps.simps numeral_eqs_upto_12)
+
+            moreover have "inv_tm_skip_first_arg_len_eq_1 n (step0 (5, l, r) tm_skip_first_arg)"
+            proof -
+              from \<open>l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n\<close>
+              have "inv_tm_skip_first_arg_len_eq_1_s5 n (l, r)"                
+                by simp
+              then show "inv_tm_skip_first_arg_len_eq_1 n (step0 (5, l, r) tm_skip_first_arg)"
+                using \<open>l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n\<close>
+                  and \<open>step0 (5, l, r) tm_skip_first_arg = (5, [], Bk # Oc \<up> Suc n2 @ [Bk])\<close>
+                by simp
+            qed
+
+            ultimately show ?thesis
+              using  assms and \<open>a = Oc\<close> and \<open>r = a # rs\<close> and cf_cases and \<open>s = 5\<close>
+                and \<open>l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n\<close>
+              by (simp )
+          qed
+        qed
+      qed
+      with cf_cases and \<open>s=5\<close> show ?thesis by auto
+
+    qed
+  qed
+qed
+
+lemma inv_tm_skip_first_arg_len_eq_1_steps: 
+  assumes "inv_tm_skip_first_arg_len_eq_1 n cf" 
+  shows "inv_tm_skip_first_arg_len_eq_1 n (steps0 cf tm_skip_first_arg stp)"
+proof (induct stp)
+  case 0
+  with assms show ?case
+    by (auto simp add: inv_tm_skip_first_arg_len_eq_1_step step.simps steps.simps)
+next
+  case (Suc stp)
+  with assms show ?case
+    using inv_tm_skip_first_arg_len_eq_1_step step_red by auto 
+qed
+
+lemma tm_skip_first_arg_len_eq_1_partial_correctness:
+  assumes "\<exists>stp. is_final (steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp)"
+  shows "\<lbrace> \<lambda>tap. tap = ([], <[n::nat]>) \<rbrace> 
+           tm_skip_first_arg
+         \<lbrace> \<lambda>tap. tap = ([Bk], <[n::nat]> @[Bk]) \<rbrace>"
+proof (rule Hoare_consequence)
+  show "(\<lambda>tap. tap = ([], <[n::nat]>)) \<mapsto> (\<lambda>tap. tap = ([], <[n::nat]>))"
+    by auto
+next
+  show "inv_tm_skip_first_arg_len_eq_1_s0 n \<mapsto> (\<lambda>tap. tap = ([Bk], <[n::nat]> @ [Bk]))"
+    by (simp add: assert_imp_def  tape_of_list_def tape_of_nat_def)
+next
+  show "\<lbrace>\<lambda>tap. tap = ([], <[n]>)\<rbrace> tm_skip_first_arg \<lbrace>inv_tm_skip_first_arg_len_eq_1_s0 n\<rbrace>"
+  proof (rule Hoare_haltI)
+    fix l::"cell list"
+    fix r:: "cell list"
+    assume major: "(l, r) = ([], <[n]>)"
+    show "\<exists>stp. is_final (steps0 (1, l, r) tm_skip_first_arg stp) \<and>
+                inv_tm_skip_first_arg_len_eq_1_s0 n holds_for steps0 (1, l, r) tm_skip_first_arg stp"
+    proof -
+      from major and assms have "\<exists>stp. is_final (steps0 (1, l, r) tm_skip_first_arg stp)" by auto
+      then obtain stp where
+        w_stp: "is_final (steps0 (1, l, r) tm_skip_first_arg stp)" by blast
+
+      moreover have "inv_tm_skip_first_arg_len_eq_1_s0 n holds_for steps0 (1, l, r) tm_skip_first_arg stp"
+      proof -
+        have "inv_tm_skip_first_arg_len_eq_1 n (1, l, r)"
+          by (simp add: major tape_of_list_def tape_of_nat_def)
+
+        then have "inv_tm_skip_first_arg_len_eq_1 n (steps0 (1, l, r) tm_skip_first_arg stp)"
+          using inv_tm_skip_first_arg_len_eq_1_steps by auto
+
+        then show ?thesis
+          by (smt holds_for.elims(3) inv_tm_skip_first_arg_len_eq_1.simps is_final_eq w_stp)
+      qed
+      ultimately show ?thesis by auto
+    qed
+  qed
+qed
+
+(* --- now, we prove termination of tm_skip_first_arg on singleton lists --- *)
+(* 
+    Lexicographic orders (See List.measures)
+    quote: "These are useful for termination proofs"
+    
+    lemma in_measures[simp]:
+      "(x, y) \<in> measures [] = False"
+      "(x, y) \<in> measures (f # fs)
+             = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"
+*)
+
+(* Assemble a lexicographic measure function *)
+
+definition measure_tm_skip_first_arg_len_eq_1 :: "(config \<times> config) set"
+  where
+    "measure_tm_skip_first_arg_len_eq_1 = measures [
+      \<lambda>(s, l, r). (if s = 0 then 0 else 5 - s),
+      \<lambda>(s, l, r). (if s = 2 then length r else 0),
+      \<lambda>(s, l, r). (if s = 5 then length l + (if hd r = Oc then 2 else 1) else 0)
+      ]"
+
+lemma wf_measure_tm_skip_first_arg_len_eq_1: "wf measure_tm_skip_first_arg_len_eq_1"
+  unfolding measure_tm_skip_first_arg_len_eq_1_def
+  by (auto)
+
+lemma measure_tm_skip_first_arg_len_eq_1_induct [case_names Step]: 
+  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_tm_skip_first_arg_len_eq_1\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
+  using wf_measure_tm_skip_first_arg_len_eq_1
+  by (metis wf_iff_no_infinite_down_chain)
+
+(* Machine tm_skip_first_arg always halts on a singleton list *)
+
+lemma tm_skip_first_arg_len_eq_1_halts:
+  "\<exists>stp. is_final (steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp)"
+proof (induct rule: measure_tm_skip_first_arg_len_eq_1_induct)
+  case (Step stp)
+  then have not_final: "\<not> is_final (steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp)" .
+
+  have INV: "inv_tm_skip_first_arg_len_eq_1 n (steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp)"
+  proof (rule_tac inv_tm_skip_first_arg_len_eq_1_steps)
+    show  "inv_tm_skip_first_arg_len_eq_1 n (1, [], <[n::nat]>)"
+      by (simp add: tape_of_list_def tape_of_nat_def  )
+  qed
+
+  have SUC_STEP_RED: "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+        step0 (steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp) tm_skip_first_arg"
+    by (rule step_red)
+
+  show "( steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp),
+          steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp
+        ) \<in> measure_tm_skip_first_arg_len_eq_1"
+  proof (cases "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp")
+    case (fields s l r)
+    then have cf_cases: "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (s, l, r)" .
+
+    show ?thesis
+    proof (rule tm_skip_first_arg_len_eq_1_cases)
+      from INV and cf_cases
+      show "inv_tm_skip_first_arg_len_eq_1 n (s, l, r)" by auto
+    next
+      assume "s=0" (* not possible *)
+      with cf_cases not_final
+      show ?thesis by auto
+    next
+      assume "s=1"
+      show ?thesis
+      proof (cases r)
+        case Nil        
+        then have "r = []" .
+
+        with cf_cases and \<open>s=1\<close>
+        have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (1, l, [])"
+          by auto
+        with INV have False by auto (* not possible due to invariant in s=1 *)
+        then show ?thesis by auto
+      next
+        case (Cons a rs)
+        then have "r = a # rs" .
+        show ?thesis
+        proof (cases "a")
+          case Bk
+          then have "a=Bk" .
+          with cf_cases and \<open>s=1\<close> and \<open>r = a # rs\<close>
+          have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (1, l, Bk#rs)"
+            by auto       
+
+          with INV have False by auto (* not possible due to invariant in s=1 *)
+          then show ?thesis by auto
+        next
+          case Oc
+          then have "a=Oc" .
+          with cf_cases and \<open>s=1\<close> and \<open>r = a # rs\<close>
+          have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (1, l, Oc#rs)"
+            by auto   
+
+          with SUC_STEP_RED
+          have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                step0 (1, l, Oc#rs) tm_skip_first_arg"
+            by auto
+
+          also have "... = (2,Oc#l,rs)"
+            by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) = (2,Oc#l,rs)"
+            by auto
+
+          with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (1, l, Oc#rs)\<close>
+          show ?thesis           
+            by (auto simp add: measure_tm_skip_first_arg_len_eq_1_def)
+        qed         
+      qed
+    next
+      assume "s=2"
+      show ?thesis
+      proof -
+        from cf_cases and \<open>s=2\<close>
+        have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (2, l, r)"
+          by auto
+
+        with cf_cases  and \<open>s=2\<close> and INV
+        have "(\<exists>n1 n2. l = Oc \<up> (Suc n1) \<and> r = Oc \<up> n2 \<and> Suc n1 + n2 = Suc n)"
+          by auto
+        then have "(\<exists>n2. r = Oc \<up> n2)" by blast
+        then obtain n2 where w_n2: "r = Oc \<up> n2" by blast
+        show ?thesis
+        proof (cases n2)
+          case 0
+          then have "n2 = 0" .
+          with w_n2 have "r = []" by auto
+          with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (2, l, r)\<close>
+          have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (2, l, [])"
+            by auto
+
+          with SUC_STEP_RED
+          have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                step0 (2, l, []) tm_skip_first_arg"
+            by auto
+
+          also have "... = (3,Bk#l,[])"
+            by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) = (3,Bk#l,[])"
+            by auto
+
+          with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (2, l, [])\<close>
+          show ?thesis           
+            by (auto simp add: measure_tm_skip_first_arg_len_eq_1_def)
+        next
+          case (Suc n2')
+          then have "n2 = Suc n2'" .
+
+          with w_n2 have "r = Oc \<up> Suc n2'" by auto
+          with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (2, l, r)\<close>
+          have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (2, l, Oc#Oc \<up> n2')"
+            by auto
+
+          with SUC_STEP_RED
+          have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                step0 (2, l, Oc#Oc \<up> n2') tm_skip_first_arg"
+            by auto
+
+          also have "... = (2,Oc#l,Oc \<up> n2')"
+            by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) = (2,Oc#l,Oc \<up> n2')"
+            by auto
+
+          with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (2, l, Oc#Oc \<up> n2')\<close>
+          show ?thesis           
+            by (auto simp add: measure_tm_skip_first_arg_len_eq_1_def)
+        qed
+      qed
+    next
+      assume "s=3"
+      show ?thesis
+      proof -
+        from cf_cases and \<open>s=3\<close>
+        have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (3, l, r)"
+          by auto
+
+        with cf_cases  and \<open>s=3\<close> and INV
+
+        have "l = Bk # Oc \<up> (Suc n) \<and> r = []"
+          by auto
+
+        with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (3, l, r)\<close>
+        have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (3, Bk # Oc \<up> (Suc n), [])"
+          by auto
+
+        with SUC_STEP_RED
+        have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                step0 (3, Bk # Oc \<up> (Suc n), []) tm_skip_first_arg"
+          by auto
+
+        also have "... = (4,Oc \<up> (Suc n),[Bk])"
+          by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) = (4,Oc \<up> (Suc n),[Bk])"
+          by auto
+
+        with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (3, Bk # Oc \<up> (Suc n), [])\<close>
+        show ?thesis           
+          by (auto simp add: measure_tm_skip_first_arg_len_eq_1_def)
+      qed
+    next
+      assume "s=4"
+      show ?thesis
+      proof -
+        from cf_cases and \<open>s=4\<close>
+        have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (4, l, r)"
+          by auto
+
+        with cf_cases  and \<open>s=4\<close> and INV
+
+        have "l = Oc \<up> (Suc n) \<and> r = [Bk]"
+          by auto
+
+        with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (4, l, r)\<close>
+        have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (4, Oc \<up> (Suc n), [Bk])"
+          by auto
+
+        with SUC_STEP_RED
+        have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                step0 (4, Oc \<up> (Suc n), [Bk]) tm_skip_first_arg"
+          by auto
+
+        also have "... = (5,Oc \<up> n,[Oc, Bk])"
+          by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) = (5,Oc \<up> n,[Oc, Bk])"
+          by auto
+
+        with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (4, Oc \<up> (Suc n), [Bk])\<close>
+        show ?thesis           
+          by (auto simp add: measure_tm_skip_first_arg_len_eq_1_def)
+      qed
+    next
+      assume "s=5"
+      show ?thesis
+      proof -
+        from cf_cases and \<open>s=5\<close>
+        have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (5, l, r)"
+          by auto
+
+        with cf_cases  and \<open>s=5\<close> and INV
+
+        have "(\<exists>n1 n2.
+                (l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n) \<or>
+                (l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n) \<or>
+                (l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n) )"
+          by auto
+
+        then obtain n1 n2 where
+          w_n1_n2: "(l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n) \<or>
+                    (l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n) \<or>
+                    (l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n)"
+          by blast
+        then show ?thesis
+        proof
+          assume "l = Oc \<up> Suc n1 \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n1 + Suc n2 = Suc n"
+
+          with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (5, l, r)\<close>
+          have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (5, Oc \<up> Suc n1, Oc \<up> Suc n2 @ [Bk])"
+            by auto
+
+          with SUC_STEP_RED
+          have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                step0 (5, Oc \<up> Suc n1, Oc \<up> Suc n2 @ [Bk]) tm_skip_first_arg"
+            by auto
+
+          also have "... = (5,Oc \<up> n1,Oc#Oc \<up> Suc n2 @ [Bk])"
+            by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                        (5,Oc \<up> n1,Oc#Oc \<up> Suc n2 @ [Bk])"
+            by auto
+
+          with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (5, Oc \<up> Suc n1, Oc \<up> Suc n2 @ [Bk])\<close>
+          show ?thesis           
+            by (auto simp add: measure_tm_skip_first_arg_len_eq_1_def)
+        next
+          assume "l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n \<or>
+                  l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n"
+          then show ?thesis
+          proof
+            assume "l = [] \<and> r = Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n"
+
+            with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (5, l, r)\<close>
+            have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (5, [], Oc \<up> Suc n2 @ [Bk])"
+              by auto
+
+            with SUC_STEP_RED
+            have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                step0 (5, [], Oc \<up> Suc n2 @ [Bk]) tm_skip_first_arg"
+              by auto
+
+            also have "... = (5,[],Bk#Oc \<up> Suc n2 @ [Bk])"
+              by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                        (5,[],Bk#Oc \<up> Suc n2 @ [Bk])"
+              by auto
+
+            with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (5, [], Oc \<up> Suc n2 @ [Bk])\<close>
+            show ?thesis           
+              by (auto simp add: measure_tm_skip_first_arg_len_eq_1_def)
+          next
+            assume "l = [] \<and> r = Bk # Oc \<up> Suc n2 @ [Bk] \<and> Suc n2 = Suc n"
+
+            with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (5, l, r)\<close>
+            have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (5, [], Bk # Oc \<up> Suc n2 @ [Bk])"
+              by auto
+
+            with SUC_STEP_RED
+            have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                step0 (5, [], Bk # Oc \<up> Suc n2 @ [Bk]) tm_skip_first_arg"
+              by auto
+
+            also have "... = (0,[Bk], Oc \<up> Suc n2 @ [Bk])"
+              by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [], <[n::nat]>) tm_skip_first_arg (Suc stp) =
+                        (0,[Bk], Oc \<up> Suc n2 @ [Bk])"
+              by auto
+
+            with \<open>steps0 (1, [], <[n::nat]>) tm_skip_first_arg stp = (5, [], Bk # Oc \<up> Suc n2 @ [Bk])\<close>
+            show ?thesis         
+              by (auto simp add: measure_tm_skip_first_arg_len_eq_1_def)
+          qed
+        qed
+      qed
+    qed
+  qed
+qed
+
+lemma tm_skip_first_arg_len_eq_1_total_correctness:
+  "\<lbrace> \<lambda>tap. tap = ([], <[n::nat]>)\<rbrace>
+     tm_skip_first_arg
+   \<lbrace> \<lambda>tap. tap = ([Bk], <[n::nat]> @[Bk])\<rbrace>"
+proof (rule tm_skip_first_arg_len_eq_1_partial_correctness)
+  show "\<exists>stp. is_final (steps0 (1, [], <[n]>) tm_skip_first_arg stp)"
+    using  tm_skip_first_arg_len_eq_1_halts by auto
+qed
+
+lemma tm_skip_first_arg_len_eq_1_total_correctness':
+  "length nl = 1
+   \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list> )\<rbrace> tm_skip_first_arg \<lbrace> \<lambda>tap. tap = ([Bk],  <[hd nl]> @[Bk])\<rbrace>"
+proof -
+  assume "length nl = 1"
+  then have "nl = [hd nl]"
+    by (metis One_nat_def diff_Suc_1 length_0_conv length_greater_0_conv length_tl list.distinct(1)
+        list.expand list.sel(1) list.sel(3) list.size(3) zero_neq_one)
+  moreover have "\<lbrace> \<lambda>tap. tap = ([], <[hd nl]>)\<rbrace> tm_skip_first_arg \<lbrace> \<lambda>tap. tap = ([Bk], <[hd nl]> @[Bk])\<rbrace>"
+    by (rule tm_skip_first_arg_len_eq_1_total_correctness)
+  ultimately show ?thesis
+    by (simp add: Hoare_haltE Hoare_haltI tape_of_list_def)
+qed
+
+(* ERROR cases: length nl > 1 *)
+
+(*
+ctxrunTM tm_skip_first_arg (1,[],[Oc, Bk, Oc])
+0: [] _1_ [Oc,Bk,Oc]
+=>
+1: [Oc] _2_ [Bk,Oc]
+=>
+2: [Oc,Bk] _3_ [Oc]
+=>
+3: [Oc,Bk] _0_ [Oc]
+
+ctxrunTM tm_skip_first_arg (1,[],[Oc,Oc, Bk, Oc,Oc])
+0: [] _1_ [Oc,Oc,Bk,Oc,Oc]
+=>
+1: [Oc] _2_ [Oc,Bk,Oc,Oc]
+=> 
+2: [Oc,Oc] _2_ [Bk,Oc,Oc]
+=>
+3: [Oc,Oc,Bk] _3_ [Oc,Oc]
+=>
+4: [Oc,Oc,Bk] _0_ [Oc,Oc]
+
+ctxrunTM tm_skip_first_arg (1,[],[Oc,Oc,Oc, Bk, Oc,Oc])
+0: [] _1_ [Oc,Oc,Oc,Bk,Oc,Oc]
+=>
+1: [Oc] _2_ [Oc,Oc,Bk,Oc,Oc]
+=>
+2: [Oc,Oc] _2_ [Oc,Bk,Oc,Oc]
+=>
+3: [Oc,Oc,Oc] _2_ [Bk,Oc,Oc]
+=>
+4: [Oc,Oc,Oc,Bk] _3_ [Oc,Oc]
+=>
+5: [Oc,Oc,Oc,Bk] _0_ [Oc,Oc]
+
+ctxrunTM tm_skip_first_arg (1, [], [Oc,Oc,Bk, Oc,Bk, Oc,Oc])
+0: [] _1_ [Oc,Oc,Bk,Oc,Bk,Oc,Oc]
+=>
+1: [Oc] _2_ [Oc,Bk,Oc,Bk,Oc,Oc]
+=>
+2: [Oc,Oc] _2_ [Bk,Oc,Bk,Oc,Oc]
+=>
+3: [Bk,Oc,Oc] _3_ [Oc,Bk,Oc,Oc]
+=>
+4: [Bk,Oc,Oc] _0_ [Oc,Bk,Oc,Oc]
+
+
+*)
+
+
+fun 
+  inv_tm_skip_first_arg_len_gt_1_s0 :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_skip_first_arg_len_gt_1_s1 :: "nat \<Rightarrow> nat list\<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_skip_first_arg_len_gt_1_s2 :: "nat \<Rightarrow> nat list\<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_skip_first_arg_len_gt_1_s3 :: "nat \<Rightarrow> nat list\<Rightarrow> tape \<Rightarrow> bool"
+  where
+   "inv_tm_skip_first_arg_len_gt_1_s1 n ns (l, r) = (
+      l = [] \<and> r = Oc \<up> Suc n @ [Bk] @ (<ns::nat list>) )"
+  | "inv_tm_skip_first_arg_len_gt_1_s2 n ns (l, r) = 
+      (\<exists>n1 n2. l = Oc \<up> (Suc n1) \<and> r = Oc \<up> n2 @ [Bk] @ (<ns::nat list>) \<and>
+                Suc n1 + n2 = Suc n)"
+  | "inv_tm_skip_first_arg_len_gt_1_s3 n ns (l, r) = (
+      l = Bk # Oc \<up> (Suc n) \<and> r = (<ns::nat list>)
+      )"
+  |  "inv_tm_skip_first_arg_len_gt_1_s0 n ns (l, r) = (
+      l = Bk# Oc \<up> (Suc n) \<and> r = (<ns::nat list>)
+      )"
+
+fun inv_tm_skip_first_arg_len_gt_1 :: "nat \<Rightarrow> nat list \<Rightarrow> config \<Rightarrow> bool"
+  where
+    "inv_tm_skip_first_arg_len_gt_1 n ns (s, tap) = 
+        (if s = 0 then inv_tm_skip_first_arg_len_gt_1_s0 n ns tap else
+         if s = 1 then inv_tm_skip_first_arg_len_gt_1_s1 n ns tap else
+         if s = 2 then inv_tm_skip_first_arg_len_gt_1_s2 n ns tap else
+         if s = 3 then inv_tm_skip_first_arg_len_gt_1_s3 n ns tap
+         else False)"
+
+lemma tm_skip_first_arg_len_gt_1_cases: 
+  fixes s::nat
+  assumes "inv_tm_skip_first_arg_len_gt_1 n ns (s,l,r)"
+    and "s=0 \<Longrightarrow> P"
+    and "s=1 \<Longrightarrow> P"
+    and "s=2 \<Longrightarrow> P"
+    and "s=3 \<Longrightarrow> P"
+    and "s=4 \<Longrightarrow> P"
+    and "s=5 \<Longrightarrow> P"
+  shows "P"
+proof -
+  have "s < 6"
+  proof (rule ccontr)
+    assume "\<not> s < 6"
+    with \<open>inv_tm_skip_first_arg_len_gt_1 n ns (s,l,r)\<close> show False by auto
+  qed
+  then have "s = 0 \<or> s = 1 \<or> s = 2 \<or> s = 3  \<or> s = 4 \<or> s = 5" by auto
+  with assms show ?thesis by auto
+qed
+
+lemma inv_tm_skip_first_arg_len_gt_1_step: 
+  assumes "length ns > 0"
+    and "inv_tm_skip_first_arg_len_gt_1 n ns cf" 
+  shows "inv_tm_skip_first_arg_len_gt_1 n ns (step0 cf tm_skip_first_arg)"
+proof (cases cf)
+  case (fields s l r)
+  then have cf_cases: "cf = (s, l, r)" .
+  show "inv_tm_skip_first_arg_len_gt_1 n ns (step0 cf tm_skip_first_arg)"
+  proof (rule tm_skip_first_arg_len_gt_1_cases)
+    from cf_cases and assms
+    show "inv_tm_skip_first_arg_len_gt_1 n ns (s, l, r)" by auto
+  next
+    assume "s = 0"
+    with cf_cases and assms
+    show ?thesis by (auto simp add: tm_skip_first_arg_def)
+  next
+    assume "s = 4"
+    with cf_cases and assms
+    show ?thesis by (auto simp add: tm_skip_first_arg_def)
+  next
+    assume "s = 5"
+    with cf_cases and assms
+    show ?thesis by (auto simp add: tm_skip_first_arg_def)
+  next
+    assume "s = 1"
+    with cf_cases and assms
+    have "l = [] \<and> r = Oc \<up> Suc n @ [Bk] @ (<ns::nat list>)"
+      by auto
+    with assms and cf_cases and \<open>s = 1\<close> show ?thesis
+      by (auto simp add: tm_skip_first_arg_def step.simps steps.simps)
+  next
+    assume "s = 2"
+    with cf_cases and assms
+    have "(\<exists>n1 n2. l = Oc \<up> (Suc n1) \<and> r = Oc \<up> n2 @ [Bk] @ (<ns::nat list>) \<and> Suc n1 + n2 = Suc n)"
+      by auto
+    then obtain n1 n2
+      where w_n1_n2: "l = Oc \<up> (Suc n1) \<and> r = Oc \<up> n2 @ [Bk] @ (<ns::nat list>) \<and> Suc n1 + n2 = Suc n" by blast
+    show ?thesis
+    proof (cases n2)
+      case 0
+      then have "n2 = 0" .
+      with w_n1_n2 have "l = Oc \<up> (Suc n1) \<and> r = [Bk] @ (<ns::nat list>) \<and> Suc n1 = Suc n"
+        by auto
+
+      then have "step0 (2, Oc \<up> (Suc n1),  [Bk] @ (<ns::nat list>)) tm_skip_first_arg = (3, Bk # Oc \<up> (Suc n1), (<ns::nat list>))"
+        by (simp add:  tm_skip_first_arg_def step.simps steps.simps numeral_eqs_upto_12)
+
+      moreover have "inv_tm_skip_first_arg_len_gt_1 n ns (3, Bk # Oc \<up> (Suc n1), (<ns::nat list>))"
+      proof -
+        from \<open>l = Oc \<up> (Suc n1) \<and> r = [Bk] @ (<ns::nat list>) \<and> Suc n1 = Suc n\<close>
+        have "Oc \<up> (Suc n1) = Oc \<up> (Suc n1) \<and> Bk # Oc \<up> (Suc n1) = Bk#Oc#Oc \<up> n1 \<and> Suc n1 + 0 = Suc n" by auto
+        then show "inv_tm_skip_first_arg_len_gt_1 n ns (3, Bk # Oc \<up> (Suc n1), (<ns::nat list>))" by auto
+      qed
+
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 2\<close> and w_n1_n2
+        by auto
+    next
+      case (Suc n2')
+      then have "n2 = Suc n2'" .
+      with w_n1_n2 have "l = Oc \<up> (Suc n1) \<and> r = Oc \<up> Suc n2' @ [Bk] @ (<ns::nat list>) \<and> Suc n1 + n2 = Suc n"
+        by auto
+
+      then have "step0 (2, Oc \<up> (Suc n1),  Oc \<up> Suc n2' @ [Bk] @ (<ns::nat list>)) tm_skip_first_arg
+                  = (2, Oc # Oc \<up> (Suc n1), Oc \<up> n2' @ [Bk] @ (<ns::nat list>))"
+        by (simp add:  tm_skip_first_arg_def step.simps steps.simps numeral_eqs_upto_12)
+
+      moreover have "inv_tm_skip_first_arg_len_gt_1 n ns (2, Oc # Oc \<up> (Suc n1), Oc \<up> n2' @ [Bk] @ (<ns::nat list>))"
+      proof -
+        from \<open>l = Oc \<up> (Suc n1) \<and> r = Oc \<up> Suc n2' @ [Bk] @ (<ns::nat list>) \<and> Suc n1 + n2 = Suc n\<close>
+        have "Oc # Oc \<up> (Suc n1) = Oc \<up> Suc (Suc n1) \<and> Oc \<up> n2' @ [Bk] @ (<ns::nat list>)
+                 = Oc \<up> n2' @ [Bk] @ (<ns::nat list>) \<and> Suc (Suc n1) + n2' = Suc n"
+          by (simp add: Suc add_Suc_shift)
+        then show "inv_tm_skip_first_arg_len_gt_1 n ns (2, Oc # Oc \<up> (Suc n1), Oc \<up> n2' @ [Bk] @ (<ns::nat list>))" 
+          by force
+      qed
+
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 2\<close> and w_n1_n2
+        using \<open>l = Oc \<up> (Suc n1) \<and> r = Oc \<up> Suc n2' @ [Bk] @ (<ns::nat list>) \<and> Suc n1 + n2 = Suc n\<close>
+        by force
+    qed
+  next
+    assume "s = 3"
+    with cf_cases and assms
+    have unpackedINV: "l = Bk # Oc \<up> (Suc n) \<and> r = (<ns::nat list>)"
+      by auto
+    moreover with \<open>length ns > 0\<close> have "(ns::nat list) \<noteq> [] \<and> hd (<ns::nat list>) = Oc"
+      using numeral_list_head_is_Oc
+      by force
+    moreover from this have "<ns::nat list> = Oc#(tl (<ns::nat list>))"
+      by (metis append_Nil list.exhaust_sel tape_of_list_empty
+          unique_Bk_postfix_numeral_list_Nil)
+    ultimately have "step0 (3, Bk # Oc \<up> (Suc n),  (<ns::nat list>)) tm_skip_first_arg
+                     = (0, Bk # Oc \<up> (Suc n), (<ns::nat list>))"
+    proof -
+      from \<open><ns> = Oc # tl (<ns>)\<close>
+      have "step0 (3, Bk # Oc \<up> (Suc n),  (<ns::nat list>)) tm_skip_first_arg
+            = step0 (3, Bk # Oc \<up> (Suc n), Oc # tl (<ns>)) tm_skip_first_arg"
+        by auto
+      also have "... = (0, Bk # Oc \<up> (Suc n),  Oc # tl (<ns>))"
+        by (simp add:  tm_skip_first_arg_def step.simps steps.simps numeral_eqs_upto_12)
+      also with  \<open><ns> = Oc # tl (<ns>)\<close> have "... =  (0, Bk # Oc \<up> (Suc n),  (<ns::nat list>))" by auto
+      finally show "step0 (3, Bk # Oc \<up> (Suc n),  (<ns::nat list>)) tm_skip_first_arg
+                    = (0, Bk # Oc \<up> (Suc n), (<ns::nat list>))"
+        by auto
+    qed
+
+    moreover with \<open>l = Bk # Oc \<up> (Suc n) \<and> r = (<ns::nat list>)\<close>
+    have "inv_tm_skip_first_arg_len_gt_1 n ns (0, Bk # Oc \<up> (Suc n), (<ns::nat list>))"
+      by auto
+
+    ultimately show ?thesis
+      using  assms and cf_cases and \<open>s = 3\<close> and unpackedINV
+      by auto
+  qed
+qed
+
+lemma inv_tm_skip_first_arg_len_gt_1_steps: 
+  assumes "length ns > 0"
+  and "inv_tm_skip_first_arg_len_gt_1 n ns cf" 
+  shows "inv_tm_skip_first_arg_len_gt_1 n ns (steps0 cf tm_skip_first_arg stp)"
+proof (induct stp)
+  case 0
+  with assms show ?case
+    by (auto simp add: inv_tm_skip_first_arg_len_gt_1_step step.simps steps.simps)
+next
+  case (Suc stp)
+  with assms show ?case
+    using inv_tm_skip_first_arg_len_gt_1_step step_red by auto 
+qed
+
+lemma tm_skip_first_arg_len_gt_1_partial_correctness:
+  assumes "\<exists>stp. is_final (steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns::nat list>) ) tm_skip_first_arg stp)"
+  and "0 < length ns"
+  shows "\<lbrace>\<lambda>tap. tap = ([], Oc \<up> Suc n @ [Bk] @ (<ns::nat list>) ) \<rbrace> 
+           tm_skip_first_arg
+         \<lbrace> \<lambda>tap. tap = (Bk# Oc \<up> Suc n, (<ns::nat list>) ) \<rbrace>"
+proof (rule Hoare_consequence)
+  show " (\<lambda>tap. tap = ([],  Oc \<up> Suc n @ [Bk] @ (<ns::nat list>)))
+         \<mapsto> (\<lambda>tap. tap = ([],  Oc \<up> Suc n @ [Bk] @ (<ns::nat list>)))"
+    by (simp add: assert_imp_def tape_of_nat_def)
+next
+  show "inv_tm_skip_first_arg_len_gt_1_s0 n ns \<mapsto> (\<lambda>tap. tap = (Bk # Oc \<up> Suc n, <ns>))"
+    using assert_imp_def inv_tm_skip_first_arg_len_gt_1_s0.simps rev_numeral tape_of_nat_def by auto
+next
+  show "\<lbrace>\<lambda>tap. tap = ([], Oc \<up> Suc n @ [Bk] @ <ns>)\<rbrace> tm_skip_first_arg \<lbrace>inv_tm_skip_first_arg_len_gt_1_s0 n ns\<rbrace>"
+  proof (rule Hoare_haltI)
+    fix l::"cell list"
+    fix r:: "cell list"
+    assume major: "(l, r) = ([], Oc \<up> Suc n @ [Bk] @ <ns::nat list>)"
+    show "\<exists>stp. is_final (steps0 (1, l, r) tm_skip_first_arg stp) \<and>
+            inv_tm_skip_first_arg_len_gt_1_s0 n ns holds_for steps0 (1, l, r) tm_skip_first_arg stp"
+    proof -
+      from major and assms have "\<exists>stp. is_final (steps0 (1, l, r) tm_skip_first_arg stp)" by auto
+      then obtain stp where
+        w_stp: "is_final (steps0 (1, l, r) tm_skip_first_arg stp)" by blast
+
+      moreover have "inv_tm_skip_first_arg_len_gt_1_s0 n ns holds_for steps0 (1, l, r) tm_skip_first_arg stp"
+      proof -
+        have "inv_tm_skip_first_arg_len_gt_1 n ns (1, l, r)"
+          by (simp add: major tape_of_list_def tape_of_nat_def)
+
+        with assms  have "inv_tm_skip_first_arg_len_gt_1 n ns (steps0 (1, l, r) tm_skip_first_arg stp)"
+          using inv_tm_skip_first_arg_len_gt_1_steps by auto
+
+        then show ?thesis
+          by (smt holds_for.elims(3) inv_tm_skip_first_arg_len_gt_1.simps is_final_eq w_stp)
+      qed
+      ultimately show ?thesis by auto
+    qed
+  qed
+qed
+
+(* --- now, we prove termination of tm_skip_first_arg on arguments containing more than one numeral --- *)
+(* 
+    Lexicographic orders (See List.measures)
+    quote: "These are useful for termination proofs"
+    
+    lemma in_measures[simp]:
+      "(x, y) \<in> measures [] = False"
+      "(x, y) \<in> measures (f # fs)
+             = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"
+*)
+
+(* Assemble a lexicographic measure function *)
+
+definition measure_tm_skip_first_arg_len_gt_1 :: "(config \<times> config) set"
+  where
+    "measure_tm_skip_first_arg_len_gt_1 = measures [
+      \<lambda>(s, l, r). (if s = 0 then 0 else 4 - s),
+      \<lambda>(s, l, r). (if s = 2 then length r else 0)
+      ]"
+
+lemma wf_measure_tm_skip_first_arg_len_gt_1: "wf measure_tm_skip_first_arg_len_gt_1"
+  unfolding measure_tm_skip_first_arg_len_gt_1_def
+  by (auto)
+
+lemma measure_tm_skip_first_arg_len_gt_1_induct [case_names Step]: 
+  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_tm_skip_first_arg_len_gt_1\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
+  using wf_measure_tm_skip_first_arg_len_gt_1
+  by (metis wf_iff_no_infinite_down_chain)
+
+lemma tm_skip_first_arg_len_gt_1_halts:
+  "0 < length ns \<Longrightarrow> \<exists>stp. is_final (steps0 (1, [], Oc \<up> Suc n @ [Bk] @ <ns::nat list>) tm_skip_first_arg stp)"
+proof -
+  assume A:  "0 < length ns"
+  show "\<exists>stp. is_final (steps0 (1, [], Oc \<up> Suc n @ [Bk] @ <ns::nat list>) tm_skip_first_arg stp)"
+  proof (induct rule: measure_tm_skip_first_arg_len_gt_1_induct)
+    case (Step stp)
+    then have not_final: "\<not> is_final (steps0 (1, [], Oc \<up> Suc n @ [Bk] @ <ns>) tm_skip_first_arg stp)" .
+
+    have INV: "inv_tm_skip_first_arg_len_gt_1 n ns (steps0 (1, [], Oc \<up> Suc n @ [Bk] @ <ns>) tm_skip_first_arg stp)"
+    proof (rule_tac inv_tm_skip_first_arg_len_gt_1_steps)
+      from A show "0 < length ns " .
+      then show  "inv_tm_skip_first_arg_len_gt_1 n ns (1, [], Oc \<up> Suc n @ [Bk] @ <ns>)"
+        by (simp add: tape_of_list_def tape_of_nat_def)
+    qed
+
+    have SUC_STEP_RED:
+      "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ <ns>) tm_skip_first_arg (Suc stp) =
+         step0 (steps0 (1, [], Oc \<up> Suc n @ [Bk] @ <ns>) tm_skip_first_arg stp) tm_skip_first_arg"
+      by (rule step_red)
+
+    show "( steps0 (1, [], Oc \<up> Suc n @ [Bk] @ <ns>) tm_skip_first_arg (Suc stp),
+          steps0 (1, [], Oc \<up> Suc n @ [Bk] @ <ns>) tm_skip_first_arg stp
+        ) \<in> measure_tm_skip_first_arg_len_gt_1"
+
+    proof (cases "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ <ns>) tm_skip_first_arg stp")
+      case (fields s l r2)
+      then have
+        cf_cases: "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ <ns>) tm_skip_first_arg stp = (s, l, r2)" .
+      show ?thesis
+      proof (rule tm_skip_first_arg_len_gt_1_cases)
+        from INV and cf_cases
+        show "inv_tm_skip_first_arg_len_gt_1 n ns (s, l, r2)" by auto
+      next
+        assume "s=0" (* not possible *)
+        with cf_cases not_final
+        show ?thesis by auto
+      next
+        assume "s=4" (* not possible *)
+        with cf_cases not_final INV
+        show ?thesis by auto
+      next
+        assume "s=5" (* not possible *)
+        with cf_cases not_final INV
+        show ?thesis by auto
+      next
+        assume "s=1"
+        show ?thesis
+        proof -
+          from cf_cases and \<open>s=1\<close>
+          have "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (1, l, r2)"
+            by auto
+
+          with cf_cases  and \<open>s=1\<close> and INV
+          have unpackedINV: "l = [] \<and> r2 = Oc \<up> Suc n @ [Bk] @ (<ns>)"
+            by auto          
+
+          with cf_cases and \<open>s=1\<close> and SUC_STEP_RED
+          have "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg (Suc stp) =
+                step0 (1, [],  Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg"
+            by auto
+          also have "... = (2,[Oc],Oc \<up> n @ [Bk] @ (<ns>))"
+            by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg (Suc stp)
+                       = (2,[Oc],Oc \<up> n @ [Bk] @ (<ns>))"
+            by auto
+
+          with \<open>steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (1, l, r2)\<close>
+          show ?thesis
+            by (auto simp add: measure_tm_skip_first_arg_len_gt_1_def)
+        qed
+      next
+        assume "s=2"
+        show ?thesis
+        proof -
+          from cf_cases and \<open>s=2\<close>
+          have "steps0 (1, [],Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (2, l, r2)"
+            by auto
+
+          with cf_cases  and \<open>s=2\<close> and INV
+          have "(\<exists>n1 n2. l = Oc \<up> (Suc n1) \<and> r2 = Oc \<up> n2 @ [Bk] @ (<ns::nat list>) \<and>
+                Suc n1 + n2 = Suc n)"
+            by auto
+          then obtain n1 n2 where
+            w_n1_n2: "l = Oc \<up> (Suc n1) \<and> r2 = Oc \<up> n2 @ [Bk] @ (<ns::nat list>) \<and> Suc n1 + n2 = Suc n" by blast
+          show ?thesis
+          proof (cases n2)
+            case 0
+            then have "n2 = 0" .
+            with w_n1_n2 have "r2 = [Bk] @ (<ns::nat list>)" by auto
+            with \<open>steps0 (1, [],Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (2, l, r2)\<close>
+            have "steps0 (1, [],Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (2, l, [Bk] @ (<ns::nat list>))"
+              by auto
+
+            with SUC_STEP_RED
+            have "steps0 (1, [],Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg (Suc stp) =
+                step0 (2, l, [Bk] @ (<ns::nat list>)) tm_skip_first_arg"
+              by auto
+            also have "... = (3,Bk#l,(<ns>))"
+              by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [],Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg (Suc stp) = (3,Bk#l,(<ns>))"
+              by auto
+
+            with \<open>steps0 (1, [],Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (2, l, [Bk] @ (<ns::nat list>))\<close>
+            show ?thesis           
+              by (auto simp add: measure_tm_skip_first_arg_len_gt_1_def)
+          next
+            case (Suc n2')
+            then have "n2 = Suc n2'" .
+            with w_n1_n2 have "r2 = Oc \<up> Suc n2'@Bk#(<ns>)" by auto
+
+            with \<open>steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (2, l, r2)\<close>
+            have "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (2, l, Oc \<up> Suc n2'@Bk#(<ns>))"
+              by auto
+
+            with SUC_STEP_RED
+            have "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg (Suc stp) =
+                step0 (2, l, Oc \<up> Suc n2'@Bk#(<ns>)) tm_skip_first_arg"
+              by auto
+            also have "... = (2,Oc#l,Oc \<up> n2'@Bk#(<ns>))"
+              by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg (Suc stp)
+                         = (2,Oc#l,Oc \<up> n2'@Bk#(<ns>))"
+              by auto
+
+            with \<open>steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (2, l, Oc \<up> Suc n2'@Bk#(<ns>))\<close>
+            show ?thesis           
+              by (auto simp add: measure_tm_skip_first_arg_len_gt_1_def)
+          qed
+        qed
+      next
+        assume "s=3"
+        show ?thesis
+        proof -
+          from cf_cases and \<open>s=3\<close>
+          have "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (3, l, r2)"
+            by auto
+
+          with cf_cases  and \<open>s=3\<close> and INV
+
+          have unpacked_INV: "l = Bk # Oc \<up> (Suc n) \<and> r2 = (<ns::nat list>)"
+            by auto
+          with \<open>steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (3, l, r2)\<close>
+
+          have "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (3,  Bk # Oc \<up> (Suc n), (<ns::nat list>))"
+            by auto
+
+          with SUC_STEP_RED
+          have "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg (Suc stp) =
+                step0 (3,  Bk # Oc \<up> (Suc n), (<ns::nat list>)) tm_skip_first_arg"
+            by auto
+
+          also have "... = (0, Bk # Oc \<up> (Suc n),(<ns::nat list>))"
+          proof -
+            from \<open>length ns > 0\<close> have "(ns::nat list) \<noteq> [] \<and> hd (<ns::nat list>) = Oc"
+              using numeral_list_head_is_Oc
+              by force
+            then have "<ns::nat list> = Oc#(tl (<ns::nat list>))"
+              by (metis append_Nil list.exhaust_sel tape_of_list_empty
+                  unique_Bk_postfix_numeral_list_Nil)
+
+            then have "step0 (3,  Bk # Oc \<up> (Suc n), (<ns::nat list>)) tm_skip_first_arg
+                     = step0 (3,  Bk # Oc \<up> (Suc n), Oc#(tl (<ns::nat list>))) tm_skip_first_arg"
+              by auto
+            also have "... = (0, Bk # Oc \<up> (Suc n), Oc#(tl (<ns::nat list>)))"
+              by (auto simp add: tm_skip_first_arg_def numeral_eqs_upto_12 step.simps steps.simps)
+            also with \<open><ns::nat list> = Oc#(tl (<ns::nat list>))\<close>
+            have "... = (0, Bk # Oc \<up> (Suc n), <ns::nat list>)"
+              by auto
+            finally show "step0 (3,  Bk # Oc \<up> (Suc n), (<ns::nat list>)) tm_skip_first_arg
+                     = (0, Bk # Oc \<up> (Suc n), <ns::nat list>)" by auto
+          qed
+          finally have "steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg (Suc stp) =
+                      (0, Bk # Oc \<up> (Suc n),(<ns::nat list>))"
+            by auto
+
+          with \<open>steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns>)) tm_skip_first_arg stp = (3,  Bk # Oc \<up> (Suc n), (<ns::nat list>))\<close>
+          show ?thesis
+            by (auto simp add: measure_tm_skip_first_arg_len_gt_1_def)
+        qed
+      qed
+    qed
+  qed
+qed
+
+lemma tm_skip_first_arg_len_gt_1_total_correctness_pre:
+  assumes "0 < length ns"
+  shows "\<lbrace>\<lambda>tap. tap = ([], Oc \<up> Suc n @ [Bk] @ (<ns::nat list>) ) \<rbrace> 
+           tm_skip_first_arg
+         \<lbrace> \<lambda>tap. tap = (Bk# Oc \<up> Suc n, (<ns::nat list>) ) \<rbrace>"
+proof (rule tm_skip_first_arg_len_gt_1_partial_correctness)
+  from assms show "0 < length ns" .
+  from assms show "\<exists>stp. is_final (steps0 (1, [], Oc \<up> Suc n @ [Bk] @ (<ns::nat list>) ) tm_skip_first_arg stp)"
+    using  tm_skip_first_arg_len_gt_1_halts by auto
+qed
+
+lemma tm_skip_first_arg_len_gt_1_total_correctness:
+  assumes "1 < length (nl::nat list)"
+  shows "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list> )\<rbrace> tm_skip_first_arg \<lbrace> \<lambda>tap. tap = (Bk# <rev [hd nl]>, <tl nl>) \<rbrace>"
+proof -
+  from assms have major: "(nl::nat list) = hd nl # tl nl"
+    by (metis list.exhaust_sel list.size(3)  not_one_less_zero)
+  from assms have "tl nl \<noteq> []"
+    using list_length_tl_neq_Nil by auto
+  from assms have "(nl::nat list) \<noteq> []" by auto
+
+  from \<open>(nl::nat list) = hd nl # tl nl\<close>
+  have "<nl::nat list> = <hd nl # tl nl>"
+    by auto
+  also with \<open>tl nl \<noteq> []\<close> have "... = <hd nl> @ [Bk] @ (<tl nl>)"
+    by (simp add:  tape_of_nat_list_cons_eq)
+  also with \<open>(nl::nat list) \<noteq> []\<close> have "... = Oc \<up> Suc (hd nl) @ [Bk] @ (<tl nl>)"
+    using tape_of_nat_def by blast
+  finally have "<nl::nat list> = Oc \<up> Suc (hd nl) @ [Bk] @ (<tl nl>)"
+    by auto
+
+  from \<open>tl nl \<noteq> []\<close> have "0 < length (tl nl)"
+    using length_greater_0_conv by blast
+  with assms have 
+    "\<lbrace>\<lambda>tap. tap = ([], Oc \<up> Suc (hd nl) @ [Bk] @ (<tl nl>) ) \<rbrace> 
+           tm_skip_first_arg
+     \<lbrace> \<lambda>tap. tap = (Bk# Oc \<up> Suc (hd nl), (<tl nl>) ) \<rbrace>"
+    using tm_skip_first_arg_len_gt_1_total_correctness_pre
+    by force
+  with \<open><nl::nat list> = Oc \<up> Suc (hd nl) @ [Bk] @ (<tl nl>)\<close> have 
+    "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list> ) \<rbrace> 
+           tm_skip_first_arg
+     \<lbrace> \<lambda>tap. tap = (Bk# Oc \<up> Suc (hd nl), (<tl nl>) ) \<rbrace>"
+    by force
+  moreover have "<rev [hd nl]> = Oc \<up> Suc (hd nl)"
+    by (simp add: tape_of_list_def tape_of_nat_def)
+  ultimately 
+  show ?thesis
+    by (simp add: rev_numeral rev_numeral_list tape_of_list_def )
+qed
+
+(* ---------- tm_erase_right_then_dblBk_left ---------- *)
+
+(* We will prove:
+
+-- DO_NOTHING path, the eraser should do nothing
+
+lemma tm_erase_right_then_dblBk_left_dnp_total_correctness:
+ "\<lbrace> \<lambda>tap. tap = ([], r ) \<rbrace> 
+    tm_erase_right_then_dblBk_left
+  \<lbrace> \<lambda>tap. tap = ([Bk,Bk], r ) \<rbrace>"
+
+-- ERASE path
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_one_arg:
+  assumes "1 \<le> length (nl::nat list)"
+  shows "\<lbrace> \<lambda>tap. tap = (Bk# rev(<hd nl>), <tl nl>) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ (<hd nl>) @ [Bk] @ Bk \<up> rex ) \<rbrace>"
+
+*)
+
+(* Test runs for the formulation of invariants:
+ *
+ * See file EngineeringOf_StrongCopy2.hs for more test runs
+ *
+
+ctxrunTM tm_erase_right_then_dblBk_left (1, [Bk,Oc], [Oc])
+0: [Bk,Oc] _1_ [Oc]
+=> 
+1: [Oc] _2_ [Bk,Oc]
+=> 
+2: [] _3_ [Oc,Bk,Oc]
+=> 
+3: [Oc] _5_ [Bk,Oc]
+=> 
+4: [Bk,Oc] _6_ [Oc]
+=> 
+5: [Bk,Oc] _6_ [Bk]
+=> 
+6: [Bk,Bk,Oc] _7_ []
+=> 
+7: [Bk,Bk,Bk,Oc] _9_ []
+=> 
+8: [Bk,Bk,Oc] _10_ [Bk]
+=> 
+9: [Bk,Oc] _10_ [Bk,Bk]
+=> 
+10: [Oc] _10_ [Bk,Bk,Bk]
+=> 
+11: [] _10_ [Oc,Bk,Bk,Bk]
+=> 
+12: [] _11_ [Bk,Oc,Bk,Bk,Bk]
+=> 
+13: [] _12_ [Bk,Bk,Oc,Bk,Bk,Bk]
+=> 
+14: [] _0_ [Bk,Bk,Oc,Bk,Bk,Bk]
+
+ctxrunTM tm_erase_right_then_dblBk_left (1, [Bk,Oc,Oc], [Oc,Oc,Oc])
+0: [Bk,Oc,Oc] _1_ [Oc,Oc,Oc]
+=>
+1: [Oc,Oc] _2_ [Bk,Oc,Oc,Oc]
+=>
+2: [Oc] _3_ [Oc,Bk,Oc,Oc,Oc]
+=>
+3: [Oc,Oc] _5_ [Bk,Oc,Oc,Oc]
+=>
+4: [Bk,Oc,Oc] _6_ [Oc,Oc,Oc]
+=>
+5: [Bk,Oc,Oc] _6_ [Bk,Oc,Oc]
+=>
+6: [Bk,Bk,Oc,Oc] _7_ [Oc,Oc]
+=>
+7: [Bk,Bk,Oc,Oc] _8_ [Bk,Oc]
+=>
+8: [Bk,Bk,Bk,Oc,Oc] _7_ [Oc]
+=>
+9: [Bk,Bk,Bk,Oc,Oc] _8_ [Bk]
+=>
+10: [Bk,Bk,Bk,Bk,Oc,Oc] _7_ []
+=>
+11: [Bk,Bk,Bk,Bk,Bk,Oc,Oc] _9_ []
+=>
+12: [Bk,Bk,Bk,Bk,Oc,Oc] _10_ [Bk]
+=>
+13: [Bk,Bk,Bk,Oc,Oc] _10_ [Bk,Bk]
+=>
+14: [Bk,Bk,Oc,Oc] _10_ [Bk,Bk,Bk]
+=>
+15: [Bk,Oc,Oc] _10_ [Bk,Bk,Bk,Bk]
+=>
+16: [Oc,Oc] _10_ [Bk,Bk,Bk,Bk,Bk]
+=>
+17: [Oc] _10_ [Oc,Bk,Bk,Bk,Bk,Bk]
+=>
+18: [] _11_ [Oc,Oc,Bk,Bk,Bk,Bk,Bk]
+=>
+19: [] _11_ [Bk,Oc,Oc,Bk,Bk,Bk,Bk,Bk]
+=>
+20: [] _12_ [Bk,Bk,Oc,Oc,Bk,Bk,Bk,Bk,Bk]
+=>
+21: [] _0_ [Bk,Bk,Oc,Oc,Bk,Bk,Bk,Bk,Bk]
+
+ *)
+
+(*  Commented definition of tm_erase_right_then_dblBk_left
+
+let
+tm_erase_right_then_dblBk_left = from_raw [
+  -- 'check the left tape':
+  (L, 2),(L, 2), -- 1   one step left
+  (L, 3),(R, 5), -- 2   on Bk do one more step left, on Oc right towards 'check the right tape'
+  (R, 4),(R, 5), -- 3   on 2nd Bk right to towards termination, on Oc right towards 'check the right tape'
+  (R, 0),(R, 0), -- 4   one step right and terminate
+  (R, 6),(R, 6), -- 5   one more step right to erase path
+  -- 'check the right tape':
+  (R, 7),(WB,6), -- 6   on Bk goto loop 'erase all to the right', on Oc erase
+  --
+  (R, 9),(WB,8), -- 7   loop 'erase all to the right': on Bk leave loop, on Oc erase
+  (R, 7),(R, 7), -- 8   move right and continue loop 'erase all to the right'
+  (L,10),(WB,8), -- 9   on 2nd Bk start loop 'move to left until Oc', on Oc continue 'erase all to the right'
+  --
+  (L,10),(L,11), -- 10  loop 'move to left until Oc': on Bk continue loop 'move to left until Oc', on Oc goto loop 'move left until DblBk'
+  --
+  (L,12),(L,11), -- 11  loop 'move left until DblBk': on 1st Bk move once more to the left, on Oc continue loop  'move left until DblBk' 
+  (WB,0),(L,11)  -- 12  on 2nd Bk stop, on Oc (possible in generic case) continue loop 'move left until DblBk'
+  ]
+
+-- Note:
+-- In a more generic context, the 'move left until DblBk' may see an Oc in state 12.
+-- However, in our context of tm_check_for_one_arg there cannot be an Oc in state 12.
+
+*)
+
+definition 
+  tm_erase_right_then_dblBk_left :: "instr list"
+  where
+    "tm_erase_right_then_dblBk_left \<equiv>
+    [ (L, 2),(L, 2),
+      (L, 3),(R, 5),
+      (R, 4),(R, 5),
+      (R, 0),(R, 0),
+      (R, 6),(R, 6),
+      
+      (R, 7),(WB,6),
+      (R, 9),(WB,8),
+
+      (R, 7),(R, 7),
+      (L,10),(WB,8),
+
+      (L,10),(L,11),
+
+      (L,12),(L,11),
+      (WB,0),(L,11)
+    ]"
+
+
+(* Partial and total correctness for tm_erase_right_then_dblBk_left
+ *
+ * The leading 2 symbols on the left tape are used to differentiate!
+ *
+ * [Bk,Bk] \<longrightarrow> DO NOTHING path
+ * [Bk,Oc] \<longrightarrow> ERASE path
+ *
+*)
+
+(* ----------------------------------------------------------------- *)
+(* DO NOTHING path tm_erase_right_then_dblBk_left_dnp                *)
+(* Sequence of states on the DO NOTHING path: 1,2,3 then 4, 0        *)
+(* ----------------------------------------------------------------- *)
+(*
+ *   "\<lbrace> \<lambda>tap. tap = ([], r ) \<rbrace> 
+ *      tm_erase_right_then_dblBk_left
+ *    \<lbrace> \<lambda>tap. tap = ([Bk,Bk], r ) \<rbrace>"
+ *)
+
+(* Definition of invariants for the DO_NOTHING path *)
+
+fun
+  inv_tm_erase_right_then_dblBk_left_dnp_s0 :: "(cell list) \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_erase_right_then_dblBk_left_dnp_s1 :: "(cell list) \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_erase_right_then_dblBk_left_dnp_s2 :: "(cell list) \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_erase_right_then_dblBk_left_dnp_s3 :: "(cell list) \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_tm_erase_right_then_dblBk_left_dnp_s4 :: "(cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_dnp_s0 CR (l, r) = (l = [Bk, Bk] \<and> CR = r)"
+  | "inv_tm_erase_right_then_dblBk_left_dnp_s1 CR (l, r) = (l = []       \<and> CR = r)"
+  | "inv_tm_erase_right_then_dblBk_left_dnp_s2 CR (l, r) = (l = []       \<and> r = Bk#CR)"
+  | "inv_tm_erase_right_then_dblBk_left_dnp_s3 CR (l, r) = (l = []       \<and> r = Bk#Bk#CR)"
+  | "inv_tm_erase_right_then_dblBk_left_dnp_s4 CR (l, r) = (l = [Bk]     \<and> r = Bk#CR)"
+
+
+fun inv_tm_erase_right_then_dblBk_left_dnp :: "(cell list) \<Rightarrow> config \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_dnp CR (s, tap) = 
+        (if s = 0 then inv_tm_erase_right_then_dblBk_left_dnp_s0 CR tap else
+         if s = 1 then inv_tm_erase_right_then_dblBk_left_dnp_s1 CR tap else
+         if s = 2 then inv_tm_erase_right_then_dblBk_left_dnp_s2 CR tap else
+         if s = 3 then inv_tm_erase_right_then_dblBk_left_dnp_s3 CR tap else
+         if s = 4 then inv_tm_erase_right_then_dblBk_left_dnp_s4 CR tap
+         else False)"
+
+lemma tm_erase_right_then_dblBk_left_dnp_cases: 
+  fixes s::nat
+  assumes "inv_tm_erase_right_then_dblBk_left_dnp CR (s,l,r)"
+    and "s=0 \<Longrightarrow> P"
+    and "s=1 \<Longrightarrow> P"
+    and "s=2 \<Longrightarrow> P"
+    and "s=3 \<Longrightarrow> P"
+    and "s=4 \<Longrightarrow> P"
+  shows "P"
+proof -
+  have "s < 5"
+  proof (rule ccontr)
+    assume "\<not> s < 5"
+    with \<open>inv_tm_erase_right_then_dblBk_left_dnp CR (s,l,r)\<close> show False by auto
+  qed
+  then have "s = 0 \<or> s = 1 \<or> s = 2 \<or> s = 3  \<or> s = 4" by auto
+  with assms show ?thesis by auto
+qed
+
+lemma inv_tm_erase_right_then_dblBk_left_dnp_step: 
+  assumes "inv_tm_erase_right_then_dblBk_left_dnp CR cf" 
+  shows "inv_tm_erase_right_then_dblBk_left_dnp CR (step0 cf tm_erase_right_then_dblBk_left)"
+proof (cases cf)
+  case (fields s l r)
+  then have cf_cases: "cf = (s, l, r)" .
+  show "inv_tm_erase_right_then_dblBk_left_dnp CR (step0 cf tm_erase_right_then_dblBk_left)"
+  proof (rule tm_erase_right_then_dblBk_left_dnp_cases)
+    from cf_cases and assms
+    show "inv_tm_erase_right_then_dblBk_left_dnp CR (s, l, r)" by auto
+  next
+    assume "s = 0"
+    with cf_cases and assms
+    show ?thesis by (auto simp add: tm_erase_right_then_dblBk_left_def)
+  next
+    assume "s = 1"
+    with cf_cases and assms
+    have "l = []"
+      by auto
+    show ?thesis
+    proof (cases r)
+      case Nil
+      then have "r = []" .
+      with assms and cf_cases and \<open>s = 1\<close> show ?thesis
+        by (auto simp add: tm_erase_right_then_dblBk_left_def step.simps steps.simps)
+    next
+      case (Cons a rs)
+      then have "r = a # rs" .
+      show ?thesis
+      proof (cases a)
+        case Bk
+        with assms and cf_cases and \<open>s = 1\<close> and \<open>r = a # rs\<close> show ?thesis
+          by (auto simp add: tm_erase_right_then_dblBk_left_def step.simps steps.simps)
+      next
+        case Oc
+        with assms and cf_cases and \<open>s = 1\<close> and \<open>r = a # rs\<close> show ?thesis
+          by (auto simp add: tm_erase_right_then_dblBk_left_def step.simps steps.simps)
+      qed
+    qed
+  next
+    assume "s = 2"
+    with cf_cases and assms
+    have "l = [] \<and> r = Bk#CR" by auto
+
+    then have "step0 (2, [], Bk#CR) tm_erase_right_then_dblBk_left = (3, [], Bk# Bk # CR)"
+      by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+    moreover have "inv_tm_erase_right_then_dblBk_left_dnp CR (3, [], Bk# Bk # CR)"
+    proof -
+      from \<open>l = [] \<and> r = Bk#CR\<close>
+      show "inv_tm_erase_right_then_dblBk_left_dnp CR (3, [], Bk# Bk # CR)" by auto
+    qed
+
+    ultimately show ?thesis
+      using  assms and cf_cases and \<open>s = 2\<close> and \<open>l = [] \<and> r = Bk#CR\<close>
+      by auto
+  next
+    assume "s = 3"
+    with cf_cases and assms
+    have "l = [] \<and> r = Bk#Bk#CR"
+      by auto
+
+    then have "step0 (3, [], Bk#Bk#CR) tm_erase_right_then_dblBk_left = (4, [Bk], Bk # CR)"
+      by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+    moreover have "inv_tm_erase_right_then_dblBk_left_dnp CR (4, [Bk], Bk # CR)"
+    proof -
+      from \<open>l = [] \<and> r = Bk#Bk#CR\<close>
+      show "inv_tm_erase_right_then_dblBk_left_dnp CR (4, [Bk], Bk # CR)" by auto
+    qed
+
+    ultimately show ?thesis
+      using  assms and cf_cases and \<open>s = 3\<close> and \<open>l = [] \<and> r = Bk#Bk#CR\<close>
+      by auto
+  next
+    assume "s = 4"
+    with cf_cases and assms
+    have "l = [Bk] \<and> r = Bk#CR"
+      by auto
+
+    then have "step0 (4, [Bk], Bk#CR) tm_erase_right_then_dblBk_left = (0, [Bk,Bk], CR)"
+      by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+    moreover have "inv_tm_erase_right_then_dblBk_left_dnp CR (0, [Bk,Bk], CR)"
+    proof -
+      from \<open>l = [Bk] \<and> r = Bk#CR\<close>
+      show "inv_tm_erase_right_then_dblBk_left_dnp  CR (0, [Bk,Bk], CR)" by auto
+    qed
+
+    ultimately show ?thesis
+      using  assms and cf_cases and \<open>s = 4\<close> and \<open>l = [Bk] \<and> r = Bk#CR\<close>
+      by auto
+  qed
+qed
+
+lemma inv_tm_erase_right_then_dblBk_left_dnp_steps: 
+  assumes "inv_tm_erase_right_then_dblBk_left_dnp CR cf" 
+  shows "inv_tm_erase_right_then_dblBk_left_dnp CR (steps0 cf tm_erase_right_then_dblBk_left stp)"
+proof (induct stp)
+  case 0
+  with assms show ?case
+    by (auto simp add: inv_tm_erase_right_then_dblBk_left_dnp_step step.simps steps.simps)
+next
+  case (Suc stp)
+  with assms show ?case
+    using inv_tm_erase_right_then_dblBk_left_dnp_step step_red by auto 
+qed
+
+
+lemma tm_erase_right_then_dblBk_left_dnp_partial_correctness:
+  assumes "\<exists>stp. is_final (steps0 (1, [], r) tm_erase_right_then_dblBk_left stp)"
+  shows "\<lbrace> \<lambda>tap. tap = ([], r ) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. tap = ([Bk,Bk], r ) \<rbrace>"
+proof (rule Hoare_consequence)
+  show "(\<lambda>tap. tap = ([], r) ) \<mapsto> (\<lambda>tap. tap = ([], r) )"
+    by auto
+next
+  show "inv_tm_erase_right_then_dblBk_left_dnp_s0 r  \<mapsto> (\<lambda>tap. tap = ([Bk,Bk], r ))"
+    by (simp add: assert_imp_def  tape_of_list_def tape_of_nat_def)
+next
+  show "\<lbrace>\<lambda>tap. tap = ([], r)\<rbrace>
+         tm_erase_right_then_dblBk_left
+        \<lbrace>inv_tm_erase_right_then_dblBk_left_dnp_s0 r \<rbrace>"
+  proof (rule Hoare_haltI)
+    fix l::"cell list"
+    fix r'':: "cell list"
+    assume major: "(l, r'') = ([], r)"
+    show "\<exists>stp. is_final (steps0 (1, l, r'') tm_erase_right_then_dblBk_left stp) \<and>
+                inv_tm_erase_right_then_dblBk_left_dnp_s0 r holds_for steps0 (1, l, r'') tm_erase_right_then_dblBk_left stp"
+    proof -
+      from major and assms have "\<exists>stp. is_final (steps0 (1, l, r'') tm_erase_right_then_dblBk_left stp)" by auto
+      then obtain stp where
+        w_stp: "is_final (steps0 (1, l, r'') tm_erase_right_then_dblBk_left stp)" by blast
+
+      moreover have "inv_tm_erase_right_then_dblBk_left_dnp_s0 r holds_for steps0 (1, l, r'') tm_erase_right_then_dblBk_left stp"
+      proof -
+        have "inv_tm_erase_right_then_dblBk_left_dnp r (1, l, r'')"
+          by (simp add: major tape_of_list_def tape_of_nat_def)
+
+        then have "inv_tm_erase_right_then_dblBk_left_dnp r (steps0 (1, l, r'') tm_erase_right_then_dblBk_left stp)"
+          using inv_tm_erase_right_then_dblBk_left_dnp_steps by auto
+
+        then show ?thesis
+          by (smt holds_for.elims(3) inv_tm_erase_right_then_dblBk_left_dnp.simps is_final_eq w_stp)
+      qed
+      ultimately show ?thesis by auto
+    qed
+  qed
+qed
+
+(* Total correctness of tm_erase_right_then_dblBk_left for DO NOTHING path *)
+
+(* Assemble a lexicographic measure function  for the DO NOTHING path *)
+
+definition measure_tm_erase_right_then_dblBk_left_dnp :: "(config \<times> config) set"
+  where
+    "measure_tm_erase_right_then_dblBk_left_dnp = measures [
+      \<lambda>(s, l, r). (if s = 0 then 0 else 5 - s)
+      ]"
+
+lemma wf_measure_tm_erase_right_then_dblBk_left_dnp: "wf measure_tm_erase_right_then_dblBk_left_dnp"
+  unfolding measure_tm_erase_right_then_dblBk_left_dnp_def
+  by (auto)
+
+lemma measure_tm_erase_right_then_dblBk_left_dnp_induct [case_names Step]: 
+  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_tm_erase_right_then_dblBk_left_dnp\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
+  using wf_measure_tm_erase_right_then_dblBk_left_dnp
+  by (metis wf_iff_no_infinite_down_chain)
+
+
+lemma tm_erase_right_then_dblBk_left_dnp_halts:
+  "\<exists>stp. is_final (steps0 (1, [], r) tm_erase_right_then_dblBk_left stp)"
+proof (induct rule: measure_tm_erase_right_then_dblBk_left_dnp_induct)
+  case (Step stp)
+  then have not_final: "\<not> is_final (steps0 (1, [], r) tm_erase_right_then_dblBk_left stp)" .
+
+  have INV: "inv_tm_erase_right_then_dblBk_left_dnp r (steps0 (1, [], r) tm_erase_right_then_dblBk_left stp)"
+  proof (rule_tac inv_tm_erase_right_then_dblBk_left_dnp_steps)
+    show  "inv_tm_erase_right_then_dblBk_left_dnp r (1, [], r)"
+      by (simp add: tape_of_list_def tape_of_nat_def  )
+  qed
+
+  have SUC_STEP_RED: "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =
+        step0 (steps0 (1, [], r) tm_erase_right_then_dblBk_left stp) tm_erase_right_then_dblBk_left"
+    by (rule step_red)
+
+  show "( steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp),
+          steps0 (1, [], r) tm_erase_right_then_dblBk_left stp
+        ) \<in> measure_tm_erase_right_then_dblBk_left_dnp"
+
+  proof (cases "steps0 (1, [], r) tm_erase_right_then_dblBk_left stp")
+    case (fields s l r2)
+    then have
+      cf_cases: "steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (s, l, r2)" .
+    show ?thesis
+    proof (rule tm_erase_right_then_dblBk_left_dnp_cases)
+      from INV and cf_cases
+      show "inv_tm_erase_right_then_dblBk_left_dnp r (s, l, r2)" by auto
+    next
+      assume "s=0" (* not possible *)
+      with cf_cases not_final
+      show ?thesis by auto
+    next
+      assume "s=1"
+      show ?thesis
+      proof (cases r)
+        case Nil
+        then have "r = []" .
+        from cf_cases and \<open>s=1\<close>
+        have "steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (1, l, r2)"
+          by auto
+        with cf_cases  and \<open>s=1\<close> and INV
+        have "l = [] \<and> r = r2"
+          by auto          
+        with cf_cases and \<open>s=1\<close> and SUC_STEP_RED
+        have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (1, [],  r) tm_erase_right_then_dblBk_left"
+          by auto
+        also with \<open>r = []\<close> and \<open>l = [] \<and> r = r2\<close> have "... = (2,[],Bk#r2)"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+
+        finally have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =  (2,[],Bk#r2)"
+          by auto
+
+        with \<open>steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (1, l, r2)\<close>
+        show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_dnp_def)
+      next
+        case (Cons a rs)
+        then have "r = a # rs" .
+        then show ?thesis
+        proof (cases a)
+          case Bk
+          then have "a = Bk" .
+          from cf_cases and \<open>s=1\<close>
+          have "steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (1, l, r2)"
+            by auto
+          with cf_cases  and \<open>s=1\<close> and INV
+          have "l = [] \<and> r = r2"
+            by auto          
+          with cf_cases and \<open>s=1\<close> and SUC_STEP_RED
+          have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (1, [],  r) tm_erase_right_then_dblBk_left"
+            by auto
+          also with \<open>r = a # rs\<close> and \<open>a=Bk\<close> and \<open>l = [] \<and> r = r2\<close> have "... = (2,[],Bk#r2)"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+
+          finally have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =  (2,[],Bk#r2)"
+            by auto
+
+          with \<open>steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (1, l, r2)\<close>
+          show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_dnp_def)
+        next
+          case Oc
+          then have "a = Oc" .
+          from cf_cases and \<open>s=1\<close>
+          have "steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (1, l, r2)"
+            by auto
+          with cf_cases  and \<open>s=1\<close> and INV
+          have "l = [] \<and> r = r2"
+            by auto          
+          with cf_cases and \<open>s=1\<close> and SUC_STEP_RED
+          have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (1, [],  r) tm_erase_right_then_dblBk_left"
+            by auto
+          also with \<open>r = a # rs\<close> and \<open>a=Oc\<close> and \<open>l = [] \<and> r = r2\<close> have "... = (2,[],Bk#r2)"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+
+          finally have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =  (2,[],Bk#r2)"
+            by auto
+
+          with \<open>steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (1, l, r2)\<close>
+          show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_dnp_def)
+        qed
+      qed
+    next
+      assume "s=2"
+      with cf_cases
+      have "steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (2, l, r2)"
+        by auto
+
+      with cf_cases  and \<open>s=2\<close> and INV
+      have "(l = []       \<and> r2 = Bk#r)"
+        by auto      
+
+      with cf_cases and \<open>s=2\<close> and SUC_STEP_RED
+      have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (2, l,  r2) tm_erase_right_then_dblBk_left"
+        by auto
+
+      also with \<open>s=2\<close> and \<open>(l = []       \<and> r2 = Bk#r)\<close> have "... = (3,[],Bk#r2)"
+        by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+
+      finally have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =  (3,[],Bk#r2)"
+        by auto
+
+      with \<open>steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (2, l, r2)\<close>
+      show ?thesis
+        by (auto simp add: measure_tm_erase_right_then_dblBk_left_dnp_def)
+    next
+      assume "s=3"
+      with cf_cases
+      have "steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (3, l, r2)"
+        by auto
+
+      with cf_cases  and \<open>s=3\<close> and INV
+      have "(l = []       \<and> r2 = Bk#Bk#r)"
+        by auto      
+
+      with cf_cases and \<open>s=3\<close> and SUC_STEP_RED
+      have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (3, l,  r2) tm_erase_right_then_dblBk_left"
+        by auto
+
+      also with \<open>s=3\<close> and \<open>(l = []       \<and> r2 = Bk#Bk#r)\<close> have "... = (4,[Bk],Bk#r)"
+        by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+
+      finally have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =  (4,[Bk],Bk#r)"
+        by auto
+
+      with \<open>steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (3, l, r2)\<close>
+      show ?thesis
+        by (auto simp add: measure_tm_erase_right_then_dblBk_left_dnp_def)
+    next
+      assume "s=4"
+      with cf_cases
+      have "steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (4, l, r2)"
+        by auto
+
+      with cf_cases  and \<open>s=4\<close> and INV
+      have "(l = [Bk]       \<and> r2 = Bk#r)"
+        by auto      
+
+      with cf_cases and \<open>s=4\<close> and SUC_STEP_RED
+      have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (4, l,  r2) tm_erase_right_then_dblBk_left"
+        by auto
+
+      also with \<open>s=4\<close> and \<open>(l = [Bk]       \<and> r2 = Bk#r)\<close> have "... = (0,[Bk,Bk],r)"
+        by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+
+      finally have "steps0 (1, [], r) tm_erase_right_then_dblBk_left (Suc stp) =  (0,[Bk,Bk],r)"
+        by auto
+
+      with \<open>steps0 (1, [], r) tm_erase_right_then_dblBk_left stp = (4, l, r2)\<close>
+      show ?thesis
+        by (auto simp add: measure_tm_erase_right_then_dblBk_left_dnp_def)
+    qed
+  qed
+qed
+
+lemma tm_erase_right_then_dblBk_left_dnp_total_correctness:
+ "\<lbrace> \<lambda>tap. tap = ([], r ) \<rbrace> 
+    tm_erase_right_then_dblBk_left
+  \<lbrace> \<lambda>tap. tap = ([Bk,Bk], r ) \<rbrace>"
+proof (rule tm_erase_right_then_dblBk_left_dnp_partial_correctness)
+  show "\<exists>stp. is_final (steps0 (1, [], r) tm_erase_right_then_dblBk_left stp)"
+    using  tm_erase_right_then_dblBk_left_dnp_halts by auto
+qed
+
+(* ----------------------------------------------------------------- *)
+(* ERASE path tm_erase_right_then_dblBk_left_erp                     *)
+(* Sequence of states on the      ERASE path: 1,2,3 then 5...        *)
+(* ----------------------------------------------------------------- *)
+(*
+ *        \<lbrace> \<lambda>tap. tap = (Bk# rev(<hd nl>), <tl nl>) \<rbrace> 
+ *          tm_erase_right_then_dblBk_left
+ *        \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ (<hd nl>) @ [Bk] @ Bk \<up> rex ) \<rbrace>"
+ *)
+
+(* Definition of invariants for the ERASE path: had to split definitions *)
+
+fun inv_tm_erase_right_then_dblBk_left_erp_s1  :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s1  CL CR (l, r) =
+        (l = [Bk,Oc] @ CL \<and> r = CR)"
+fun inv_tm_erase_right_then_dblBk_left_erp_s2  :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s2  CL CR (l, r) = 
+        (l = [Oc]    @ CL \<and> r = Bk#CR)"
+fun inv_tm_erase_right_then_dblBk_left_erp_s3  :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s3  CL CR (l, r) = 
+        (l =           CL \<and> r = Oc#Bk#CR)"
+
+fun inv_tm_erase_right_then_dblBk_left_erp_s5  :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s5  CL CR (l, r) = 
+        (l = [Oc]    @ CL \<and> r = Bk#CR)"
+
+fun inv_tm_erase_right_then_dblBk_left_erp_s6  :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s6  CL CR (l, r) =
+        (l = [Bk,Oc] @ CL \<and> ( (CR = [] \<and> r = CR) \<or> (CR \<noteq> [] \<and> (r = CR \<or> r = Bk # tl CR)) )  )"
+
+(* ENHANCE: simplify invariant of s6 (simpler to use for proof by cases
+
+    "inv_tm_erase_right_then_dblBk_left_erp_s6  CL CR (l, r) =
+         (l = [Bk,Oc] @ CL \<and> CR = [] \<and> r = CR \<or>
+          l = [Bk,Oc] @ CL \<and> CR \<noteq> [] \<and> r = Oc # tl CR \<or>
+          l = [Bk,Oc] @ CL \<and> CR \<noteq> [] \<and> r = Bk # tl CR   )"
+*)
+
+fun inv_tm_erase_right_then_dblBk_left_erp_s7  :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s7  CL CR (l, r) =
+        ((\<exists>lex. l = Bk \<up> Suc lex @ [Bk,Oc] @ CL) \<and> (\<exists>rs. CR = rs @ r) )"
+
+fun inv_tm_erase_right_then_dblBk_left_erp_s8  :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s8  CL CR (l, r) = 
+        ((\<exists>lex. l = Bk \<up> Suc lex @ [Bk,Oc] @ CL) \<and>
+         (\<exists>rs1 rs2. CR = rs1 @ [Oc] @ rs2 \<and> r = Bk#rs2) )"
+
+fun inv_tm_erase_right_then_dblBk_left_erp_s9  :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s9  CL CR (l, r) = 
+        ((\<exists>lex. l = Bk \<up> Suc lex @ [Bk,Oc] @ CL) \<and> (\<exists>rs. CR = rs @ [Bk] @ r \<or> CR = rs \<and> r = []) )"
+
+fun inv_tm_erase_right_then_dblBk_left_erp_s10 :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s10  CL CR (l, r) = 
+        (
+          (\<exists>lex rex. l = Bk \<up> lex @ [Bk,Oc] @ CL \<and> r = Bk \<up> Suc rex) \<or>
+          (\<exists>rex. l = [Oc] @ CL \<and> r = Bk \<up> Suc rex) \<or>
+          (\<exists>rex. l = CL \<and> r = Oc # Bk \<up> Suc rex)
+        )"
+
+fun inv_tm_erase_right_then_dblBk_left_erp_s11 :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s11  CL CR (l, r) = 
+        (
+          (\<exists>rex.         l = []         \<and> r = Bk# rev CL    @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc))              \<or>
+
+          (\<exists>rex.         l = []         \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk ) \<or>
+          (\<exists>rex.         l = []         \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Oc ) \<or>
+
+          (\<exists>rex.         l = [Bk]       \<and> r = rev [Oc]      @ Oc # Bk \<up> Suc rex \<and> CL = [Oc, Bk]) \<or>
+
+          (\<exists>rex ls1 ls2. l = Bk#Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Bk#Oc#ls2 \<and> ls1 = [Oc] ) \<or>
+          (\<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Bk] ) \<or>
+          (\<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Oc] ) \<or>
+
+          (\<exists>rex ls1 ls2. l =       ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2       \<and> tl ls1 \<noteq> [])
+
+       )"
+
+(*
+
+YYYY1'    (\<exists>rex.         l =        []  \<and> r = Bk# rev CL    @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc) ) \<or>       (s11 \<longrightarrow> s11)                  
+
+YYYY2'    (\<exists>rex.         l =        []  \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> []  \<and> last CL = Bk) \<or>  (s11 \<longrightarrow> s11)
+YYYY2''   (\<exists>rex.         l =        []  \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> []  \<and> last CL = Oc) \<or>  (s11 \<longrightarrow> s11)
+
+YYYY5     (\<exists>rex.         l =      [Bk]  \<and> r = rev [Oc] @ Oc # Bk \<up> Suc rex \<and> CL = [Oc, Bk]) \<or>            (s10 \<longrightarrow> s11)
+
+YYYY6     (\<exists>rex ls1 ls2. l = Bk#Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Bk#Oc#ls2 \<and> ls1 = [Oc] ) \<or>                           (s10 \<longrightarrow> s11)
+YYYY3     (\<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Bk] ) \<or>                           (s10 \<longrightarrow> s11)
+YYYY7     (\<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Oc] ) \<or>                           (s10 \<longrightarrow> s11)
+YYYY8     (\<exists>rex ls1 ls2. l =       ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2       \<and> tl ls1 \<noteq> [])              (s11 \<longrightarrow> s11)
+
+*)
+
+fun inv_tm_erase_right_then_dblBk_left_erp_s12 :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s12  CL CR (l, r) = 
+        (
+          (\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2  \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc) \<or>
+
+          (\<exists>rex. l = []  \<and> r = Bk#rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk) \<or>
+          (\<exists>rex. l = []  \<and> r = Bk#Bk#rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc) ) \<or>
+          False
+        )"
+
+(*
+     YYYY4      (\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2  \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc)
+
+     YYYY6'''   (\<exists>rex. l = []  \<and> r = Bk#rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk)
+
+     YYYY9      (\<exists>rex. l = []  \<and> r = Bk#Bk#rev CL @ Oc # Bk \<up> Suc rex) \<or>
+
+*)
+
+fun inv_tm_erase_right_then_dblBk_left_erp_s0  :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp_s0  CL CR (l, r) =
+       (
+        (\<exists>rex. l = [] \<and>  r = [Bk, Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex \<and> (CL = [] \<or> last CL = Oc)  ) \<or>
+        (\<exists>rex. l = [] \<and>  r = [Bk]     @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex \<and>  CL \<noteq> [] \<and> last CL = Bk )
+       )"
+
+fun inv_tm_erase_right_then_dblBk_left_erp :: "(cell list) \<Rightarrow> (cell list) \<Rightarrow> config \<Rightarrow> bool"
+  where
+    "inv_tm_erase_right_then_dblBk_left_erp CL CR (s, tap) = 
+        (if s = 0 then inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR tap else
+         if s = 1 then inv_tm_erase_right_then_dblBk_left_erp_s1 CL CR tap else
+         if s = 2 then inv_tm_erase_right_then_dblBk_left_erp_s2 CL CR tap else
+         if s = 3 then inv_tm_erase_right_then_dblBk_left_erp_s3 CL CR tap else
+         if s = 5 then inv_tm_erase_right_then_dblBk_left_erp_s5 CL CR tap else
+         if s = 6 then inv_tm_erase_right_then_dblBk_left_erp_s6 CL CR tap else
+         if s = 7 then inv_tm_erase_right_then_dblBk_left_erp_s7 CL CR tap else
+         if s = 8 then inv_tm_erase_right_then_dblBk_left_erp_s8 CL CR tap else
+         if s = 9 then inv_tm_erase_right_then_dblBk_left_erp_s9 CL CR tap else
+         if s = 10 then inv_tm_erase_right_then_dblBk_left_erp_s10 CL CR tap else
+         if s = 11 then inv_tm_erase_right_then_dblBk_left_erp_s11 CL CR tap else
+         if s = 12 then inv_tm_erase_right_then_dblBk_left_erp_s12 CL CR tap
+         else False)"
+
+lemma tm_erase_right_then_dblBk_left_erp_cases: 
+  fixes s::nat
+  assumes "inv_tm_erase_right_then_dblBk_left_erp CL CR (s,l,r)"
+    and "s=0 \<Longrightarrow> P"
+    and "s=1 \<Longrightarrow> P"
+    and "s=2 \<Longrightarrow> P"
+    and "s=3 \<Longrightarrow> P"
+    and "s=5 \<Longrightarrow> P"
+    and "s=6 \<Longrightarrow> P"
+    and "s=7 \<Longrightarrow> P"
+    and "s=8 \<Longrightarrow> P"
+    and "s=9 \<Longrightarrow> P"
+    and "s=10 \<Longrightarrow> P"
+    and "s=11 \<Longrightarrow> P"
+    and "s=12 \<Longrightarrow> P"
+  shows "P"
+proof -
+  have "s < 4 \<or> 4 < s \<and> s < 13"
+  proof (rule ccontr)
+    assume "\<not> (s < 4 \<or> 4 < s \<and> s < 13)"
+    with \<open>inv_tm_erase_right_then_dblBk_left_erp CL CR (s,l,r)\<close> show False by auto
+  qed
+  then have "s = 0 \<or> s = 1 \<or> s = 2 \<or> s = 3  \<or> s = 5  \<or> s = 6 \<or> s = 7 \<or>
+             s = 8 \<or> s = 9 \<or> s = 10 \<or> s = 11 \<or> s = 12"
+    by arith
+  with assms show ?thesis by auto
+qed
+
+(* -------------- step - lemma for the invariants of the ERASE path of tm_erase_right_then_dblBk_left ------------------ *)
+
+lemma inv_tm_erase_right_then_dblBk_left_erp_step: 
+  assumes "inv_tm_erase_right_then_dblBk_left_erp CL CR cf"
+    and "noDblBk CL"
+    and "noDblBk CR"
+  shows "inv_tm_erase_right_then_dblBk_left_erp CL CR (step0 cf tm_erase_right_then_dblBk_left)"
+proof (cases cf)
+  case (fields s l r)
+  then have cf_cases: "cf = (s, l, r)" .
+  show "inv_tm_erase_right_then_dblBk_left_erp CL CR (step0 cf tm_erase_right_then_dblBk_left)"
+  proof (rule tm_erase_right_then_dblBk_left_erp_cases)
+    from cf_cases and assms
+    show "inv_tm_erase_right_then_dblBk_left_erp CL CR (s, l, r)" by auto
+  next
+    assume "s = 1"
+    with cf_cases and assms
+    have "(l = [Bk,Oc] @ CL \<and> r = CR)" by auto
+    show ?thesis
+    proof (cases r)
+      case Nil
+      then have "r = []" .
+      with assms and cf_cases and \<open>s = 1\<close> show ?thesis
+        by (auto simp add: tm_erase_right_then_dblBk_left_def step.simps steps.simps)
+    next
+      case (Cons a rs)
+      then have "r = a # rs" .
+      show ?thesis
+      proof (cases a)
+        case Bk
+        with assms and cf_cases and \<open>r = a # rs\<close> and \<open>s = 1\<close> show ?thesis
+          by (auto simp add: tm_erase_right_then_dblBk_left_def step.simps steps.simps)
+      next
+        case Oc
+        with assms and cf_cases and \<open>r = a # rs\<close> and \<open>s = 1\<close> show ?thesis
+          by (auto simp add: tm_erase_right_then_dblBk_left_def step.simps steps.simps)
+      qed
+    qed
+  next
+    assume "s = 2"
+    with cf_cases and assms
+    have "l = [Oc] @ CL \<and> r = Bk#CR" by auto
+
+    then have "step0 (2, [Oc]    @ CL, Bk#CR) tm_erase_right_then_dblBk_left = (3, CL, Oc# Bk # CR)"
+      by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+    moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (3, CL, Oc# Bk # CR)"
+      by auto
+
+    ultimately show ?thesis
+      using  assms and cf_cases and \<open>s = 2\<close> and \<open>l = [Oc] @ CL \<and> r = Bk#CR\<close>
+      by auto
+  next
+    assume "s = 3"
+    with cf_cases and assms
+    have "l = CL \<and> r = Oc#Bk#CR" by auto
+
+    then have "step0 (3, CL, Oc#Bk#CR) tm_erase_right_then_dblBk_left = (5, Oc#CL, Bk # CR)"
+      by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+    moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (5, Oc#CL, Bk # CR)"
+      by auto
+    ultimately show ?thesis
+      using  assms and cf_cases and \<open>s = 3\<close> and \<open>l = CL \<and> r = Oc#Bk#CR\<close>
+      by auto
+  next
+    assume "s = 5"
+    with cf_cases and assms
+    have "l = [Oc] @ CL \<and> r = Bk#CR" by auto
+
+    then have "step0 (5, [Oc] @ CL, Bk#CR) tm_erase_right_then_dblBk_left = (6, Bk#Oc#CL, CR)"
+      by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+    moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (6, Bk#Oc#CL, CR)"
+    proof (cases CR)
+      case Nil
+      then show ?thesis by auto
+    next
+      case (Cons a cs)
+      then have "CR = a # cs" .
+
+      with \<open>l = [Oc] @ CL \<and> r = Bk#CR\<close> and \<open>s = 5\<close> and \<open>CR = a # cs\<close>
+      have  "inv_tm_erase_right_then_dblBk_left_erp_s6 CL CR (Bk#Oc#CL, CR)"        
+        by simp
+      with \<open>s=5\<close> 
+      show "inv_tm_erase_right_then_dblBk_left_erp CL CR (6, Bk#Oc#CL, CR)"
+        by auto     
+    qed
+    ultimately show ?thesis
+      using  assms and cf_cases and \<open>s = 5\<close> and \<open>l = [Oc] @ CL \<and> r = Bk#CR\<close>
+      by auto
+  next
+    assume "s = 6"
+    with cf_cases and assms
+    have "l = [Bk,Oc] @ CL" and "( (CR = [] \<and> r = CR) \<or> (CR \<noteq> [] \<and> (r = CR \<or> r = Bk # tl CR)) )"
+      by auto
+    from \<open>( (CR = [] \<and> r = CR) \<or> (CR \<noteq> [] \<and> (r = CR \<or> r = Bk # tl CR)) )\<close> show ?thesis
+    proof 
+      assume "CR = [] \<and> r = CR"
+      have "step0 (6, [Bk,Oc] @ CL, []) tm_erase_right_then_dblBk_left = (7, Bk \<up> Suc 0 @ [Bk,Oc] @ CL, [])"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+      moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (7, Bk \<up> Suc 0 @ [Bk,Oc] @ CL, [])"
+        by auto
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 6\<close> and \<open>l = [Bk,Oc] @ CL\<close> and \<open>CR = [] \<and> r = CR\<close>
+        by auto
+    next
+      assume "CR \<noteq> [] \<and> (r = CR \<or> r = Bk # tl CR)"
+      then have "CR \<noteq> []" and "r = CR \<or> r = Bk # tl CR" by auto
+      from \<open>r = CR \<or> r = Bk # tl CR\<close>
+      show "inv_tm_erase_right_then_dblBk_left_erp CL CR (step0 cf tm_erase_right_then_dblBk_left)"
+      proof
+        assume "r = CR"
+        show "inv_tm_erase_right_then_dblBk_left_erp CL CR (step0 cf tm_erase_right_then_dblBk_left)"
+        proof (cases r)
+          case Nil
+          then have "r = []" .
+          then have "step0 (6, [Bk,Oc] @ CL, []) tm_erase_right_then_dblBk_left = (7, Bk \<up> Suc 0 @ [Bk,Oc] @ CL, [])"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+          moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (7, Bk \<up> Suc 0 @ [Bk,Oc] @ CL, [])"
+            by auto
+          ultimately show ?thesis
+            using  assms and cf_cases and \<open>s = 6\<close> and \<open>l = [Bk,Oc] @ CL\<close> and \<open>r = []\<close> 
+            by auto
+        next
+          case (Cons a rs')
+          then have "r = a # rs'" .
+          with \<open>r = CR\<close>  have "r = a # tl CR" by auto
+          show ?thesis
+          proof (cases a)
+            case Bk
+            then have "a = Bk" .
+            then have "step0 (6, [Bk,Oc] @ CL, Bk # tl CR) tm_erase_right_then_dblBk_left = (7, Bk \<up> Suc 0 @ [Bk,Oc] @ CL, tl CR)"
+              by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+            moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (7, Bk \<up> Suc 0 @ [Bk,Oc] @ CL, tl CR)"
+            proof -
+              from \<open>CR \<noteq> []\<close> and \<open>r = CR\<close> and \<open>a = Bk\<close> and \<open>r = a # tl CR\<close> and \<open>l = [Bk,Oc] @ CL\<close> 
+              have "inv_tm_erase_right_then_dblBk_left_erp_s7 CL CR (Bk \<up> Suc 0 @ [Bk,Oc] @ CL, tl CR)"                
+                by (metis append.left_neutral append_Cons  empty_replicate inv_tm_erase_right_then_dblBk_left_erp_s7.simps
+                    replicate_Suc )
+              then show "inv_tm_erase_right_then_dblBk_left_erp CL CR (7, Bk \<up> Suc 0 @ [Bk,Oc] @ CL, tl CR)" by auto
+            qed
+            ultimately show ?thesis
+              using \<open>CR \<noteq> []\<close> and \<open>r = CR\<close> and \<open>a = Bk\<close> and \<open>r = a # tl CR\<close> and \<open>l = [Bk,Oc] @ CL\<close> and \<open>s = 6\<close> and cf_cases
+              by auto
+          next
+            case Oc
+            then have "a = Oc" .
+            then have "step0 (6, [Bk,Oc] @ CL, Oc # rs') tm_erase_right_then_dblBk_left = (6, [Bk,Oc] @ CL, Bk # rs')"
+              by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+            moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (6, [Bk,Oc] @ CL, Bk # rs')"
+            proof -
+              from \<open>CR \<noteq> []\<close> and \<open>r = CR\<close> and \<open>a = Oc\<close> and \<open>r = a # tl CR\<close> and \<open>l = [Bk,Oc] @ CL\<close> 
+              have "inv_tm_erase_right_then_dblBk_left_erp_s6 CL CR ([Bk,Oc] @ CL, Bk # rs')"
+                using inv_tm_erase_right_then_dblBk_left_erp_s6.simps list.sel(3) local.Cons by blast
+              then show "inv_tm_erase_right_then_dblBk_left_erp CL CR (6, [Bk,Oc] @ CL, Bk # rs')"
+                by auto
+            qed
+            ultimately show ?thesis
+              using \<open>CR \<noteq> []\<close> and \<open>r = CR\<close> and \<open>a = Oc\<close> and \<open>r = a # tl CR\<close> and \<open>l = [Bk,Oc] @ CL\<close> and \<open>s = 6\<close> and cf_cases
+              by auto
+          qed
+        qed
+      next
+        assume "r = Bk # tl CR"
+
+        have "step0 (6, [Bk,Oc] @ CL, Bk # tl CR) tm_erase_right_then_dblBk_left = (7, Bk \<up> Suc 0 @ [Bk,Oc] @ CL, tl CR)"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+        moreover with \<open>CR \<noteq> []\<close> and \<open>r = Bk # tl CR\<close>
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (7, Bk \<up> Suc 0 @ [Bk,Oc] @ CL, tl CR)"
+        proof -
+          have "(\<exists>lex. Bk \<up> Suc 0 @ [Bk,Oc] @ CL = Bk \<up> Suc lex @ [Bk,Oc] @ CL) " by blast
+          moreover with \<open>CR \<noteq> []\<close> have "(\<exists>rs. CR = rs @ tl CR)"
+            by (metis append_Cons append_Nil list.exhaust list.sel(3))
+          ultimately 
+          show "inv_tm_erase_right_then_dblBk_left_erp CL CR (7, Bk \<up> Suc 0 @ [Bk,Oc] @ CL, tl CR)"
+            by auto
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 6\<close> and \<open>CR \<noteq> []\<close> and \<open>r = Bk # tl CR\<close> and \<open>l = [Bk,Oc] @ CL\<close> and cf_cases        
+          by auto
+      qed
+    qed
+  next
+    assume "s = 7"
+    with cf_cases and assms
+    have "(\<exists>lex. l = Bk \<up> Suc lex @ [Bk,Oc] @ CL) \<and> (\<exists>rs. CR = rs @ r)" by auto
+    then obtain lex rs where
+      w_lex_rs: "l = Bk \<up> Suc lex @ [Bk,Oc] @ CL \<and> CR = rs @ r" by blast
+    show ?thesis
+    proof (cases r)
+      case Nil
+      then have "r=[]" .
+      with w_lex_rs have "CR = rs" by auto
+      have "step0 (7, Bk \<up> Suc lex @ [Bk,Oc] @ CL, []) tm_erase_right_then_dblBk_left =
+             (9, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, [])"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover with \<open>CR = rs\<close>
+      have "inv_tm_erase_right_then_dblBk_left_erp CL CR (9, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, [])"
+      proof -
+        have "(\<exists>lex'. Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL = Bk \<up> Suc lex' @ [Bk,Oc] @ CL)" by blast
+        moreover have "\<exists>rs. CR = rs" by auto
+        ultimately
+        show "inv_tm_erase_right_then_dblBk_left_erp CL CR (9, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, [])"
+          by auto
+      qed
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 7\<close> and w_lex_rs and \<open>CR = rs\<close> and \<open>r=[]\<close>
+        by auto
+    next
+      case (Cons a rs')
+      then have "r = a # rs'" .
+      show ?thesis
+      proof (cases a)
+        case Bk
+        then have "a = Bk" .
+        with w_lex_rs and \<open>r = a # rs'\<close> have "CR = rs@(Bk#rs')" by auto
+
+        have "step0 (7, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs') tm_erase_right_then_dblBk_left = (9, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, rs')"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+        moreover with \<open>CR = rs@(Bk#rs')\<close>
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (9, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, rs')"
+        proof -
+          have "(\<exists>lex'. Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL = Bk \<up> Suc lex' @ [Bk,Oc] @ CL)" by blast
+          moreover with \<open>r = a # rs'\<close> and \<open>a = Bk\<close> and \<open>CR = rs@(Bk#rs')\<close> have "\<exists>rs. CR = rs @ [Bk] @ rs'" by auto
+          ultimately
+          show "inv_tm_erase_right_then_dblBk_left_erp CL CR (9, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, rs')"
+            by auto
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 7\<close> and w_lex_rs and \<open>a = Bk\<close> and \<open>r = a # rs'\<close>
+          by simp
+      next
+        case Oc
+        then have "a = Oc" .
+        with w_lex_rs and \<open>r = a # rs'\<close> have "CR = rs@(Oc#rs')" by auto
+
+        have "step0 (7, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Oc#rs') tm_erase_right_then_dblBk_left = (8, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs')"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+        moreover  
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (8, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs')"
+        proof -
+          have "(\<exists>lex'. Bk \<up> Suc lex @ [Bk,Oc] @ CL = Bk \<up> Suc lex' @ [Bk,Oc] @ CL)" by blast
+          moreover with \<open>r = a # rs'\<close> and \<open>a = Oc\<close> and \<open>CR = rs@(Oc#rs')\<close>         
+          have "\<exists>rs1 rs2. CR = rs1 @ [Oc] @ rs2 \<and> Bk#rs' = Bk#rs2" by auto
+          ultimately
+          show "inv_tm_erase_right_then_dblBk_left_erp CL CR (8, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs')"
+            by auto
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 7\<close> and w_lex_rs and \<open>a = Oc\<close> and \<open>r = a # rs'\<close>
+          by simp
+      qed
+    qed
+  next
+    assume "s = 8"
+    with cf_cases and assms
+    have "((\<exists>lex. l = Bk \<up> Suc lex @ [Bk,Oc] @ CL) \<and> (\<exists>rs1 rs2. CR = rs1 @ [Oc] @ rs2 \<and> r = Bk#rs2) )" by auto
+    then obtain lex rs1 rs2 where
+      w_lex_rs1_rs2: "l = Bk \<up> Suc lex @ [Bk,Oc] @ CL \<and> CR = rs1 @ [Oc] @ rs2 \<and> r = Bk#rs2"
+      by blast
+    have "step0 (8, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs2) tm_erase_right_then_dblBk_left = (7, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, rs2)"
+      by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+    moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (7, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, rs2)"
+    proof -
+      have "(\<exists>lex'. Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL = Bk \<up> Suc lex' @ [Bk,Oc] @ CL)" by blast
+      moreover have "\<exists>rs. CR = rs @ []" by auto
+      ultimately
+      show "inv_tm_erase_right_then_dblBk_left_erp CL CR (7, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, rs2)"
+        using w_lex_rs1_rs2
+        by auto
+    qed
+    ultimately show ?thesis
+      using  assms and cf_cases and \<open>s = 8\<close> and w_lex_rs1_rs2
+      by auto
+  next
+    assume "s = 9"
+    with cf_cases and assms
+    have "(\<exists>lex. l = Bk \<up> Suc lex @ [Bk,Oc] @ CL) \<and> (\<exists>rs. CR = rs @ [Bk] @ r \<or> CR = rs \<and> r = [])" by auto
+    then obtain lex rs where
+      w_lex_rs: "l = Bk \<up> Suc lex @ [Bk,Oc] @ CL \<and> (CR = rs @ [Bk] @ r \<or> CR = rs \<and> r = [])" by blast
+
+    then have "CR = rs @ [Bk] @ r \<or> CR = rs \<and> r = []" by auto
+    then show ?thesis
+    proof 
+      assume "CR = rs \<and> r = []"
+      have "step0 (9, Bk \<up> Suc lex @ [Bk,Oc] @ CL, []) tm_erase_right_then_dblBk_left
+                = (10, Bk \<up> lex @ [Bk,Oc] @ CL, [Bk])"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover with \<open>CR = rs \<and> r = []\<close>
+      have "inv_tm_erase_right_then_dblBk_left_erp CL CR (10, Bk \<up> lex @ [Bk,Oc] @ CL, [Bk])"
+      proof -
+        from w_lex_rs and \<open>CR = rs \<and> r = []\<close>
+        have "\<exists>lex' rex.  Bk \<up> lex @ [Bk,Oc] @ CL = Bk \<up> lex' @ [Bk,Oc] @ CL \<and> [Bk] = Bk \<up> Suc rex"
+          by (simp)
+        then show "inv_tm_erase_right_then_dblBk_left_erp CL CR (10, Bk \<up> lex @ [Bk,Oc] @ CL, [Bk])"
+          by auto
+      qed
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 9\<close> and w_lex_rs and \<open>CR = rs \<and> r = []\<close>
+        by auto
+    next
+      assume "CR = rs @ [Bk] @ r"
+      show ?thesis
+      proof (cases r)
+        case Nil
+        then have "r=[]" .
+        have "step0 (9, Bk \<up> Suc lex @ [Bk,Oc] @ CL, []) tm_erase_right_then_dblBk_left
+                = (10, Bk \<up> lex @ [Bk,Oc] @ CL, [Bk])"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+        moreover with \<open>CR = rs @ [Bk] @ r\<close>
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (10, Bk \<up> lex @ [Bk,Oc] @ CL, [Bk])"
+        proof -
+          from w_lex_rs and \<open>CR = rs @ [Bk] @ r\<close>
+          have "\<exists>lex' rex.  Bk \<up> lex @ [Bk,Oc] @ CL = Bk \<up> lex' @ [Bk,Oc] @ CL \<and> [Bk] = Bk \<up> Suc rex"
+            by (simp)
+          with \<open>s=9\<close> show "inv_tm_erase_right_then_dblBk_left_erp CL CR (10, Bk \<up> lex @ [Bk,Oc] @ CL, [Bk])"
+            by auto
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 9\<close> and w_lex_rs and \<open>r=[]\<close>
+          by auto
+      next
+        case (Cons a rs')
+        then have "r = a # rs'" .
+        show ?thesis
+        proof (cases a)
+          case Bk
+          then have "a = Bk" .
+          with \<open>CR = rs @ [Bk] @ r\<close> and \<open>r = a # rs'\<close> have "CR = rs @ [Bk] @ Bk # rs'" by auto
+          moreover from assms  have "noDblBk CR" by auto
+          ultimately have False using hasDblBk_L1 by auto
+          then show ?thesis by auto
+        next
+          case Oc
+          then have "a = Oc" .
+          with \<open>CR = rs @ [Bk] @ r\<close> and \<open>r = a # rs'\<close> have "CR = rs @ [Bk] @ Oc # rs'" by auto
+
+          have "step0 (9, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Oc # rs') tm_erase_right_then_dblBk_left
+                = (8, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk # rs')"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+          moreover  
+          have "inv_tm_erase_right_then_dblBk_left_erp CL CR (8, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk # rs')"
+          proof -
+            have "(\<exists>lex'. Bk \<up> Suc lex @ [Bk,Oc] @ CL = Bk \<up> Suc lex' @ [Bk,Oc] @ CL)" by blast
+            moreover with \<open>r = a # rs'\<close> and \<open>a = Oc\<close> and \<open>CR = rs @ [Bk] @ Oc # rs'\<close>         
+            have "\<exists>rs1 rs2. CR = rs1 @ [Oc] @ rs2 \<and> Bk#rs' = Bk#rs2" by auto
+            ultimately
+            show "inv_tm_erase_right_then_dblBk_left_erp CL CR (8, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs')"
+              by auto
+          qed
+          ultimately show ?thesis
+            using  assms and cf_cases and \<open>s = 9\<close> and w_lex_rs and \<open>a = Oc\<close> and \<open>r = a # rs'\<close>
+            by simp
+        qed
+      qed
+    qed
+  next
+    assume "s = 10"
+    with cf_cases and assms
+    have "(\<exists>lex rex. l = Bk \<up> lex @ [Bk,Oc] @ CL \<and> r = Bk \<up> Suc rex) \<or>
+          (\<exists>rex. l = [Oc] @ CL \<and> r = Bk \<up> Suc rex) \<or>
+          (\<exists>rex. l = CL \<and> r = Oc # Bk \<up> Suc rex)" by auto
+    then obtain lex rex where
+      w_lex_rex: "l = Bk \<up> lex @ [Bk,Oc] @ CL \<and> r = Bk \<up> Suc rex \<or>
+                  l = [Oc] @ CL \<and> r = Bk \<up> Suc rex \<or>
+                  l = CL \<and> r = Oc # Bk \<up> Suc rex" by blast
+    then show ?thesis
+    proof
+      assume "l = Bk \<up> lex @ [Bk, Oc] @ CL \<and> r = Bk \<up> Suc rex"
+      then have "l = Bk \<up> lex @ [Bk, Oc] @ CL" and "r = Bk \<up> Suc rex" by auto
+      show ?thesis
+      proof (cases lex)
+        case 0
+        with \<open>l = Bk \<up> lex @ [Bk, Oc] @ CL\<close> have "l = [Bk, Oc] @ CL" by auto
+        have "step0 (10, [Bk, Oc] @ CL, Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                 = (10, [Oc] @ CL, Bk \<up> Suc (Suc rex))"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+        moreover
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (10, [Oc] @ CL, Bk \<up> Suc (Suc rex))"
+        proof -
+          from \<open>l = [Bk, Oc] @ CL\<close> and \<open>r = Bk \<up> Suc rex\<close>
+          have "\<exists>rex'. [Oc] @ CL = [Oc] @ CL \<and> Bk \<up> Suc (Suc rex) = Bk \<up> Suc rex'"
+            by blast
+          with \<open>l = [Bk, Oc] @ CL\<close>
+          show "inv_tm_erase_right_then_dblBk_left_erp CL CR (10, [Oc] @ CL, Bk \<up> Suc (Suc rex))"    
+            by auto
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 10\<close> and  \<open>l = [Bk, Oc] @ CL\<close> and \<open>r = Bk \<up> Suc rex\<close>
+          by auto
+      next
+        case (Suc nat)
+        then have "lex = Suc nat" .
+        with \<open>l = Bk \<up> lex @ [Bk, Oc] @ CL\<close> have "l= Bk \<up> Suc nat @ [Bk, Oc] @ CL" by auto
+        have "step0 (10, Bk \<up> Suc nat @ [Bk, Oc] @ CL, Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                 = (10, Bk \<up> nat @ [Bk, Oc] @ CL, Bk \<up> Suc (Suc rex))"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+        moreover
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (10, Bk \<up> nat @ [Bk, Oc] @ CL, Bk \<up> Suc (Suc rex))"
+        proof -
+          from \<open>l= Bk \<up> Suc nat @ [Bk, Oc] @ CL\<close> and \<open>r = Bk \<up> Suc rex\<close>
+          have  "\<exists>lex' rex'. Bk \<up> Suc nat @ [Bk, Oc] @ CL = Bk \<up> lex' @ [Bk,Oc] @ CL \<and> Bk \<up> Suc (Suc rex) = Bk \<up> Suc rex'"
+            by blast
+          with \<open>l= Bk \<up> Suc nat @ [Bk, Oc] @ CL\<close>
+          show "inv_tm_erase_right_then_dblBk_left_erp CL CR (10, Bk \<up> nat @ [Bk, Oc] @ CL, Bk \<up> Suc (Suc rex))"
+            by auto
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 10\<close> and \<open>l= Bk \<up> Suc nat @ [Bk, Oc] @ CL\<close> and \<open>r = Bk \<up> Suc rex\<close>
+          by auto
+      qed
+    next
+      assume "l = [Oc] @ CL \<and> r = Bk \<up> Suc rex \<or> l = CL \<and> r = Oc # Bk \<up> Suc rex"
+      then show ?thesis
+      proof
+        assume "l = [Oc] @ CL \<and> r = Bk \<up> Suc rex"
+        then have "l = [Oc] @ CL" and "r = Bk \<up> Suc rex" by auto
+
+        have "step0 (10, [Oc] @ CL, Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                 = (10, CL, Oc# Bk \<up> (Suc rex))"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+        moreover
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (10, CL, Oc# Bk \<up> (Suc rex))"
+        proof -
+          from \<open>l = [Oc] @ CL\<close> and \<open>r = Bk \<up> Suc rex\<close>
+          have "\<exists>rex'. [Oc] @ CL = [Oc] @ CL \<and> Bk \<up> Suc rex = Bk \<up> Suc rex'"
+            by blast
+          with \<open>l = [Oc] @ CL\<close>
+          show "inv_tm_erase_right_then_dblBk_left_erp CL CR (10, CL, Oc# Bk \<up> (Suc rex))"    
+            by auto
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 10\<close> and  \<open>l = [Oc] @ CL\<close> and \<open>r = Bk \<up> Suc rex\<close>
+          by auto
+      next
+        assume "l = CL \<and> r = Oc # Bk \<up> Suc rex"
+        then have "l = CL" and "r = Oc # Bk \<up> Suc rex" by auto
+        show ?thesis
+        proof (cases CL) (* here, we start decomposing CL in the loop 'move to left until Oc *)
+          case Nil
+          then have "CL = []" .
+          with \<open>l = CL\<close> have "l = []" by auto
+          have "step0 (10, [], Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                 = (11, [], Bk#Oc# Bk \<up> (Suc rex))"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+          moreover
+          have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk#Oc# Bk \<up> (Suc rex))"
+          proof -
+            (* Special case: CL = [] 
+               from call (1, [Oc, Bk], []) we get 11: [] _11_ [Bk,Oc,Bk,Bk,Bk]
+
+               YYYY1' "\<exists>rex'. ] = [] \<and> Bk# Oc# Bk \<up> Suc rex = [Bk] @ rev CL @ Oc # Bk \<up> Suc rex' \<and> (CL = [] \<or> last CL = Oc)" 
+             *)
+            from \<open>CL = []\<close>
+            have "\<exists>rex'. [] = [] \<and> Bk# Oc# Bk \<up> Suc rex = [Bk] @ rev CL @ Oc # Bk \<up> Suc rex' \<and> (CL = [] \<or> last CL = Oc)"
+              by auto           
+            with \<open>l = []\<close>
+            show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk#Oc# Bk \<up> (Suc rex))"    
+              by auto
+          qed
+          ultimately show ?thesis
+            using  assms and cf_cases and \<open>s = 10\<close> and  \<open>l = []\<close> and \<open>r = Oc # Bk \<up> Suc rex\<close>
+            by auto
+        next
+          case (Cons a cls)
+          then have "CL = a # cls" .
+          with \<open>l = CL\<close> have "l =  a # cls" by auto
+          then show ?thesis
+          proof (cases a)
+            case Bk
+            then have "a = Bk" .
+            with \<open>l =  a # cls\<close> have "l =  Bk # cls" by auto
+            with \<open>a = Bk\<close> \<open>CL = a # cls\<close> have "CL = Bk # cls" by auto
+
+            have "step0 (10,  Bk # cls, Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                 = (11, cls, Bk# Oc # Bk \<up> Suc rex)"
+              by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+            moreover
+            have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, cls, Bk# Oc # Bk \<up> Suc rex)"
+
+            proof (cases cls)
+              case Nil
+              then have "cls = []" .
+              with \<open>CL = Bk # cls\<close> have "CL = [Bk]" by auto
+                  (* Special case: CL ends with a blank 
+                     from call ctxrunTM tm_erase_right_then_dblBk_left (1, [Bk, Oc,Bk], [Bk,Oc,Oc,Bk,Oc,Oc])
+                          24: [Bk] _10_ [Oc,Bk,Bk,Bk,Bk,Bk,Bk,Bk,Bk]
+                          25: [] _11_ [Bk,Oc,Bk,Bk,Bk,Bk,Bk,Bk,Bk,Bk]
+
+                     YYYY2' "\<exists>rex'.         [] = []  \<and>     Bk# Oc# Bk \<up> Suc rex = rev CL        @ Oc # Bk \<up> Suc rex' \<and> \<and> CL \<noteq> [] \<and> last CL = Bk" 
+
+                   *)
+              then have "\<exists>rex'. [] = [] \<and> Bk# Oc# Bk \<up> Suc rex = rev CL @ Oc # Bk \<up> Suc rex' \<and> CL \<noteq> [] \<and> last CL = Bk"
+                by auto
+              with \<open>l =  Bk # cls\<close> and \<open>cls = []\<close>
+              show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, cls, Bk# Oc # Bk \<up> Suc rex)"    
+                by auto
+            next
+              case (Cons a cls')
+              then have "cls = a # cls'" .
+              then show ?thesis
+              proof (cases a)
+                case Bk
+                with \<open>CL = Bk # cls\<close> and \<open>cls = a # cls'\<close> have "CL = Bk# Bk# cls'" by auto
+                with \<open>noDblBk CL\<close> have False using noDblBk_def by auto
+                then show ?thesis by auto
+              next
+                case Oc
+                then have "a = Oc" .
+                with \<open>CL = Bk # cls\<close> and \<open>cls = a # cls'\<close> and \<open>l =  Bk # cls\<close>
+                have "CL = Bk# Oc# cls' \<and> l =  Bk # Oc # cls'" by auto
+                    (* from call (1, [Oc,Oc,Bk,Oc,Bk], [Oc,Oc,Oc,Bk,Oc,Oc])
+                       we get 26: [Oc,Oc] _11_ [Bk,Oc,Bk,Bk,Bk,Bk,Bk,Bk,Bk,Bk]
+  
+                       YYYY3 "\<exists>rex' ls1 ls2. Oc#cls' = Oc#ls2 \<and> Bk# Oc# Bk \<up> Suc rex = rev ls1 @ Oc # Bk \<up> Suc rex' \<and>
+                                    CL = ls1 @ Oc#ls2    \<and> ls1 = [Bk]"
+                     *)
+                with \<open>cls = a # cls'\<close> and \<open>a=Oc\<close>
+                have "\<exists>rex' ls1 ls2. Oc#cls' = Oc#ls2 \<and> Bk# Oc# Bk \<up> Suc rex = rev ls1 @ Oc # Bk \<up> Suc rex' \<and>
+                                     CL = ls1 @ Oc#ls2    \<and> ls1 = [Bk]"
+                  by auto
+                with \<open>cls = a # cls'\<close> and \<open>a=Oc\<close>
+                show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, cls, Bk# Oc # Bk \<up> Suc rex)"    
+                  by auto
+              qed
+            qed
+            ultimately show ?thesis
+              using  assms and cf_cases and \<open>s = 10\<close> and  \<open>l =  Bk # cls\<close> and \<open>r = Oc # Bk \<up> Suc rex\<close>
+              by auto
+          next
+            case Oc
+            then have "a = Oc" .
+            with \<open>l =  a # cls\<close> have "l =  Oc # cls" by auto
+            with \<open>a = Oc\<close> \<open>CL = a # cls\<close> have "CL = Oc # cls" by auto  (* a normal case *)
+
+            have "step0 (10,  Oc # cls, Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                 = (11, cls, Oc # Oc # Bk \<up> Suc rex)"
+              by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+            moreover
+            have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, cls, Oc # Oc # Bk \<up> Suc rex)"
+            proof (cases cls)
+              case Nil
+              then have "cls = []" .
+              with \<open>CL = Oc # cls\<close> have "CL = [Oc]" by auto
+               (* from call (1, [Oc,Oc,Bk], [Oc,Oc,Oc,Bk,Oc,Oc])
+                    we get 26: [] _11_ [Oc,Oc,Bk,Bk,Bk,Bk,Bk,Bk,Bk,Bk]
+
+                   YYYY2''   "\<exists>rex'. [] = [] \<and> Oc# Oc# Bk \<up> Suc rex = rev CL @ Oc # Bk \<up> Suc rex' \<and>
+                                     CL \<noteq> [] \<and> last CL = Oc"
+               *)
+              then have "\<exists>rex'. [] = [] \<and> Oc# Oc# Bk \<up> Suc rex = rev CL @ Oc # Bk \<up> Suc rex' \<and> CL \<noteq> [] \<and> last CL = Oc"
+                by auto
+              with \<open>l =  Oc # cls\<close> and \<open>cls = []\<close>
+              show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, cls, Oc# Oc # Bk \<up> Suc rex)"    
+                by auto
+            next
+              case (Cons a cls')
+              then have "cls = a # cls'" .
+              then show ?thesis
+              proof (cases a)
+                case Bk
+                then have "a=Bk" .
+                with \<open>CL = Oc # cls\<close> and \<open>cls = a # cls'\<close> and \<open>l =  Oc # cls\<close>
+                have "CL = Oc# Bk# cls'" and "l =  Oc # Bk # cls'" and "CL = l" and \<open>cls = Bk # cls'\<close> by auto
+
+                from \<open>CL = Oc# Bk# cls'\<close> and \<open>noDblBk CL\<close>
+                have "cls' = [] \<or> (\<exists>cls''. cls' = Oc# cls'')"
+                  by (metis (full_types) \<open>CL = Oc # cls\<close> \<open>cls = Bk # cls'\<close> append_Cons append_Nil cell.exhaust hasDblBk_L1 neq_Nil_conv)
+
+                then show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, cls, Oc # Oc # Bk \<up> Suc rex)"
+                proof
+                  assume "cls' = []"
+                  with \<open>CL = Oc# Bk# cls'\<close> and \<open>CL = l\<close> and \<open>cls = Bk # cls'\<close>
+                  have "CL = Oc# Bk# []" and "l = Oc# Bk# []" and "cls = [Bk]" by auto
+                      (* from call (1, [Bk,Oc,Oc,Bk], [Oc,Oc,Oc,Bk,Oc,Oc])
+                        we get 26: [Bk] _11_ [Oc,Oc,Bk,Bk,Bk,Bk,Bk,Bk,Bk,Bk]
+
+                        YYYY5 "\<exists>rex'.     cls = [Bk] \<and> Oc# Oc# Bk \<up> Suc rex = rev [Oc] @ Oc # Bk \<up> Suc rex' \<and> CL = [Oc, Bk]"
+
+                      *)
+                  then have "\<exists>rex'.     cls = [Bk] \<and> Oc# Oc# Bk \<up> Suc rex = rev [Oc] @ Oc # Bk \<up> Suc rex' \<and> CL = [Oc, Bk]"
+                    by auto
+                  with \<open>CL = Oc# Bk# []\<close> show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, cls, Oc # Oc # Bk \<up> Suc rex)" 
+                    by auto
+                next
+                  assume "\<exists>cls''. cls' = Oc # cls''"
+                  then obtain cls'' where "cls' = Oc # cls''" by blast
+                  with \<open>CL = Oc# Bk# cls'\<close> and \<open>CL = l\<close> and \<open>cls = Bk # cls'\<close>
+                  have "CL = Oc# Bk# Oc # cls''" and "l = Oc# Bk# Oc # cls''" and "cls = Bk#Oc # cls''" by auto
+                      (* very special case  call (1, [*,Oc,Bk, Oc,Oc,Bk], [Oc,Oc,Oc,Bk,Oc,Oc])
+                         trailing Bk on initial left tape
+                         
+                         from call (1, [Oc,Bk, Oc,Oc,Bk], [Oc,Oc,Oc,Bk,Oc,Oc])
+                            we get 26: [Oc,Bk] _11_ [Oc,Oc,Bk,Bk,Bk,Bk,Bk,Bk,Bk,Bk]
+    
+                         from call (1, [Oc,Oc,Bk,Oc,Bk, Oc,Oc,Bk], [Oc,Oc,Oc,Bk,Oc,Oc])
+                            we get 26: [Oc,Oc,Bk,Oc,Bk] _11_ [Oc,Oc,Bk,Bk,Bk,Bk,Bk,Bk,Bk,Bk]
+
+                        YYYY6   "\<exists>rex' ls1 ls2. cls     = Bk#Oc#ls2  \<and> Oc# Oc# Bk \<up> Suc rex = rev ls1 @ Oc # Bk \<up> Suc rex'
+                                                \<and> CL = ls1 @ Bk#Oc#ls2 \<and> ls1 = [Oc]"
+                   *)
+                  then have "\<exists>rex' ls1 ls2. cls     = Bk#Oc#ls2  \<and> Oc# Oc# Bk \<up> Suc rex = rev ls1 @ Oc # Bk \<up> Suc rex'
+                                                \<and> CL = ls1 @ Bk#Oc#ls2 \<and> ls1 = [Oc]"
+                    by auto
+                  then show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, cls, Oc # Oc # Bk \<up> Suc rex)"
+                    by auto
+                qed
+
+              next
+                case Oc
+                then have "a=Oc" .
+                with \<open>CL = Oc # cls\<close> and \<open>cls = a # cls'\<close> and \<open>l =  Oc # cls\<close>
+                have "CL = Oc# Oc# cls'" and "l =  Oc # Oc # cls'" and "CL = l" and \<open>cls = Oc # cls'\<close> by auto
+                (* We know more : ls1 = [Oc]
+                   YYYY7   "\<exists>rex' ls1 ls2. cls = Oc#ls2 \<and> Oc# Oc# Bk \<up> Suc rex = rev ls1 @ Oc # Bk \<up> Suc rex' \<and>
+                                           CL = ls1 @ Oc#ls2    \<and> ls1 = [Oc]"
+
+                           "\<exists>rex' ls1 ls2. cls = Oc#ls2 \<and> Oc# Oc# Bk \<up> Suc rex = rev ls1 @ Oc # Bk \<up> Suc rex' \<and>
+                                           CL = ls1 @ Oc#ls2    \<and> ls1 = [Oc]"
+                *)
+                then have "\<exists>rex' ls1 ls2. cls = Oc#ls2 \<and> Oc# Oc# Bk \<up> Suc rex = rev ls1 @ Oc # Bk \<up> Suc rex' \<and>
+                                           CL = ls1 @ Oc#ls2    \<and> ls1 = [Oc]"
+                  by auto
+                then show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, cls, Oc # Oc # Bk \<up> Suc rex)"
+                  by auto
+              qed
+            qed
+            ultimately show ?thesis
+              using  assms and cf_cases and \<open>s = 10\<close> and  \<open>l =  Oc # cls\<close> and \<open>r = Oc # Bk \<up> Suc rex\<close>
+              by auto
+          qed
+        qed
+      qed
+    qed
+  next
+    assume "s = 11"
+    with cf_cases and assms
+    have "(\<exists>rex.         l = []         \<and> r = Bk# rev CL    @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc))              \<or>
+          (\<exists>rex.         l = []         \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk ) \<or>
+          (\<exists>rex.         l = []         \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Oc ) \<or>
+
+          (\<exists>rex.         l = [Bk]       \<and> r = rev [Oc]      @ Oc # Bk \<up> Suc rex \<and> CL = [Oc, Bk]) \<or>
+
+          (\<exists>rex ls1 ls2. l = Bk#Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Bk#Oc#ls2 \<and> ls1 = [Oc] ) \<or>
+          (\<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Bk] ) \<or>
+          (\<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Oc] ) \<or>
+ 
+          (\<exists>rex ls1 ls2. l =       ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2       \<and> tl ls1 \<noteq> [])"
+      by auto
+
+    then have s11_cases:
+      "\<And>P. \<lbrakk> \<exists>rex.         l = []         \<and> r = Bk# rev CL    @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc) \<Longrightarrow> P;
+             \<exists>rex.         l = []         \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk \<Longrightarrow> P;
+             \<exists>rex.         l = []         \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Oc \<Longrightarrow> P;
+
+             \<exists>rex.         l = [Bk]       \<and> r = rev [Oc]      @ Oc # Bk \<up> Suc rex \<and> CL = [Oc, Bk] \<Longrightarrow> P;
+
+             \<exists>rex ls1 ls2. l = Bk#Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Bk#Oc#ls2 \<and> ls1 = [Oc] \<Longrightarrow> P;
+             \<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Bk] \<Longrightarrow> P;
+             \<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Oc] \<Longrightarrow> P;
+
+             \<exists>rex ls1 ls2. l =       ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2       \<and> tl ls1 \<noteq> [] \<Longrightarrow> P
+            \<rbrakk> \<Longrightarrow> P"
+      by blast
+
+    show ?thesis
+    proof (rule s11_cases)
+      assume "\<exists>rex ls1 ls2. l = Bk # Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Bk # Oc # ls2 \<and> ls1 = [Oc]"
+      then obtain rex ls1 ls2 where A_case: "l = Bk#Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Bk#Oc#ls2 \<and> ls1 = [Oc]" by blast
+
+      then have "step0 (11,  Bk # Oc # ls2, r) tm_erase_right_then_dblBk_left
+                 = (11, Oc # ls2, Bk # r)"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+      moreover
+      have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, Oc # ls2, Bk # r)"
+      proof -         
+        from A_case   (* YYYY8 *)
+        have "\<exists>rex' ls1' ls2'. Oc#ls2 = ls2'  \<and> Bk# Oc# Oc# Bk \<up> Suc rex' = rev ls1' @ Oc # Bk \<up> Suc rex' \<and>
+                                         CL = ls1' @ ls2' \<and> tl ls1' \<noteq> []"
+          by force
+        with A_case
+        show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, Oc # ls2, Bk # r)"
+          by auto
+      qed
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 11\<close> and A_case
+        by simp
+    next
+      assume "\<exists>rex ls1 ls2. l = Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc # ls2 \<and> ls1 = [Oc]"
+      then obtain rex ls1 ls2 where
+        A_case: "l = Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc # ls2 \<and> ls1 = [Oc]" by blast
+      then have "step0 (11, Oc # ls2, r) tm_erase_right_then_dblBk_left
+                 = (11, ls2, Oc#r)"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover
+      have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, ls2, Oc#r)"
+      proof (rule noDblBk_cases)
+        from \<open>noDblBk CL\<close> show "noDblBk CL" .
+      next
+        from A_case show "CL = [Oc,Oc] @ ls2" by auto
+      next
+        assume "ls2 = []" 
+(*
+        with A_case  (* YYYY7''' *)
+        have "\<exists>rex'. ls2 = [] \<and> [Oc,Oc] @ Oc # Bk \<up> Suc rex = rev CL @ Oc # Bk \<up> Suc rex' \<and> CL = [Oc, Oc]"
+          by force
+*)
+        with A_case  (* YYYY2'' *)
+        have "\<exists>rex'. ls2 = [] \<and> [Oc,Oc] @ Oc # Bk \<up> Suc rex = rev CL @ Oc # Bk \<up> Suc rex'"
+          by force
+        with A_case and \<open>ls2 = []\<close> show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, ls2, Oc#r)"
+          by auto
+      next
+        assume "ls2 = [Bk]"
+        (* YYYY8 *)
+        with A_case
+        have "\<exists>rex' ls1' ls2'.    ls2 = ls2'      \<and>     Oc#Oc# Oc# Bk \<up> Suc rex  = rev ls1'       @ Oc # Bk \<up> Suc rex' \<and> CL = ls1' @ ls2'       \<and> hd ls1' = Oc \<and> tl ls1' \<noteq> []"
+          by simp
+
+        with A_case and \<open>ls2 = [Bk]\<close> show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, ls2, Oc#r)"
+          by force
+      next
+        fix C3
+        assume "ls2 = Bk # Oc # C3"
+        (* YYYY8 *)
+        with A_case
+        have "\<exists>rex' ls1' ls2'.    ls2 = ls2'      \<and>     Oc#Oc# Oc# Bk \<up> Suc rex  = rev ls1'       @ Oc # Bk \<up> Suc rex' \<and> CL = ls1' @ ls2'       \<and> hd ls1' = Oc \<and> tl ls1' \<noteq> []"
+          by simp
+        with A_case and \<open>ls2 = Bk # Oc # C3\<close> show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, ls2, Oc#r)"
+          by force
+      next
+        fix C3
+        assume "ls2 = Oc # C3"
+        (* YYYY8 *)
+        with A_case
+        have "\<exists>rex' ls1' ls2'.    ls2 = ls2'      \<and>     Oc#Oc# Oc# Bk \<up> Suc rex  = rev ls1'       @ Oc # Bk \<up> Suc rex' \<and> CL = ls1' @ ls2'       \<and> hd ls1' = Oc \<and> tl ls1' \<noteq> []"
+          by simp
+        with A_case and \<open>ls2 = Oc # C3\<close> show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, ls2, Oc#r)"
+          by force
+      qed
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 11\<close> and A_case
+        by simp
+    next
+      assume "\<exists>rex. l = [Bk] \<and> r = rev [Oc] @ Oc # Bk \<up> Suc rex \<and> CL = [Oc, Bk]"
+      then obtain rex where
+        A_case: "l = [Bk] \<and> r = rev [Oc] @ Oc # Bk \<up> Suc rex \<and> CL = [Oc, Bk]" by blast
+      then have "step0 (11, [Bk] , r) tm_erase_right_then_dblBk_left
+                 = (11, [], Bk#r)"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk#r)"
+      proof -
+        from A_case
+(*
+        have "\<exists>rex'.         [] = []         \<and> Bk#rev [Oc] @ Oc # Bk \<up> Suc rex = rev CL        @ Oc # Bk \<up> Suc rex' \<and> CL = [Oc, Bk]" (* YYYY5' *)
+          by simp
+*)
+        have "\<exists>rex'.         [] = []         \<and> Bk#rev [Oc] @ Oc # Bk \<up> Suc rex = rev CL        @ Oc # Bk \<up> Suc rex'" (* YYYY2' *)
+          by simp
+        with A_case  show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk#r)"
+          by force
+      qed
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 11\<close> and A_case
+        by simp
+    next
+      (* YYYY8 for s11 *)
+      assume "\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> tl ls1 \<noteq> []"
+      then obtain rex ls1 ls2 where
+        A_case: "l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> tl ls1 \<noteq> []" by blast
+      then have "\<exists>z b bs. ls1 = z#bs@[b]"  (* the symbol z does not matter *) 
+        by (metis Nil_tl list.exhaust_sel rev_exhaust)
+      then have "\<exists>z bs. ls1 = z#bs@[Bk] \<or> ls1 = z#bs@[Oc]"
+        using cell.exhaust by blast
+      then obtain z bs where w_z_bs: "ls1 = z#bs@[Bk] \<or> ls1 = z#bs@[Oc]" by blast
+      then show "inv_tm_erase_right_then_dblBk_left_erp CL CR (step0 cf tm_erase_right_then_dblBk_left)"
+      proof
+        assume major1: "ls1 = z # bs @ [Bk]"
+        then have major2: "rev ls1 = Bk#(rev bs)@[z]" by auto  (* in this case all transitions will be s11 \<longrightarrow> s12 *)
+        show ?thesis
+        proof  (rule noDblBk_cases)
+          from \<open>noDblBk CL\<close> show "noDblBk CL" .
+        next
+          from A_case show "CL = ls1 @ ls2" by auto
+        next
+          assume "ls2 = []"
+          with A_case have "step0 (11, [] , Bk#(rev bs)@[z] @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                          = (12, [], Bk#Bk#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+          moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (12, [], Bk#Bk#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+          proof -
+            from A_case \<open>rev ls1 = Bk#(rev bs)@[z]\<close> and \<open>ls2 = []\<close>
+            have "ls1 = z#bs@[Bk]" and "CL = ls1" and "r = rev CL @ Oc # Bk \<up> Suc rex" by auto
+            (*  YYYY6'''    \<exists>rex. l = []  \<and> r = Bk#rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk *)
+            with A_case \<open>rev ls1 = Bk#(rev bs)@[z]\<close> and \<open>ls2 = []\<close>
+            have "\<exists>rex'. [] = []  \<and> Bk#Bk#(rev bs)@[z] @ Oc # Bk \<up> Suc rex = Bk#rev CL @ Oc # Bk \<up> Suc rex' \<and> CL \<noteq> [] \<and> last CL = Bk"
+              by simp
+            with A_case \<open>rev ls1 = Bk#(rev bs)@[z]\<close> and \<open>ls2 = []\<close>
+            show "inv_tm_erase_right_then_dblBk_left_erp CL CR (12, [], Bk#Bk#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+              by force
+          qed
+          ultimately show ?thesis
+            using  assms and cf_cases and \<open>s = 11\<close> and A_case and \<open>rev ls1 = Bk#(rev bs)@[z]\<close> and \<open>ls2 = []\<close>
+            by simp
+        next
+          assume "ls2 = [Bk]"
+            (* A_case: l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [] *)
+          with A_case \<open>rev ls1 = Bk#(rev bs)@[z]\<close> and \<open>ls2 = [Bk]\<close>
+          have "ls1 = z#bs@[Bk]" and "CL = z#bs@[Bk]@[Bk]" by auto
+          with \<open>noDblBk CL\<close> have False               
+            by (metis A_case  \<open>ls2 = [Bk]\<close> append_Cons hasDblBk_L5 major2)
+          then show ?thesis by auto
+        next
+          fix C3
+          assume minor: "ls2 = Bk # Oc # C3"
+          with A_case and major2 have "CL = z # bs @ [Bk] @ Bk # Oc # C3" by auto
+          with \<open>noDblBk CL\<close> have False
+            by (metis append.left_neutral append_Cons append_assoc hasDblBk_L1 major1 minor)
+          then show ?thesis by auto     
+        next
+          fix C3
+          assume minor: "ls2 = Oc # C3"
+            (*
+               A_case: "l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> []"
+        
+                  major1: "ls1 = Oc # bs @ [Bk]"
+                  major2: "rev ls1 = Bk # rev bs @ [Oc]"
+        
+                  minor1: "ls2 = Oc # C3"
+        
+                          l =  Oc # C3
+        
+                          r = rev ls1           @ Oc # Bk \<up> Suc rex
+        
+                          r = Bk#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex
+        
+                  thus: s11 \<longrightarrow> s12
+        
+                          (12, C3, Oc#Bk#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex )
+                  
+                          l' = C3
+                          r' = Oc#Bk#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex
+        
+                          ls2' = C3
+                          
+                          rev ls1' = Oc#Bk#(rev bs)@[Oc]
+        
+                          ls1' = Oc# bs @ [Bk] @ [Oc] = ls1@[Oc]
+        
+                          CL = ls1 @ ls2 = ls1 @ Oc # C3 = ls1 @ [Oc] @ [C3] = ls1' @ ls2'
+        
+                              \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> []
+        
+                           (\<exists>rex' ls1' ls2'. C3 = ls2'  \<and> Oc#Bk#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex = rev ls1'       @ Oc # Bk \<up> Suc rex' \<and>
+                                                         CL =  ls1' @ ls2'  \<and> hd ls1' = Oc \<and> tl ls1' \<noteq> [] \<and> last ls1' = Oc)
+        
+               again       YYYY4 (\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2  \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc)
+             *)
+
+          with A_case have "step0 (11, Oc # C3 , Bk#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                          = (12, C3, Oc#Bk#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex )"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+          moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (12, C3, Oc#Bk#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex )"
+          proof -
+            from A_case and \<open>rev ls1 = Bk # rev bs @ [z]\<close> and \<open>ls2 = Oc # C3\<close> and \<open>ls1 = z # bs @ [Bk]\<close>
+            have "\<exists>rex' ls1' ls2'. C3 = ls2'  \<and> Oc#Bk#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex = rev ls1'       @ Oc # Bk \<up> Suc rex' \<and>
+                                                 CL =  ls1' @ ls2'  \<and> hd ls1' = z \<and> tl ls1' \<noteq> [] \<and> last ls1' = Oc"            
+              by simp
+
+            with A_case \<open>rev ls1 = Bk # rev bs @ [z]\<close> and \<open>ls2 = Oc # C3\<close> and \<open>ls1 = z # bs @ [Bk]\<close>
+            show "inv_tm_erase_right_then_dblBk_left_erp CL CR (12, C3, Oc#Bk#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex )"           
+              by simp
+          qed
+          ultimately show ?thesis
+            using  assms and cf_cases and \<open>s = 11\<close> and A_case and \<open>rev ls1 = Bk#(rev bs)@[z]\<close> and  \<open>ls2 = Oc # C3\<close>
+            by simp      
+        qed
+      next
+        assume major1: "ls1 = z # bs @ [Oc]"
+        then have major2: "rev ls1 = Oc#(rev bs)@[z]" by auto (* in this case all transitions will be s11 \<longrightarrow> s11 *)
+        show ?thesis
+        proof  (rule noDblBk_cases)
+          from \<open>noDblBk CL\<close> show "noDblBk CL" .
+        next
+          from A_case show "CL = ls1 @ ls2" by auto
+        next
+          assume "ls2 = []"
+            (* A_case: l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [] 
+
+              l = []
+              r = rev ls1          @ Oc # Bk \<up> Suc rex
+              r = Oc#(rev bs)@[Oc] @ Oc # Bk \<up> Suc rex
+
+              l' = []
+              r' = Bk#Oc#(rev bs)@[Oc] @ Oc # Bk \<up> Suc rex
+
+              ls1 = Oc # bs @ [Oc]
+              rev ls1 = Oc#(rev bs)@[Oc]
+              
+              rev ls1' =  Bk#Oc#(rev bs)@[Oc]
+
+              ls1' = Oc # bs @ [Oc] @ [Bk]
+
+              ls2' = []
+
+              CL = ls1 @ ls2 = (Oc # bs @ [Oc]) @ [] = Oc # bs @ [Oc] = ls1
+
+              rev ls1 = rev CL
+
+              \<exists>rex'. [] = []  \<and> Bk#Oc#(rev bs)@[Oc] @ Oc # Bk \<up> Suc rex = Bk#rev CL @ Oc # Bk \<up> Suc rex' \<and> last CL = Oc
+
+                      (\<exists>rex. l = []  \<and> r = Bk# rev CL @ Oc # Bk \<up> Suc rex \<and> last CL = Oc) 
+
+              we simplify
+              YYYY1'  (\<exists>rex. l = []  \<and> r = Bk# rev CL @ Oc # Bk \<up> Suc rex)
+
+              now, we generalize to 
+              YYYY1'  (\<exists>rex. l = []  \<and> r = Bk# rev CL @ Oc # Bk \<up> Suc rex) \<and> (CL = [] \<or> last CL = Oc)
+
+           *)
+
+          with A_case have "step0 (11, [] , Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                          = (11, [], Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex)"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+          moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+          proof -
+            from A_case \<open>rev ls1 = Oc#(rev bs)@[z]\<close> and \<open>ls2 = []\<close>
+            have "ls1 = z # bs @ [Oc]" and "CL = ls1" and "r = rev CL @ Oc # Bk \<up> Suc rex" by auto
+                (*  new invariant for s11:
+                    YYYY1'  (\<exists>rex. l = []  \<and> r = Bk# rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc))
+           *)
+            with A_case \<open>rev ls1 = Oc#(rev bs)@[z]\<close> and \<open>ls2 = []\<close>
+            have "\<exists>rex'. [] = []  \<and> Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex = Bk#rev CL @ Oc # Bk \<up> Suc rex' \<and> (CL = [] \<or> last CL = Oc)"              
+              by simp
+            with A_case \<open>rev ls1 = Oc#(rev bs)@[z]\<close> and \<open>ls2 = []\<close>
+            show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+              by force
+          qed
+          ultimately show ?thesis
+            using  assms and cf_cases and \<open>s = 11\<close> and A_case and \<open>rev ls1 = Oc#(rev bs)@[z]\<close> and \<open>ls2 = []\<close>
+            by simp
+        next     
+          assume "ls2 = [Bk]"
+            (* A_case: l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [] 
+
+              l = [Bk]
+              r = rev ls1          @ Oc # Bk \<up> Suc rex
+              r = Oc#(rev bs)@[Oc] @ Oc # Bk \<up> Suc rex
+
+              l' = []
+              r' = Bk#Oc#(rev bs)@[Oc] @ Oc # Bk \<up> Suc rex
+
+              ls1 = Oc # bs @ [Oc]
+              rev ls1 = Oc#(rev bs)@[Oc]
+              
+              rev ls1' =  Bk#Oc#(rev bs)@[Oc]
+
+              ls1' = Oc # bs @ [Oc] @ [Bk] = ls1 @ [Bk]
+
+              ls2' = []
+
+              CL = ls1 @ ls2 = (Oc # bs @ [Oc]) @ [Bk] = ls1 @ [Bk] = ls1'
+
+
+              list functions (hd ls) and (last ls) are only usefull if ls \<noteq> [] is known! 
+
+              new invariant for s11:
+              YYYY2'    (\<exists>rex.         l =        []  \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> []  \<and> last CL = Bk) \<or>  (s11 \<longrightarrow> s11)
+              YYYY2''   (\<exists>rex.         l =        []  \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> []  \<and> last CL = Oc) \<or>  (s11 \<longrightarrow> s11)
+             
+           *)
+          with A_case have "step0 (11, [Bk] , Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                          = (11, [], Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+          moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+          proof -
+            from A_case \<open>rev ls1 = Oc#(rev bs)@[z]\<close> and \<open>ls2 = [Bk]\<close>
+            have "ls1 = z # bs @ [Oc]" and "CL = ls1@[Bk]" by auto
+                (*  new invariant for s11:
+                    YYYY2'   (\<exists>rex.         l =        []  \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> []  \<and> last CL = Bk)
+           *)
+            with A_case \<open>rev ls1 = Oc#(rev bs)@[z]\<close> and \<open>ls2 = [Bk]\<close>
+            have "\<exists>rex'. [] = []  \<and> Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex = rev CL @ Oc # Bk \<up> Suc rex' \<and> CL \<noteq> [] \<and> last CL = Bk"              
+              by simp
+
+            with A_case \<open>rev ls1 = Oc#(rev bs)@[z]\<close> and \<open>ls2 = [Bk]\<close> and \<open>CL = ls1@[Bk]\<close>
+            show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+
+              by force
+          qed
+          ultimately show ?thesis
+            using  assms and cf_cases and \<open>s = 11\<close> and A_case and \<open>rev ls1 = Oc#(rev bs)@[z]\<close> and \<open>ls2 = [Bk]\<close>
+            by simp
+        next     
+          fix C3
+          assume minor: "ls2 = Bk # Oc # C3"
+
+(* thm A_case: l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> []
+             thm major1: ls1 = Oc # bs @ [Oc]
+             thm major2: rev ls1 = Oc # rev bs @ [Oc]
+
+              minor1: "ls2 = Bk # Oc # C3"
+    
+                      l = Bk # Oc # C3
+                      r = Oc#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex
+    
+              thus: s11 \<longrightarrow> s11
+                      (11, Oc # C3, Bk#Oc#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex )
+                 
+                      l' = Oc # C3
+                      r' = Bk#Oc#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex
+                      
+                      ls2' = Oc # C3
+                      
+                      rev ls1' = Bk#Oc#(rev bs)@[Oc]
+    
+                      ls1' = Oc# bs @ [Oc] @ [Bk] = ls1@[Bk]
+    
+                      CL = ls1 @ ls2 = ls1 @ Bk # Oc # C3 = ls1 @ [Bk] @ [Oc ,C3] = ls1' @ ls2'
+    
+                          \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> []
+    
+                       (\<exists>rex' ls1' ls2'. Oc # C3 = ls2'  \<and> Bk#Oc#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex = rev ls1'       @ Oc # Bk \<up> Suc rex' \<and>
+                                                     CL =  ls1' @ ls2'  \<and> hd ls1' = Oc \<and> tl ls1' \<noteq> [])
+    
+              again  YYYY8    (\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2  \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [])
+           *)
+
+          with A_case have "step0 (11, Bk # Oc # C3 , Oc # rev bs @ [z]  @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                          = (11, Oc # C3, Bk#Oc # rev bs @ [z]  @ Oc # Bk \<up> Suc rex )"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+          moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, Oc # C3, Bk#Oc # rev bs @ [z]  @ Oc # Bk \<up> Suc rex )"
+          proof -
+            from A_case and \<open>rev ls1 = Oc # rev bs @ [z]\<close> and \<open>ls2 = Bk # Oc # C3\<close> and \<open>ls1 = z # bs @ [Oc]\<close>
+            have "\<exists>rex' ls1' ls2'. Oc # C3 = ls2'  \<and> Bk#Oc#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex = rev ls1'       @ Oc # Bk \<up> Suc rex' \<and>
+                                                     CL =  ls1' @ ls2'  \<and> hd ls1' = z \<and> tl ls1' \<noteq> [] "
+              by simp
+
+            with A_case \<open>rev ls1 = Oc # rev bs @ [z]\<close> and \<open>ls2 = Bk # Oc # C3\<close> and \<open>ls1 = z # bs @ [Oc]\<close>
+            show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, Oc # C3, Bk#Oc # rev bs @ [z]  @ Oc # Bk \<up> Suc rex )"         
+              by simp
+          qed
+          ultimately show ?thesis
+            using  assms and cf_cases and \<open>s = 11\<close> and A_case and \<open>rev ls1 = Oc # rev bs @ [z]\<close> and \<open>ls2 = Bk # Oc # C3\<close>
+            by simp      
+        next
+          fix C3
+          assume minor: "ls2 = Oc # C3"
+            (*
+               A_case: "l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> []"
+                  major1: "ls1 = Oc # bs @ [Oc]"
+                  major2: "rev ls1 = Oc # rev bs @ [Oc]"
+        
+                  minor1: "ls2 = Oc # C3"
+        
+                          l =  Oc # C3
+        
+                          r = rev ls1           @ Oc # Bk \<up> Suc rex
+        
+                          r = Oc#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex
+        
+                  thus: s11 \<longrightarrow> s11
+        
+                          (11, C3, Oc#Oc#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex )
+
+                          l' = C3
+                          r' = Oc#Oc#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex
+        
+                          ls2' = C3
+                          
+                          rev ls1' = Oc#Oc#(rev bs)@[Oc]
+        
+                          ls1' = Oc# bs @ [Oc] @ [Oc] = ls1@[Oc]
+        
+                          CL = ls1 @ ls2 = ls1 @ Oc # C3 = ls1 @ [Oc] @ [C3] = ls1' @ ls2'
+        
+                              \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> []
+        
+                           (\<exists>rex' ls1' ls2'. C3 = ls2'  \<and> Oc#Oc#(rev bs)@[Oc]  @ Oc # Bk \<up> Suc rex = rev ls1'       @ Oc # Bk \<up> Suc rex' \<and>
+                                                         CL =  ls1' @ ls2'  \<and> hd ls1' = Oc \<and> tl ls1' \<noteq> [])
+        
+               again       YYYY8    (\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2  \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [])
+             *)
+
+          with A_case have "step0 (11, Oc # C3 , Oc#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                          = (11, C3, Oc#Oc#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex)"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+          moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, C3, Oc#Oc#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex )"
+          proof -
+            from A_case and \<open>rev ls1 = Oc # rev bs @ [z]\<close> and \<open>ls2 = Oc # C3\<close> and \<open>ls1 = z # bs @ [Oc]\<close>
+            have "\<exists>rex' ls1' ls2'. C3 = ls2'  \<and> Oc#Oc#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex = rev ls1'       @ Oc # Bk \<up> Suc rex' \<and>
+                                                         CL =  ls1' @ ls2'  \<and> hd ls1' = z \<and> tl ls1' \<noteq> []"            
+              by simp
+
+            with A_case \<open>rev ls1 = Oc # rev bs @ [z]\<close> and \<open>ls2 = Oc # C3\<close> and \<open>ls1 = z # bs @ [Oc]\<close>
+            show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, C3, Oc#Oc#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex )"          
+              by simp
+          qed
+          ultimately show ?thesis
+            using  assms and cf_cases and \<open>s = 11\<close> and A_case and \<open>rev ls1 = Oc # rev bs @ [z]\<close> and  \<open>ls2 = Oc # C3\<close>
+            by simp      
+        qed
+      qed
+    next
+      (* YYYY3 *)
+      assume "\<exists>rex ls1 ls2. l = Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc # ls2 \<and> ls1 = [Bk]"
+      then obtain rex ls1 ls2 where
+        A_case: "l = Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc # ls2 \<and> ls1 = [Bk]" by blast
+      then have major2: "rev ls1 = [Bk]" by auto
+          (* "l = Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc # ls2 \<and> ls1 = [Bk]"
+
+              l = Oc # ls2
+              r = rev ls1          @ Oc # Bk \<up> Suc rex
+              r = [Bk] @ Oc # Bk \<up> Suc rex
+
+              l' = ls2
+              r' = Oc#[Bk] @ Oc # Bk \<up> Suc rex
+
+              \<longrightarrow> s12: (12, ls2, Oc#[Bk] @ Oc # Bk \<up> Suc rex )
+
+              ls1 = [Bk]
+              rev ls1 = [Bk]
+              
+              rev ls1' =   Oc#[Bk]
+
+              ls1' = Bk#[Oc]
+              ls2' = ls2
+
+              CL =  ls1 @ Oc # ls2 = [Bk] @ Oc # ls2 =  (ls1 @ [Oc]) @ ls2 = ls1'@ls2'
+
+              \<and> ls1' = Bk#[Oc]
+
+              r' = Oc#[Bk] @ Oc # Bk \<up> Suc rex = rev ls1'  @ Oc # Bk \<up> Suc rex
+
+               \<exists>rex' ls1' ls2'. ls2 = ls2'  \<and> Oc#[Bk] @ Oc # Bk \<up> Suc rex = rev ls1'  @ Oc # Bk \<up> Suc rex' \<and> CL = ls1' @ ls2' \<and>  ls1' = [Bk,Oc]
+
+              YYYY4  (\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc)
+
+           *)
+      with A_case have "step0 (11, Oc # ls2 , [Bk] @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                          = (12, ls2, Oc#[Bk] @ Oc # Bk \<up> Suc rex )"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+      moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (12, ls2, Oc#[Bk] @ Oc # Bk \<up> Suc rex )"
+      proof -
+        from A_case and \<open>rev ls1 = [Bk]\<close> 
+        have "\<exists>rex' ls1' ls2'. ls2 = ls2'  \<and> Oc#[Bk] @ Oc # Bk \<up> Suc rex = rev ls1'  @ Oc # Bk \<up> Suc rex' \<and>
+                               CL = ls1' @ ls2' \<and> tl ls1' \<noteq> [] \<and> last ls1' = Oc" (* YYYY4 *)           
+          by simp
+
+        with A_case \<open>rev ls1 = [Bk]\<close>
+        show "inv_tm_erase_right_then_dblBk_left_erp CL CR (12, ls2, Oc#[Bk] @ Oc # Bk \<up> Suc rex )"         
+          by simp
+      qed
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 11\<close> and A_case and \<open>rev ls1 = [Bk]\<close> 
+        by simp
+    next
+      assume "\<exists>rex. l = [] \<and> r = Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc)"  (* YYYY1' *)
+      then obtain rex where
+        A_case: "l = [] \<and> r = Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc)" by blast
+      then have "step0 (11, [] , Bk # rev CL @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                          = (12, [], Bk#Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (12, [], Bk#Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+      proof -
+        from A_case
+        have "\<exists>rex'. [] = [] \<and> Bk#Bk # rev CL @ Oc # Bk \<up> Suc rex  = Bk# Bk # rev CL @ Oc # Bk \<up> Suc rex' \<and> (CL = [] \<or> last CL = Oc)"  (* YYYY9 *)
+          by simp
+
+        with A_case
+        show "inv_tm_erase_right_then_dblBk_left_erp CL CR (12, [], Bk#Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+          by force
+      qed
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 11\<close> and A_case
+        by simp
+    next
+      assume "\<exists>rex. l = [] \<and> r = rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk" (* YYYY2' *)
+      then obtain rex where
+        A_case: "l = [] \<and> r = rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk" by blast
+      then have "hd (rev CL) = Bk"
+        by (simp add: hd_rev)
+      with A_case  have "step0 (11, [] , rev CL @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                          = (12, [], Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (12, [], Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+      proof -
+        from A_case 
+        have "\<exists>rex'. [] = [] \<and> Bk # rev CL @ Oc # Bk \<up> Suc rex  = Bk # rev CL @ Oc # Bk \<up> Suc rex' \<and> CL \<noteq> [] \<and> last CL = Bk" (*  YYYY6''' *)
+          by simp
+
+        with A_case
+        show "inv_tm_erase_right_then_dblBk_left_erp CL CR (12, [], Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+          by force
+      qed
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 11\<close> and A_case
+        by simp
+    next
+      assume "\<exists>rex. l = [] \<and> r = rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Oc" (* YYYY2'' *)
+      then obtain rex where
+        A_case: "l = [] \<and> r = rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Oc" by blast
+      then have "hd (rev CL) = Oc"
+        by (simp add: hd_rev)
+      with A_case  have "step0 (11, [] , rev CL @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                          = (11, [], Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+      proof -
+        from A_case
+        have "\<exists>rex'. [] = [] \<and> Bk # rev CL @ Oc # Bk \<up> Suc rex  = Bk # rev CL @ Oc # Bk \<up> Suc rex' \<and> (CL = [] \<or> last CL = Oc)" (*  YYYY1' *)
+          by simp
+
+        with A_case
+        show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+          by force
+      qed
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 11\<close> and A_case
+        by simp
+
+    qed
+  next
+    assume "s = 12"
+    with cf_cases and assms
+    have "
+          (\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2  \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc) \<or>
+          (\<exists>rex.         l = []  \<and> r = Bk#rev CL    @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk) \<or>
+          (\<exists>rex.         l = []  \<and> r = Bk#Bk#rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc))"
+      by auto
+
+    then have s12_cases:
+      "\<And>P. \<lbrakk> \<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2  \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc \<Longrightarrow> P;
+             \<exists>rex. l = []  \<and> r = Bk#rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk \<Longrightarrow> P;
+             \<exists>rex. l = []  \<and> r = Bk#Bk#rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc) \<Longrightarrow> P \<rbrakk>
+        \<Longrightarrow> P"
+      by blast
+
+    show ?thesis
+    proof (rule s12_cases)
+      (* YYYY4 *)
+      assume "\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc"
+      then obtain rex ls1 ls2 where
+        A_case: "l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2\<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc" by blast
+      then have "ls1 \<noteq> []" by auto 
+      with A_case have major: "hd (rev ls1) = Oc"
+        by (simp add: hd_rev)
+      show ?thesis
+      proof (rule noDblBk_cases)
+        from \<open>noDblBk CL\<close> show "noDblBk CL" .
+      next
+        from A_case show "CL = ls1 @ ls2" by auto
+      next
+        assume "ls2 = []"
+          (*
+          A_case: "l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc"
+          major: "hd (rev ls1) = Oc
+          ls1 \<noteq> []
+
+          ass: ls2 = []
+
+          l = []
+          r = rev ls1 @ Oc # Bk \<up> Suc rex   where "hd (rev ls1) = Oc"
+          
+          \<longrightarrow> s11
+ 
+          l' = []
+          r' = Bk#rev ls1 @ Oc # Bk \<up> Suc rex
+
+         *)
+        from A_case have "step0 (12, [] ,   Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)) tm_erase_right_then_dblBk_left
+                              = (11, [], Bk#Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex ))"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+        moreover from  A_case and major have "r = Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)"
+          by (metis Nil_is_append_conv \<open>ls1 \<noteq> []\<close> hd_Cons_tl hd_append2 list.simps(3) rev_is_Nil_conv)
+
+        ultimately have "step0 (12, [] , rev ls1 @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                             = (11, [], Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+          by (simp add: A_case)
+            (* 
+            CL = ls1 @ ls2 \<and> tl ls1 \<noteq> []
+            CL = ls1
+
+            l' = []
+            r' = Bk# (rev CL) @ Oc # Bk \<up> Suc rex 
+         *)
+        moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+        proof -
+          from A_case and \<open>ls2 = []\<close> have "rev ls1 = rev CL" by auto
+          with  A_case and \<open>ls2 = []\<close> have "\<exists>rex'. [] = []  \<and> Bk# rev ls1 @ Oc # Bk \<up> Suc rex = Bk# rev CL    @ Oc # Bk \<up> Suc rex' \<and> (CL = [] \<or> last CL = Oc)" (* YYYY1' *)
+            by simp
+          with A_case \<open>r = Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)\<close> and \<open>ls2 = []\<close>
+          show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+            by force
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 12\<close> and A_case and \<open>ls2 = []\<close>
+          by simp
+      next
+        assume "ls2 = [Bk]"
+        from A_case have "step0 (12, [Bk] ,   Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)) tm_erase_right_then_dblBk_left
+                              = (11, [], Bk#Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex ))"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+        moreover from  A_case and major have "r = Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)"
+          by (metis Nil_is_append_conv \<open>ls1 \<noteq> []\<close> hd_Cons_tl hd_append2 list.simps(3) rev_is_Nil_conv)
+
+        ultimately have "step0 (12, [Bk] , rev ls1 @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                             = (11, [], Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+          by (simp add: A_case)
+            (* 
+            CL = ls1 @ ls2 \<and> tl ls1 \<noteq> []
+            CL = ls1 @ [Bk] = (ls1 @ [Bk]) = ls1'
+
+            l' = []
+            r' = rev ls1' = rev CL
+
+            l' = []
+            r' = rev CL @ Oc # Bk \<up> Suc rex 
+         *)
+        moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+        proof -
+          from A_case and \<open>ls2 = [Bk]\<close> have "CL = ls1 @ [Bk]" by auto
+          then have "\<exists>rex'. [] = []  \<and> Bk#rev ls1 @ Oc # Bk \<up> Suc rex = rev CL    @ Oc # Bk \<up> Suc rex' \<and> CL \<noteq> []  \<and> last CL = Bk" (* YYYY2' *)
+            by simp
+          with A_case \<open>r = Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)\<close> and \<open>ls2 = [Bk]\<close>
+          show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, [], Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+            by force
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 12\<close> and A_case and \<open>ls2 = [Bk]\<close>
+          by simp
+      next
+        fix C3
+        assume minor: "ls2 = Bk # Oc # C3"
+          (*
+          A_case: "l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc"
+          major: "hd (rev ls1) = Oc
+          ls1 \<noteq> []
+
+          ass: ls2 = Bk # Oc # C3
+
+          l = Bk # Oc # C3
+          r = rev ls1 @ Oc # Bk \<up> Suc rex   where "hd (rev ls1) = Oc"
+          
+          \<longrightarrow> s11
+ 
+          l' = Oc # C3
+          r' = Bk#rev ls1 @ Oc # Bk \<up> Suc rex
+
+         *)
+        from A_case have "step0 (12, Bk # Oc # C3 ,   Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)) tm_erase_right_then_dblBk_left
+                              = (11, Oc # C3, Bk#Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex ))"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+        moreover from  A_case and major have "r = Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)"
+          by (metis Nil_is_append_conv \<open>ls1 \<noteq> []\<close> hd_Cons_tl hd_append2 list.simps(3) rev_is_Nil_conv)
+
+        ultimately have "step0 (12, Bk # Oc # C3 , rev ls1 @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                             = (11, Oc # C3, Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+          by (simp add: A_case)
+            (* 
+            CL = ls1 @ ls2 \<and> tl ls1 \<noteq> []
+            CL = ls1 @ (Bk # Oc # C3) = ls1 @ [Bk] @ (Oc # C3)
+
+            ls1' = ls1 @ [Bk]
+            ls2' = Oc # C3
+
+            rev ls1' = Bk# (rev ls1)
+
+            l' =  Oc # C3
+            r' = rev ls1' @ Oc # Bk \<up> Suc rex \<and>
+
+            CL = ls1' @ ls2'  \<and> hd ls1' = Oc \<and> tl ls1' \<noteq> []
+
+            YYYY8
+              (\<exists>rex ls1 ls2. l =       ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2       \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [])
+         *)
+        moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, Oc # C3, Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+        proof -
+          from A_case and \<open>ls2 = Bk # Oc # C3\<close> have "CL = ls1 @ [Bk] @ (Oc # C3)" and "rev (ls1 @ [Bk]) = Bk # rev ls1" by auto
+          with  \<open>ls1 \<noteq> []\<close>
+          have "\<exists>rex' ls1' ls2'. Oc # C3 = ls2'  \<and> Bk# rev ls1 @ Oc # Bk \<up> Suc rex = rev ls1' @ Oc # Bk \<up> Suc rex' \<and> CL = ls1' @ ls2' \<and> tl ls1' \<noteq> []" (* YYYY8 *)          
+            by (simp add: A_case )
+          with A_case \<open>r = Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)\<close> and \<open>ls2 = Bk # Oc # C3\<close>
+          show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, Oc # C3, Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+            by force
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 12\<close> and A_case and \<open>ls2 = Bk # Oc # C3\<close>
+          by simp
+      next
+        fix C3
+        assume minor: "ls2 = Oc # C3"
+          (*
+          A_case: "l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc"
+          major: "hd (rev ls1) = Oc
+          ls1 \<noteq> []
+
+          ass: ls2 = Bk # Oc # C3
+
+          l = ls2 = Oc # C3
+          r = rev ls1 @ Oc # Bk \<up> Suc rex   where "hd (rev ls1) = Oc"
+          
+          \<longrightarrow> s11
+ 
+          l' = C3
+          r' = Oc#rev ls1 @ Oc # Bk \<up> Suc rex
+
+         *)
+        from A_case have "step0 (12, Oc # C3 ,   Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)) tm_erase_right_then_dblBk_left
+                              = (11, C3, Oc#Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex ))"
+          by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+
+        moreover from  A_case and major have "r = Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)"
+          by (metis Nil_is_append_conv \<open>ls1 \<noteq> []\<close> hd_Cons_tl hd_append2 list.simps(3) rev_is_Nil_conv)
+
+        ultimately have "step0 (12, Oc # C3 , rev ls1 @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                             = (11, C3, Oc# rev ls1 @ Oc # Bk \<up> Suc rex )"
+          by (simp add: A_case)
+            (* 
+            CL = ls1 @ ls2 \<and> tl ls1 \<noteq> []
+            CL = ls1 @ (Oc # C3) = ls1 @ [Oc] @ (C3)
+
+            ls1' = ls1 @ [Oc]
+            ls2' = C3
+
+            rev ls1' = Oc# (rev ls1)
+
+            l' = C3
+            r' = rev ls1' @ Oc # Bk \<up> Suc rex \<and>
+
+            CL = ls1' @ ls2'  \<and> hd ls1' = Oc \<and> tl ls1' \<noteq> []
+
+            YYYY8
+              (\<exists>rex ls1 ls2. l =       ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2       \<and> hd ls1 = Oc \<and> tl ls1 \<noteq> [])
+         *)
+        moreover have "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, C3, Oc# rev ls1 @ Oc # Bk \<up> Suc rex )"
+        proof -
+          from A_case and \<open>ls2 = Oc # C3\<close> have "CL = ls1 @ [Oc] @ (C3)" and "rev (ls1 @ [Oc]) = Oc # rev ls1" by auto
+          with  \<open>ls1 \<noteq> []\<close>
+          have "\<exists>rex' ls1' ls2'. C3 = ls2'  \<and> Oc# rev ls1 @ Oc # Bk \<up> Suc rex = rev ls1' @ Oc # Bk \<up> Suc rex' \<and> CL = ls1' @ ls2'  \<and> tl ls1' \<noteq> []" (* YYYY8 *)          
+            by (simp add: A_case )
+          with A_case \<open>r = Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)\<close> and \<open>ls2 = Oc # C3\<close>
+          show "inv_tm_erase_right_then_dblBk_left_erp CL CR (11, C3, Oc# rev ls1 @ Oc # Bk \<up> Suc rex )"
+            by force
+        qed
+        ultimately show ?thesis
+          using  assms and cf_cases and \<open>s = 12\<close> and A_case and \<open>ls2 = Oc # C3\<close>
+          by simp
+      qed
+    next
+      (* YYYY6''' *)
+      assume "\<exists>rex. l = [] \<and> r = Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk"
+      then obtain rex where
+        A_case: "l = [] \<and> r = Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk" by blast
+      then have "step0 (12, [] , Bk # rev CL @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                              = (0, [], Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover with A_case have "inv_tm_erase_right_then_dblBk_left_erp CL CR (0, [], Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+        by auto
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 12\<close> and A_case 
+        by simp
+    next
+      (* YYYY9 *)
+      assume "\<exists>rex. l = [] \<and> r = Bk # Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc)"
+      then obtain rex where
+        A_case: "l = [] \<and> r = Bk # Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc)" by blast
+      then have "step0 (12, [] , Bk # Bk # rev CL @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                              = (0, [], Bk# Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover with A_case have "inv_tm_erase_right_then_dblBk_left_erp CL CR (0, [], Bk# Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+        by auto
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 12\<close> and A_case 
+        by simp
+    qed
+  next
+    assume "s = 0"
+    with cf_cases and assms
+    have "(\<exists>rex. l = [] \<and>  r = [Bk, Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex \<and> (CL = [] \<or> last CL = Oc) ) \<or>
+          (\<exists>rex. l = [] \<and>  r = [Bk]     @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex \<and> CL \<noteq> [] \<and> last CL = Bk)"
+      by auto
+    then have s0_cases:
+      "\<And>P. \<lbrakk> \<exists>rex. l = [] \<and>  r = [Bk, Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex \<and> (CL = [] \<or> last CL = Oc) \<Longrightarrow> P;
+             \<exists>rex. l = [] \<and>  r = [Bk]     @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex \<and> CL \<noteq> [] \<and> last CL = Bk \<Longrightarrow> P \<rbrakk>
+        \<Longrightarrow> P"
+      by blast
+
+    show ?thesis
+    proof (rule s0_cases)
+      assume "\<exists>rex. l = [] \<and> r = [Bk, Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex \<and> (CL = [] \<or> last CL = Oc)"
+      then obtain rex where
+        A_case: "l = [] \<and> r = [Bk, Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex \<and> (CL = [] \<or> last CL = Oc)" by blast
+      then have "step0 (0, [] , [Bk, Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex) tm_erase_right_then_dblBk_left
+                              = (0, [], Bk# Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover with A_case have "inv_tm_erase_right_then_dblBk_left_erp CL CR (0, [], Bk# Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+        by auto
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 0\<close> and A_case 
+        by simp
+    next
+      assume "\<exists>rex. l = [] \<and> r = [Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex \<and> CL \<noteq> [] \<and> last CL = Bk"
+      then obtain rex where
+        A_case: "l = [] \<and> r = [Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex \<and> CL \<noteq> [] \<and> last CL = Bk" by blast
+      then have "step0 (0, [] , [Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex) tm_erase_right_then_dblBk_left
+                              = (0, [], Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+        by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+      moreover with A_case have "inv_tm_erase_right_then_dblBk_left_erp CL CR (0, [], Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+        by auto
+      ultimately show ?thesis
+        using  assms and cf_cases and \<open>s = 0\<close> and A_case 
+        by simp
+    qed
+  qed
+qed
+
+(* -------------- steps - lemma for the invariants of the ERASE path of tm_erase_right_then_dblBk_left ------------------ *)
+
+lemma inv_tm_erase_right_then_dblBk_left_erp_steps: 
+  assumes "inv_tm_erase_right_then_dblBk_left_erp CL CR cf"
+  and "noDblBk CL" and "noDblBk CR"
+  shows "inv_tm_erase_right_then_dblBk_left_erp CL CR (steps0 cf tm_erase_right_then_dblBk_left stp)"
+proof (induct stp)
+  case 0
+  with assms show ?case
+    by (auto simp add: inv_tm_erase_right_then_dblBk_left_erp_step step.simps steps.simps)
+next
+  case (Suc stp)
+  with assms show ?case
+    using inv_tm_erase_right_then_dblBk_left_erp_step step_red by auto 
+qed
+
+
+(* -------------- Partial correctness for the ERASE path of tm_erase_right_then_dblBk_left ------------------ *)
+
+lemma tm_erase_right_then_dblBk_left_erp_partial_correctness_CL_is_Nil:
+  assumes "\<exists>stp. is_final (steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp)"
+  and "noDblBk CL"
+  and "noDblBk CR"
+  and "CL = []"
+  shows "\<lbrace> \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex ) \<rbrace>"
+proof (rule Hoare_consequence)
+  show "( \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) ) \<mapsto> ( \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) )"
+    by auto
+next
+  from assms show "inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR
+                    \<mapsto> ( \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex) )"
+    by (simp add: assert_imp_def  tape_of_list_def tape_of_nat_def)
+next
+  show " \<lbrace>\<lambda>tap. tap = ([Bk, Oc] @ CL, CR)\<rbrace>
+           tm_erase_right_then_dblBk_left
+         \<lbrace>inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR\<rbrace>"
+  proof (rule Hoare_haltI)
+    fix l::"cell list"
+    fix r:: "cell list"
+    assume major: "(l, r) = ([Bk, Oc] @ CL, CR)"
+    show "\<exists>n. is_final (steps0 (1, l, r) tm_erase_right_then_dblBk_left n) \<and>
+                inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR
+                 holds_for steps0 (1, l, r) tm_erase_right_then_dblBk_left n"
+    proof -
+      from major and assms
+      have "\<exists>stp. is_final (steps0 (1, l, r) tm_erase_right_then_dblBk_left stp)"
+        by blast
+      then obtain stp where
+        w_stp: "is_final (steps0 (1, l, r) tm_erase_right_then_dblBk_left stp)" by blast
+      moreover have "inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR
+                       holds_for steps0 (1, l, r) tm_erase_right_then_dblBk_left stp"
+      proof -
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (1, l, r)"
+          by (simp add: major tape_of_list_def tape_of_nat_def)
+        with assms
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (steps0 (1, l, r) tm_erase_right_then_dblBk_left stp)"
+          using inv_tm_erase_right_then_dblBk_left_erp_steps by auto
+        then show ?thesis
+          by (smt holds_for.elims(3) inv_tm_erase_right_then_dblBk_left_erp.simps is_final_eq w_stp)
+      qed
+      ultimately show ?thesis by auto
+    qed
+  qed
+qed
+
+lemma tm_erase_right_then_dblBk_left_erp_partial_correctness_CL_ew_Bk:
+  assumes "\<exists>stp. is_final (steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp)"
+  and "noDblBk CL"
+  and "noDblBk CR"
+  and "CL \<noteq> []"
+  and "last CL = Bk"   
+  shows "\<lbrace> \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex ) \<rbrace>"
+proof (rule Hoare_consequence)
+  show "( \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) ) \<mapsto> ( \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) )"
+    by auto
+next
+  from assms show "inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR
+                    \<mapsto> ( \<lambda>tap. \<exists>rex. tap = ([], [Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex) )"
+    by (simp add: assert_imp_def  tape_of_list_def tape_of_nat_def)
+next
+  show " \<lbrace>\<lambda>tap. tap = ([Bk, Oc] @ CL, CR)\<rbrace>
+           tm_erase_right_then_dblBk_left
+         \<lbrace>inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR\<rbrace>"
+  proof (rule Hoare_haltI)
+    fix l::"cell list"
+    fix r:: "cell list"
+    assume major: "(l, r) = ([Bk, Oc] @ CL, CR)"
+    show "\<exists>n. is_final (steps0 (1, l, r) tm_erase_right_then_dblBk_left n) \<and>
+                inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR
+                 holds_for steps0 (1, l, r) tm_erase_right_then_dblBk_left n"
+    proof -
+      from major and assms
+      have "\<exists>stp. is_final (steps0 (1, l, r) tm_erase_right_then_dblBk_left stp)"
+        by blast
+      then obtain stp where
+        w_stp: "is_final (steps0 (1, l, r) tm_erase_right_then_dblBk_left stp)" by blast
+      moreover have "inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR
+                       holds_for steps0 (1, l, r) tm_erase_right_then_dblBk_left stp"
+      proof -
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (1, l, r)"
+          by (simp add: major tape_of_list_def tape_of_nat_def)
+        with assms
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (steps0 (1, l, r) tm_erase_right_then_dblBk_left stp)"
+          using inv_tm_erase_right_then_dblBk_left_erp_steps by auto
+        then show ?thesis
+          by (smt holds_for.elims(3) inv_tm_erase_right_then_dblBk_left_erp.simps is_final_eq w_stp)
+      qed
+      ultimately show ?thesis by auto
+    qed
+  qed
+qed
+
+lemma tm_erase_right_then_dblBk_left_erp_partial_correctness_CL_ew_Oc:
+  assumes "\<exists>stp. is_final (steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp)"
+    and "noDblBk CL"
+    and "noDblBk CR"
+    and "CL \<noteq> []"
+    and "last CL = Oc"   
+  shows "\<lbrace> \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex ) \<rbrace>"
+proof (rule Hoare_consequence)
+  show "( \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) ) \<mapsto> ( \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) )"
+    by auto
+next
+  from assms show "inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR
+                    \<mapsto> ( \<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex) )"
+    by (simp add: assert_imp_def  tape_of_list_def tape_of_nat_def)
+next
+  show " \<lbrace>\<lambda>tap. tap = ([Bk, Oc] @ CL, CR)\<rbrace>
+           tm_erase_right_then_dblBk_left
+         \<lbrace>inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR\<rbrace>"
+  proof (rule Hoare_haltI)
+    fix l::"cell list"
+    fix r:: "cell list"
+    assume major: "(l, r) = ([Bk, Oc] @ CL, CR)"
+    show "\<exists>n. is_final (steps0 (1, l, r) tm_erase_right_then_dblBk_left n) \<and>
+                inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR
+                 holds_for steps0 (1, l, r) tm_erase_right_then_dblBk_left n"
+    proof -
+      from major and assms
+      have "\<exists>stp. is_final (steps0 (1, l, r) tm_erase_right_then_dblBk_left stp)"
+        by blast
+      then obtain stp where
+        w_stp: "is_final (steps0 (1, l, r) tm_erase_right_then_dblBk_left stp)" by blast
+      moreover have "inv_tm_erase_right_then_dblBk_left_erp_s0 CL CR
+                       holds_for steps0 (1, l, r) tm_erase_right_then_dblBk_left stp"
+      proof -
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (1, l, r)"
+          by (simp add: major tape_of_list_def tape_of_nat_def)
+        with assms
+        have "inv_tm_erase_right_then_dblBk_left_erp CL CR (steps0 (1, l, r) tm_erase_right_then_dblBk_left stp)"
+          using inv_tm_erase_right_then_dblBk_left_erp_steps by auto
+        then show ?thesis
+          by (smt holds_for.elims(3) inv_tm_erase_right_then_dblBk_left_erp.simps is_final_eq w_stp)
+      qed
+      ultimately show ?thesis by auto
+    qed
+  qed
+qed
+
+
+(* -------------- Termination for the ERASE path of tm_erase_right_then_dblBk_left ------------------ *)
+(* 
+    Lexicographic orders (See List.measures)
+    quote: "These are useful for termination proofs"
+    
+    lemma in_measures[simp]:
+      "(x, y) \<in> measures [] = False"
+      "(x, y) \<in> measures (f # fs)
+             = (f x < f y \<or> (f x = f y \<and> (x, y) \<in> measures fs))"
+*)
+
+(* Assemble a lexicographic measure function for the ERASE path *)
+
+definition measure_tm_erase_right_then_dblBk_left_erp :: "(config \<times> config) set"
+  where
+    "measure_tm_erase_right_then_dblBk_left_erp = measures [
+         \<lambda>(s, l, r). (
+              if s = 0
+              then 0
+              else if s < 6
+                   then 13 - s
+                   else 1),
+
+         \<lambda>(s, l, r). (
+              if s = 6
+              then if r = [] \<or> (hd r) = Bk
+                   then 1
+                   else 2
+              else 0 ),
+
+         \<lambda>(s, l, r). (
+              if 7 \<le> s \<and> s \<le> 9
+              then 2+ length r
+              else 1), 
+
+         \<lambda>(s, l, r). (
+              if 7 \<le> s \<and> s \<le> 9
+              then  
+                if r = [] \<or> hd r = Bk
+                then 2
+                else 3
+              else 1),
+
+         \<lambda>(s, l, r).(
+              if 7 \<le> s \<and> s \<le> 10
+              then 13 - s
+              else 1),
+
+         \<lambda>(s, l, r). (
+              if 10 \<le> s 
+              then 2+ length l
+              else 1),
+
+
+         \<lambda>(s, l, r). (
+              if 11 \<le> s
+              then if hd r = Oc
+                   then 3
+                   else 2
+              else 1),
+
+         \<lambda>(s, l, r).(
+              if 11 \<le> s
+              then 13 - s
+              else 1)
+
+      ]"
+
+lemma wf_measure_tm_erase_right_then_dblBk_left_erp: "wf measure_tm_erase_right_then_dblBk_left_erp"
+  unfolding measure_tm_erase_right_then_dblBk_left_erp_def
+  by (auto)
+
+lemma measure_tm_erase_right_then_dblBk_left_erp_induct [case_names Step]: 
+  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_tm_erase_right_then_dblBk_left_erp\<rbrakk>
+   \<Longrightarrow> \<exists>n. P (f n)"
+  using wf_measure_tm_erase_right_then_dblBk_left_erp
+  by (metis wf_iff_no_infinite_down_chain)
+
+lemma spike_erp_cases:
+"CL \<noteq> [] \<and> last CL = Bk \<or> CL \<noteq> [] \<and> last CL = Oc \<or> CL = []"
+  using cell.exhaust by blast
+
+lemma tm_erase_right_then_dblBk_left_erp_halts:
+  assumes "noDblBk CL"
+    and "noDblBk CR"
+  shows
+    "\<exists>stp. is_final (steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp)"
+proof (induct rule: measure_tm_erase_right_then_dblBk_left_erp_induct)
+  case (Step stp)
+  then have not_final: "\<not> is_final (steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp)" .
+
+  have INV: "inv_tm_erase_right_then_dblBk_left_erp CL CR (steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp)"
+  proof (rule_tac inv_tm_erase_right_then_dblBk_left_erp_steps)
+    show  "inv_tm_erase_right_then_dblBk_left_erp CL CR (1, [Bk,Oc] @ CL, CR)"
+      by (simp add: tape_of_list_def tape_of_nat_def )
+  next
+    from assms show "noDblBk CL" by auto
+  next
+    from assms show "noDblBk CR" by auto
+  qed
+  have SUC_STEP_RED: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+        step0 (steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp) tm_erase_right_then_dblBk_left"
+    by (rule step_red)
+  show "( steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp),
+          steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp
+        ) \<in> measure_tm_erase_right_then_dblBk_left_erp"
+  proof (cases "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp")
+    case (fields s l r)
+    then have
+      cf_at_stp: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (s, l, r)" .
+    show ?thesis
+    proof (rule tm_erase_right_then_dblBk_left_erp_cases)
+      from INV and cf_at_stp
+      show "inv_tm_erase_right_then_dblBk_left_erp CL CR (s, l, r)" by auto
+    next
+      assume "s=0" (* not possible *)
+      with cf_at_stp not_final
+      show ?thesis by auto
+    next
+      assume "s=1"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (1, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=1\<close> and INV
+      have unpacked_INV: "(l = [Bk,Oc] @ CL \<and> r = CR)"
+        by auto      
+          (* compute the next state *)
+      show ?thesis
+      proof (cases CR)
+        case Nil
+        then have minor: "CR = []" .
+
+        with unpacked_INV cf_at_stp and \<open>s=1\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left"
+          by auto
+        also with minor and unpacked_INV
+        have "... = (2,Oc#CL, Bk#CR)"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (2,Oc#CL, Bk#CR)"
+          by auto
+            (* establish measure *)
+        with cf_at_current show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next
+        case (Cons a rs)
+        then have major: "CR = a # rs" .
+        then show ?thesis
+        proof (cases a)
+          case Bk
+          with major have minor: "CR = Bk#rs" by auto
+          with unpacked_INV cf_at_stp and \<open>s=1\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left"
+            by auto
+          also with minor and unpacked_INV
+          have "... = (2,Oc#CL, Bk#CR)"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (2,Oc#CL, Bk#CR)"
+            by auto
+              (* establish measure *)
+          with cf_at_current show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        next
+          case Oc
+          with major have minor: "CR = Oc#rs" by auto
+          with unpacked_INV cf_at_stp and \<open>s=1\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left"
+            by auto
+          also with minor and unpacked_INV
+          have "... = (2,Oc#CL, Bk#CR)"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (2,Oc#CL, Bk#CR)"
+            by auto
+              (* establish measure *)
+          with cf_at_current show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        qed
+      qed
+    next
+      assume "s=2"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (2, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=2\<close> and INV
+      have unpacked_INV: "(l = [Oc]    @ CL \<and> r = Bk#CR)"
+        by auto
+          (* compute the next state *)
+      then have minor: "r = Bk#CR" by auto
+      with unpacked_INV cf_at_stp and \<open>s=2\<close> and SUC_STEP_RED
+      have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (2, [Oc] @ CL, Bk#CR) tm_erase_right_then_dblBk_left"
+        by auto
+      also with minor and unpacked_INV
+      have "... = (3,CL, Oc#Bk#CR)"
+        by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+      finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (3,CL, Oc#Bk#CR)"
+        by auto
+          (* establish measure *)
+      with cf_at_current show ?thesis
+        by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+    next
+      assume "s=3"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (3, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=3\<close> and INV
+      have unpacked_INV: "(l =           CL \<and> r = Oc#Bk#CR)"
+        by auto
+          (* compute the next state *)
+      then have minor: "r = Oc#Bk#CR" by auto
+      with unpacked_INV cf_at_stp and \<open>s=3\<close> and SUC_STEP_RED
+      have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (3, CL, Oc#Bk#CR) tm_erase_right_then_dblBk_left"
+        by auto
+      also with minor and unpacked_INV
+      have "... = (5,[Oc] @ CL, Bk#CR)"
+        by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+      finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (5,[Oc] @ CL, Bk#CR)"
+        by auto
+          (* establish measure *)
+      with cf_at_current show ?thesis
+        by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+    next
+      assume "s=5"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (5, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=5\<close> and INV
+      have unpacked_INV: "(l = [Oc]    @ CL \<and> r = Bk#CR)"
+        by auto
+          (* compute the next state *)
+      then have minor: "r = Bk#CR" by auto
+      with unpacked_INV cf_at_stp and \<open>s=5\<close> and SUC_STEP_RED
+      have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (5, [Oc]    @ CL, Bk#CR) tm_erase_right_then_dblBk_left"
+        by auto
+      also with minor and unpacked_INV
+      have "... = (6, [Bk,Oc] @ CL, CR)"
+        by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+      finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (6, [Bk,Oc] @ CL, CR)"
+        by auto
+          (* establish measure *)
+      with cf_at_current show ?thesis
+        by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+    next
+      assume "s=6"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (6, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=6\<close> and INV
+      have unpacked_INV: "(l = [Bk,Oc] @ CL \<and> ( (CR = [] \<and> r = CR) \<or>
+                                                (CR \<noteq> [] \<and> (r = CR \<or> r = Bk # tl CR))
+                                               ))"
+        by auto
+      then have unpacked_INV': "l = [Bk,Oc] @ CL \<and> CR = [] \<and> r = CR \<or>
+                               l = [Bk,Oc] @ CL \<and> CR \<noteq> [] \<and> r = Oc # tl CR \<or>
+                               l = [Bk,Oc] @ CL \<and> CR \<noteq> [] \<and> r = Bk # tl CR"
+        by (metis (full_types) cell.exhaust list.sel(3) neq_Nil_conv)
+      then show ?thesis
+      proof
+        assume minor: "l = [Bk, Oc] @ CL \<and> CR = [] \<and> r = CR"
+        with unpacked_INV cf_at_stp and \<open>s=6\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (6, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left"
+          by auto
+        also with minor and unpacked_INV
+        have "... = (7,Bk#[Bk, Oc] @ CL, CR)"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (7,Bk#[Bk, Oc] @ CL, CR)"
+          by auto
+            (* establish measure *)
+        with cf_at_current show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next
+        assume "l = [Bk, Oc] @ CL \<and> CR \<noteq> [] \<and> r = Oc # tl CR \<or> l = [Bk, Oc] @ CL \<and> CR \<noteq> [] \<and> r = Bk # tl CR"
+        then show ?thesis
+        proof
+          assume minor: "l = [Bk, Oc] @ CL \<and> CR \<noteq> [] \<and> r = Bk # tl CR"
+          with unpacked_INV cf_at_stp and \<open>s=6\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (6, [Bk, Oc] @ CL, Bk # tl CR) tm_erase_right_then_dblBk_left"
+            by auto
+          also with minor
+          have "... = (7,Bk#[Bk, Oc] @ CL, tl CR)"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (7,Bk#[Bk, Oc] @ CL, tl CR)"
+            by auto
+              (* establish measure *)
+          with cf_at_current show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        next
+          assume minor: "l = [Bk, Oc] @ CL \<and> CR \<noteq> [] \<and> r = Oc # tl CR"
+          with unpacked_INV cf_at_stp and \<open>s=6\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (6, [Bk, Oc] @ CL, Oc # tl CR) tm_erase_right_then_dblBk_left"
+            by auto
+          also with minor
+          have "... = (6, [Bk, Oc] @ CL, Bk # tl CR)"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (6, [Bk, Oc] @ CL, Bk # tl CR)"
+            by auto
+              (* establish measure *)
+          with cf_at_current and minor show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        qed
+      qed
+    next
+      assume "s=7"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (7, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=7\<close> and INV
+      have  "(\<exists>lex. l = Bk \<up> Suc lex @ [Bk,Oc] @ CL) \<and> (\<exists>rs. CR = rs @ r)"
+        by auto
+      then obtain lex rs where
+        unpacked_INV: "l = Bk \<up> Suc lex @ [Bk,Oc] @ CL \<and> CR = rs @ r" by blast
+          (* compute the next state *)
+      show ?thesis
+      proof (cases r)
+        case Nil
+        then have minor: "r = []" .
+        with unpacked_INV cf_at_stp and \<open>s=7\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (7, Bk \<up> Suc lex @ [Bk,Oc] @ CL, r) tm_erase_right_then_dblBk_left"
+          by auto
+        also with minor and unpacked_INV
+        have "... = (9, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, r)"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (9, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, r)"
+          by auto
+            (* establish measure *)
+        with cf_at_current and minor show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next
+        case (Cons a rs')
+        then have major: "r = a # rs'" .
+        then show ?thesis
+        proof (cases a)
+          case Bk
+          with major have minor: "r = Bk#rs'" by auto
+
+          with unpacked_INV cf_at_stp and \<open>s=7\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (7,  Bk \<up> Suc lex @ [Bk,Oc] @ CL, r) tm_erase_right_then_dblBk_left"
+            by auto
+          also with minor and unpacked_INV
+          have "... = (9, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, rs')"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (9, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, rs')"
+            by auto
+              (* establish measure *)
+          with cf_at_current and minor show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        next
+          case Oc
+          with major have minor: "r = Oc#rs'" by auto
+
+          with unpacked_INV cf_at_stp and \<open>s=7\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (7,  Bk \<up> Suc lex @ [Bk,Oc] @ CL, Oc#rs') tm_erase_right_then_dblBk_left"
+            by auto
+          also with minor and unpacked_INV
+          have "... = (8, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs')"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (8, Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs')"
+            by auto
+              (* establish measure *)
+          with cf_at_current and minor show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        qed
+      qed
+    next
+      assume "s=8"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (8, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=8\<close> and INV
+      have  "(\<exists>lex. l = Bk \<up> Suc lex @ [Bk,Oc] @ CL) \<and> (\<exists>rs1 rs2. CR = rs1 @ [Oc] @ rs2 \<and> r = Bk#rs2)"
+        by auto
+      then obtain lex rs1 rs2 where
+        unpacked_INV: "l = Bk \<up> Suc lex @ [Bk,Oc] @ CL \<and> CR = rs1 @ [Oc] @ rs2 \<and> r = Bk#rs2 " by blast
+          (* compute the next state *)
+      with  cf_at_stp and \<open>s=8\<close> and SUC_STEP_RED
+      have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (8,  Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs2) tm_erase_right_then_dblBk_left"
+        by auto
+      also with unpacked_INV
+      have "... = (7, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, rs2)"
+        by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+      finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                      = (7, Bk \<up> Suc (Suc lex) @ [Bk,Oc] @ CL, rs2)"
+        by auto
+          (* establish measure *)
+      with cf_at_current and unpacked_INV show ?thesis
+        by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+    next
+      assume "s=9"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (9, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=9\<close> and INV
+      have  "(\<exists>lex. l = Bk \<up> Suc lex @ [Bk,Oc] @ CL) \<and> (\<exists>rs. CR = rs @ [Bk] @ r \<or> CR = rs \<and> r = [])"
+        by auto
+      then obtain lex rs where
+        "l = Bk \<up> Suc lex @ [Bk,Oc] @ CL \<and> (CR = rs @ [Bk] @ r \<or> CR = rs \<and> r = [])" by blast
+      then have unpacked_INV: "l = Bk \<up> Suc lex @ [Bk,Oc] @ CL \<and> CR = rs @ [Bk] @ r \<or>
+                               l = Bk \<up> Suc lex @ [Bk,Oc] @ CL \<and> CR = rs \<and> r = []" by auto
+      then show ?thesis
+      proof
+        (* compute the next state *)
+        assume major: "l = Bk \<up> Suc lex @ [Bk, Oc] @ CL \<and> CR = rs @ [Bk] @ r"
+        show ?thesis
+        proof (cases r)
+          case Nil
+          then have minor: "r = []" .
+          with unpacked_INV cf_at_stp and \<open>s=9\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (9, Bk \<up> Suc lex @ [Bk,Oc] @ CL, r) tm_erase_right_then_dblBk_left"
+            by auto
+          also with minor and unpacked_INV
+          have "... = (10, Bk \<up> lex @ [Bk,Oc] @ CL, Bk#r)"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (10, Bk \<up> lex @ [Bk,Oc] @ CL, Bk#r)"
+            by auto
+              (* establish measure *)
+          with cf_at_current and minor show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        next
+          case (Cons a rs')
+          then have major2: "r = a # rs'" .
+          then show ?thesis
+          proof (cases a)
+            case Bk
+            with major2 have minor: "r = Bk#rs'" by auto
+            with unpacked_INV cf_at_stp and \<open>s=9\<close> and SUC_STEP_RED
+            have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (9,  Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs') tm_erase_right_then_dblBk_left"
+              by auto
+            also with minor and unpacked_INV
+            have "... = (10, Bk \<up> lex @ [Bk,Oc] @ CL, Bk#Bk#rs')"
+              by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (10, Bk \<up> lex @ [Bk,Oc] @ CL, Bk#Bk#rs')"
+              by auto
+                (* establish measure *)
+            with cf_at_current and minor show ?thesis
+              by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+          next
+            case Oc
+            with major2 have minor: "r = Oc#rs'" by auto
+            with unpacked_INV cf_at_stp and \<open>s=9\<close> and SUC_STEP_RED
+            have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (9,  Bk \<up> Suc lex @ [Bk,Oc] @ CL, Oc#rs') tm_erase_right_then_dblBk_left"
+              by auto
+            also with minor and unpacked_INV
+            have "... = (8,  Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs')"
+              by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (8,  Bk \<up> Suc lex @ [Bk,Oc] @ CL, Bk#rs')"
+              by auto
+                (* establish measure *)
+            with cf_at_current and minor show ?thesis
+              by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+          qed
+        qed
+      next
+        (* compute the next state *)
+        assume major: "l = Bk \<up> Suc lex @ [Bk, Oc] @ CL \<and> CR = rs \<and> r = []"
+        with unpacked_INV cf_at_stp and \<open>s=9\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (9,  Bk \<up> Suc lex @ [Bk,Oc] @ CL, []) tm_erase_right_then_dblBk_left"
+          by auto
+        also with unpacked_INV
+        have "... = (10,  Bk \<up> lex @ [Bk,Oc] @ CL, [Bk])"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (10,  Bk \<up> lex @ [Bk,Oc] @ CL, [Bk])"
+          by auto
+            (* establish measure *)
+        with cf_at_current show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      qed
+    next
+      assume "s=10"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (10, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=10\<close> and INV
+      have  "(\<exists>lex rex. l = Bk \<up> lex @ [Bk,Oc] @ CL \<and> r = Bk \<up> Suc rex) \<or>
+             (\<exists>rex. l = [Oc] @ CL \<and> r = Bk \<up> Suc rex) \<or>
+             (\<exists>rex. l = CL \<and> r = Oc # Bk \<up> Suc rex)"
+        by auto
+      then have s10_cases:
+        "\<And>P. \<lbrakk> \<exists>lex rex. l = Bk \<up> lex @ [Bk,Oc] @ CL \<and> r = Bk \<up> Suc rex \<Longrightarrow> P;
+             \<exists>rex. l = [Oc] @ CL \<and> r = Bk \<up> Suc rex \<Longrightarrow> P;
+             \<exists>rex. l = CL \<and> r = Oc # Bk \<up> Suc rex \<Longrightarrow> P
+            \<rbrakk> \<Longrightarrow> P"
+        by blast
+      show ?thesis
+      proof (rule s10_cases)
+        assume "\<exists>lex rex. l = Bk \<up> lex @ [Bk, Oc] @ CL \<and> r = Bk \<up> Suc rex"
+        then obtain lex rex where
+          unpacked_INV: "l = Bk \<up> lex @ [Bk, Oc] @ CL \<and> r = Bk \<up> Suc rex" by blast
+        with unpacked_INV cf_at_stp and \<open>s=10\<close> and SUC_STEP_RED
+        have todo_step: "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                         step0 (10, Bk \<up> lex @ [Bk, Oc] @ CL, Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+          by auto
+        show ?thesis
+        proof (cases lex)
+          case 0
+          then have "lex = 0" .
+              (* compute the next state *)
+          then have "step0 (10, Bk \<up> lex @ [Bk, Oc] @ CL, Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                     = (10, [Oc] @ CL, Bk \<up> Suc (Suc rex))"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+          with todo_step 
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (10, [Oc] @ CL, Bk \<up> Suc (Suc rex))"
+            by auto
+              (* establish measure *)
+          with \<open>lex = 0\<close> and cf_at_current and unpacked_INV show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        next
+          case (Suc nat)
+          then have "lex = Suc nat" .
+              (* compute the next state *)
+          then have "step0 (10, Bk \<up> lex @ [Bk, Oc] @ CL, Bk \<up> Suc rex) tm_erase_right_then_dblBk_left
+                     = (10, Bk \<up> nat @ [Bk, Oc] @ CL, Bk \<up> Suc (Suc rex))"
+            by (simp add:  tm_erase_right_then_dblBk_left_def step.simps steps.simps numeral_eqs_upto_12)
+          with todo_step 
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (10, Bk \<up> nat @ [Bk, Oc] @ CL, Bk \<up> Suc (Suc rex))"
+            by auto
+              (* establish measure *)
+          with \<open>lex = Suc nat\<close> cf_at_current and unpacked_INV show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        qed
+      next
+        assume "\<exists>rex. l = [Oc] @ CL \<and> r = Bk \<up> Suc rex"
+        then obtain rex where
+          unpacked_INV: "l = [Oc] @ CL \<and> r = Bk \<up> Suc rex" by blast
+            (* compute the next state *)
+        with unpacked_INV cf_at_stp and \<open>s=10\<close> and SUC_STEP_RED
+        have todo_step: "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                         step0 (10, [Oc] @ CL, Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+          by auto
+        also with unpacked_INV
+        have "... = (10, CL, Oc# Bk \<up> (Suc rex))"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (10, CL, Oc# Bk \<up> (Suc rex))"
+          by auto
+            (* establish measure *)
+        with cf_at_current and unpacked_INV show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next
+        assume "\<exists>rex. l = CL \<and> r = Oc # Bk \<up> Suc rex"
+        then obtain rex where
+          unpacked_INV: "l = CL \<and> r = Oc # Bk \<up> Suc rex" by blast
+        show ?thesis
+        proof (cases CL) (* here, we start decomposing CL in the loop 'move to left until Oc *)
+          case Nil
+          then have minor: "CL = []" .
+          with unpacked_INV cf_at_stp and \<open>s=10\<close> and SUC_STEP_RED
+            (* compute the next state *)
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (10, [], Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+            by auto
+          also with minor and unpacked_INV
+          have "... = (11, [], Bk#Oc# Bk \<up> (Suc rex))"  (* YYYY1' *)
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (11, [], Bk#Oc# Bk \<up> (Suc rex))"
+            by auto
+              (* establish measure *)
+          with cf_at_current show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        next
+          case (Cons a rs')
+          then have major2: "CL = a # rs'" .
+          then show ?thesis
+          proof (cases a)
+            case Bk
+            with major2 have minor: "CL = Bk#rs'" by auto
+            with unpacked_INV cf_at_stp and \<open>s=10\<close> and SUC_STEP_RED
+              (* compute the next state *)
+            have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (10,  Bk#rs', Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+              by auto
+            also with minor and unpacked_INV
+            have "... = (11, rs', Bk# Oc # Bk \<up> Suc rex)" (* YYYY2',YYYY3 *)
+              by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (11, rs', Bk# Oc # Bk \<up> Suc rex)"
+              by auto
+                (* establish measure *)
+            with cf_at_current and minor show ?thesis
+              by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+          next
+            case Oc
+            with major2 have minor: "CL = Oc#rs'" by auto
+            with unpacked_INV cf_at_stp and \<open>s=10\<close> and SUC_STEP_RED
+              (* compute the next state *)
+            have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (10,  Oc#rs', Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+              by auto
+            also with minor and unpacked_INV
+            have "... = (11, rs', Oc# Oc # Bk \<up> Suc rex)" (* YYYY2'', YYYY5, YYYY6, YYYY7 *)
+              by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (11, rs', Oc# Oc # Bk \<up> Suc rex)"
+              by auto
+                (* establish measure *)
+            with cf_at_current and minor show ?thesis
+              by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+          qed
+        qed
+      qed
+    next
+      assume "s=11"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (11, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=11\<close> and INV
+      have "(\<exists>rex.         l = []         \<and> r = Bk# rev CL    @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc))              \<or>
+          (\<exists>rex.         l = []         \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk ) \<or>
+          (\<exists>rex.         l = []         \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Oc ) \<or>
+
+          (\<exists>rex.         l = [Bk]       \<and> r = rev [Oc]      @ Oc # Bk \<up> Suc rex \<and> CL = [Oc, Bk]) \<or>
+
+          (\<exists>rex ls1 ls2. l = Bk#Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Bk#Oc#ls2 \<and> ls1 = [Oc] ) \<or>
+          (\<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Bk] ) \<or>
+          (\<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Oc] ) \<or>
+ 
+          (\<exists>rex ls1 ls2. l =       ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2       \<and> tl ls1 \<noteq> [])"
+        by auto
+
+      then have s11_cases:
+        "\<And>P. \<lbrakk> \<exists>rex.         l = []         \<and> r = Bk# rev CL    @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc) \<Longrightarrow> P;
+             \<exists>rex.         l = []         \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk \<Longrightarrow> P;
+             \<exists>rex.         l = []         \<and> r = rev CL        @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Oc \<Longrightarrow> P;
+
+             \<exists>rex.         l = [Bk]       \<and> r = rev [Oc]      @ Oc # Bk \<up> Suc rex \<and> CL = [Oc, Bk] \<Longrightarrow> P;
+
+             \<exists>rex ls1 ls2. l = Bk#Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Bk#Oc#ls2 \<and> ls1 = [Oc] \<Longrightarrow> P;
+             \<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Bk] \<Longrightarrow> P;
+             \<exists>rex ls1 ls2. l =    Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc#ls2    \<and> ls1 = [Oc] \<Longrightarrow> P;
+
+             \<exists>rex ls1 ls2. l =       ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2       \<and> tl ls1 \<noteq> [] \<Longrightarrow> P
+            \<rbrakk> \<Longrightarrow> P"
+        by blast
+      show ?thesis
+      proof (rule s11_cases)
+        assume "\<exists>rex ls1 ls2. l = Bk # Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Bk # Oc # ls2 \<and> ls1 = [Oc]" (* YYYY6 *)
+        then obtain rex ls1 ls2 where
+          unpacked_INV: "l = Bk#Oc#ls2  \<and> r = rev ls1       @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Bk#Oc#ls2 \<and> ls1 = [Oc]" by blast
+        from unpacked_INV cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+        have todo_step: "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                         step0 (11, Bk#Oc#ls2, r) tm_erase_right_then_dblBk_left"
+          by auto
+        also with unpacked_INV
+        have "... = (11, Oc # ls2, Bk # r)"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (11, Oc # ls2, Bk # r)"
+          by auto
+            (* establish measure *)
+        with cf_at_current and unpacked_INV show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next
+        assume "\<exists>rex ls1 ls2. l = Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc # ls2 \<and> ls1 = [Oc]" (* YYYY7 *)
+        then obtain rex ls1 ls2 where
+          unpacked_INV: "l = Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc # ls2 \<and> ls1 = [Oc]" by blast
+        from unpacked_INV cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+        have todo_step: "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                         step0 (11, l, r) tm_erase_right_then_dblBk_left"
+          by auto
+        also with unpacked_INV
+        have "... = (11, ls2, Oc#r)"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (11, ls2, Oc#r)"
+          by auto
+            (* establish measure *)
+        with cf_at_current and unpacked_INV show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next
+        assume "\<exists>rex. l = [Bk] \<and> r = rev [Oc] @ Oc # Bk \<up> Suc rex \<and> CL = [Oc, Bk]" (* YYYY5 *)
+        then obtain rex where
+          unpacked_INV: "l = [Bk] \<and> r = rev [Oc] @ Oc # Bk \<up> Suc rex \<and> CL = [Oc, Bk]" by blast
+            (* compute the next state *)
+        from unpacked_INV cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                         step0 (11, l, r) tm_erase_right_then_dblBk_left"
+          by auto
+        also with unpacked_INV
+        have "... = (11, [], Bk#r)"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (11, [], Bk#r)"
+          by auto
+            (* establish measure *)
+        with cf_at_current and unpacked_INV show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next
+        assume "\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> tl ls1 \<noteq> []" (* YYYY8 *)
+        then obtain rex ls1 ls2 where
+          A_case: "l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> tl ls1 \<noteq> []" by blast
+            (* we have to decompose both ls1 and ls2 in order to predict the next step *)
+        then have "\<exists>z b bs. ls1 = z#bs@[b]"  (* the symbol z does not matter *) 
+          by (metis Nil_tl list.exhaust_sel rev_exhaust)
+        then have "\<exists>z bs. ls1 = z#bs@[Bk] \<or> ls1 = z#bs@[Oc]"
+          using cell.exhaust by blast
+        then obtain z bs where w_z_bs: "ls1 = z#bs@[Bk] \<or> ls1 = z#bs@[Oc]" by blast
+        then show ?thesis
+        proof
+          assume major1: "ls1 = z # bs @ [Bk]"
+          then have major2: "rev ls1 = Bk#(rev bs)@[z]" by auto  (* in this case all transitions will be s11 \<longrightarrow> s12 *)
+          show ?thesis
+          proof  (rule noDblBk_cases)
+            from \<open>noDblBk CL\<close> show "noDblBk CL" .
+          next
+            from A_case show "CL = ls1 @ ls2" by auto
+          next
+            assume minor: "ls2 = []"
+              (* compute the next state *)
+            with A_case major2 cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+            have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (11, [], Bk#(rev bs)@[z] @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+              by auto
+            also 
+            have "... = (12, [], Bk#Bk#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+              by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (12, [], Bk#Bk#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+              by auto
+                (* establish measure *)
+            with cf_at_current show ?thesis
+              by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+          next
+            assume "ls2 = [Bk]"
+            with A_case \<open>rev ls1 = Bk#(rev bs)@[z]\<close> and \<open>ls2 = [Bk]\<close>
+            have "ls1 = z#bs@[Bk]" and "CL = z#bs@[Bk]@[Bk]" by auto
+            with \<open>noDblBk CL\<close> have False               
+              by (metis A_case  \<open>ls2 = [Bk]\<close> append_Cons hasDblBk_L5 major2)
+            then show ?thesis by auto
+          next
+            fix C3
+            assume minor: "ls2 = Bk # Oc # C3"
+            with A_case and major2 have "CL = z # bs @ [Bk] @ Bk # Oc # C3" by auto
+            with \<open>noDblBk CL\<close> have False
+              by (metis append.left_neutral append_Cons append_assoc hasDblBk_L1 major1 minor)
+            then show ?thesis by auto     
+          next
+            fix C3
+            assume minor: "ls2 = Oc # C3"
+              (* compute the next state *)
+            with A_case major2 cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+            have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (11, Oc # C3 , Bk#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+              by auto
+            also 
+            have "... = (12, C3, Oc#Bk#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex )"
+              by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (12, C3, Oc#Bk#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex )"
+              by auto
+                (* establish measure *)
+            with A_case minor cf_at_current  show ?thesis
+              by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+          qed
+        next
+          assume major1: "ls1 = z # bs @ [Oc]"
+          then have major2: "rev ls1 = Oc#(rev bs)@[z]" by auto (* in this case all transitions will be s11 \<longrightarrow> s11 *)
+          show ?thesis
+          proof  (rule noDblBk_cases)
+            from \<open>noDblBk CL\<close> show "noDblBk CL" .
+          next
+            from A_case show "CL = ls1 @ ls2" by auto
+          next
+            assume minor: "ls2 = []"
+              (* compute the next state *)
+            with A_case major2 cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+            have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (11, [] , Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+              by auto
+            also 
+            have "... = (11, [], Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex)"
+              by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (11, [], Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex)"
+              by auto
+                (* establish measure *)
+            with A_case minor major2 cf_at_current show ?thesis
+              by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+          next
+            assume minor: "ls2 = [Bk]"
+              (* compute the next state *)
+            with A_case major2 cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+            have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (11, [Bk] , Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+              by auto
+            also 
+            have "... = (11, [], Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+              by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (11, [], Bk#Oc#(rev bs)@[z] @ Oc # Bk \<up> Suc rex )"
+              by auto
+                (* establish measure *)
+            with A_case minor major2 cf_at_current show ?thesis
+              by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+          next
+            fix C3
+            assume minor: "ls2 = Bk # Oc # C3"
+              (* compute the next state *)
+            with A_case major2 cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+            have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (11, Bk # Oc # C3 , Oc # rev bs @ [z]  @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+              by auto
+            also 
+            have "... = (11, Oc # C3, Bk#Oc # rev bs @ [z]  @ Oc # Bk \<up> Suc rex )"
+              by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) = (11, Oc # C3, Bk#Oc # rev bs @ [z]  @ Oc # Bk \<up> Suc rex )"
+              by auto
+                (* establish measure *)
+            with A_case minor major2 cf_at_current show ?thesis
+              by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+          next
+            fix C3
+            assume minor: "ls2 = Oc # C3"
+              (* compute the next state *)
+            with A_case major2 cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+            have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (11, Oc # C3 , Oc#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+              by auto
+            also 
+            have "... = (11, C3, Oc#Oc#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex)"
+              by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+            finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                        = (11, C3, Oc#Oc#(rev bs)@[z]  @ Oc # Bk \<up> Suc rex)"
+              by auto
+                (* establish measure *)
+            with A_case minor major2 cf_at_current show ?thesis
+              by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+          qed
+        qed
+      next
+        assume "\<exists>rex ls1 ls2. l = Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc # ls2 \<and> ls1 = [Bk]" (* YYYY3 *)
+        then obtain rex ls1 ls2 where
+          unpacked_INV: "l = Oc # ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ Oc # ls2 \<and> ls1 = [Bk]" by blast
+            (* compute the next state *)
+        from unpacked_INV cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                         step0 (11, l, r) tm_erase_right_then_dblBk_left"
+          by auto
+        also with unpacked_INV
+        have "... = (12, ls2, Oc#[Bk] @ Oc # Bk \<up> Suc rex )"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                    = (12, ls2, Oc#[Bk] @ Oc # Bk \<up> Suc rex )"
+          by auto
+            (* establish measure *)
+        with cf_at_current and unpacked_INV show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next
+        assume "\<exists>rex. l = [] \<and> r = Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc)"  (* YYYY1' *)
+        then obtain rex where
+          unpacked_INV: "l = [] \<and> r = Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc)" by blast
+            (* compute the next state *)
+        from unpacked_INV cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                         step0 (11, l, r) tm_erase_right_then_dblBk_left"
+          by auto
+        also with unpacked_INV
+        have "... = (12, [], Bk#Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                    = (12, [], Bk#Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+          by auto
+            (* establish measure *)
+        with cf_at_current and unpacked_INV show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next      
+        assume "\<exists>rex. l = [] \<and> r = rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk" (* YYYY2' *)
+        then obtain rex where
+          unpacked_INV: "l = [] \<and> r = rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk" by blast
+        then have "hd (rev CL) = Bk"
+          by (simp add: hd_rev)
+            (* compute the next state *)
+        from unpacked_INV cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                         step0 (11, l, r) tm_erase_right_then_dblBk_left"
+          by auto
+        also with unpacked_INV and \<open>hd (rev CL) = Bk\<close>
+        have "... = (12, [], Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                    = (12, [], Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+          by auto
+            (* establish measure *)
+        with cf_at_current and unpacked_INV show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next      
+        assume "\<exists>rex. l = [] \<and> r = rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Oc" (* YYYY2'' *)
+        then obtain rex where
+          unpacked_INV: "l = [] \<and> r = rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Oc" by blast
+        then have "hd (rev CL) = Oc"
+          by (simp add: hd_rev)
+            (* compute the next state *)
+        from unpacked_INV cf_at_stp and \<open>s=11\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                         step0 (11, l, r) tm_erase_right_then_dblBk_left"
+          by auto
+        also with unpacked_INV and \<open>hd (rev CL) = Oc\<close>
+        have "... = (11, [], Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                    = (11, [], Bk # rev CL @ Oc # Bk \<up> Suc rex )"
+          by auto
+            (* establish measure *)
+        with cf_at_current and unpacked_INV and \<open>hd (rev CL) = Oc\<close> show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      qed
+    next
+      assume "s=12"
+        (* get the invariant of the state *)
+      with cf_at_stp
+      have cf_at_current: "steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp = (12, l, r)"
+        by auto
+      with cf_at_stp  and \<open>s=12\<close> and INV
+      have "
+          (\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2  \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc) \<or>
+          (\<exists>rex.         l = []  \<and> r = Bk#rev CL    @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk) \<or>
+          (\<exists>rex.         l = []  \<and> r = Bk#Bk#rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc))"
+        by auto
+
+      then have s12_cases:
+        "\<And>P. \<lbrakk> \<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2  \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc \<Longrightarrow> P;
+             \<exists>rex. l = []  \<and> r = Bk#rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk \<Longrightarrow> P;
+             \<exists>rex. l = []  \<and> r = Bk#Bk#rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc) \<Longrightarrow> P \<rbrakk>
+        \<Longrightarrow> P"
+        by blast
+      show ?thesis
+      proof (rule s12_cases)
+        (* YYYY4 *)
+        assume "\<exists>rex ls1 ls2. l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2 \<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc"
+        then obtain rex ls1 ls2 where
+          unpacked_INV: "l = ls2 \<and> r = rev ls1 @ Oc # Bk \<up> Suc rex \<and> CL = ls1 @ ls2\<and> tl ls1 \<noteq> [] \<and> last ls1 = Oc" by blast
+        then have "ls1 \<noteq> []" by auto 
+        with unpacked_INV have major: "hd (rev ls1) = Oc"
+          by (simp add: hd_rev)
+        with unpacked_INV and major have minor2: "r = Oc#tl ((rev ls1) @ Oc # Bk \<up> Suc rex)"
+          by (metis Nil_is_append_conv \<open>ls1 \<noteq> []\<close> hd_Cons_tl hd_append2 list.simps(3) rev_is_Nil_conv)
+
+        show ?thesis
+        proof  (rule noDblBk_cases)
+          from \<open>noDblBk CL\<close> show "noDblBk CL" .
+        next
+          from unpacked_INV show "CL = ls1 @ ls2" by auto
+        next
+          assume minor: "ls2 = []"
+            (* compute the next state *)
+          with unpacked_INV minor minor2 major cf_at_stp and \<open>s=12\<close> and \<open>ls1 \<noteq> []\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (12, [] ,   Oc#tl ((rev ls1) @ Oc # Bk \<up> Suc rex)) tm_erase_right_then_dblBk_left"
+            by auto
+          also 
+          have "... = (11, [], Bk#Oc#tl ((rev ls1) @ Oc # Bk \<up> Suc rex))"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          also with unpacked_INV and minor2 have "... =  (11, [], Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+            by auto
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                 = (11, [], Bk# rev ls1 @ Oc # Bk \<up> Suc rex )"
+            by auto
+              (* establish measure *)
+          with unpacked_INV minor major minor2 cf_at_current \<open>ls1 \<noteq> []\<close> show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        next
+          assume minor: "ls2 = [Bk]"
+            (* compute the next state *)
+          with unpacked_INV minor minor2 major cf_at_stp and \<open>s=12\<close> and \<open>ls1 \<noteq> []\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (12, [Bk] ,   Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)) tm_erase_right_then_dblBk_left"
+            by auto
+          also have "... =  (11, [], Bk#Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex ))"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                 = (11, [], Bk#Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex ))"
+            by auto
+              (* establish measure *)
+          with unpacked_INV minor major minor2 cf_at_current \<open>ls1 \<noteq> []\<close> show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        next
+          fix C3
+          assume minor: "ls2 = Bk # Oc # C3"
+            (* compute the next state *)
+          with unpacked_INV minor minor2 major cf_at_stp and \<open>s=12\<close> and \<open>ls1 \<noteq> []\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (12, Bk # Oc # C3 ,   Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)) tm_erase_right_then_dblBk_left"
+            by auto
+          also have "... =  (11, Oc # C3, Bk#Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex ))"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                 = (11, Oc # C3, Bk#Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex ))"
+            by auto
+              (* establish measure *)
+          with unpacked_INV minor major minor2 cf_at_current \<open>ls1 \<noteq> []\<close> show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        next
+          fix C3
+          assume minor: "ls2 = Oc # C3"
+            (* compute the next state *)
+          with unpacked_INV minor minor2 major cf_at_stp and \<open>s=12\<close> and \<open>ls1 \<noteq> []\<close> and SUC_STEP_RED
+          have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (12, Oc # C3 ,   Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex)) tm_erase_right_then_dblBk_left"
+            by auto
+          also have "... =  (11, C3, Oc#Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex ))"
+            by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+          finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                 = (11, C3, Oc#Oc#tl (rev ls1 @ Oc # Bk \<up> Suc rex ))"
+            by auto
+              (* establish measure *)
+          with unpacked_INV minor major minor2 cf_at_current \<open>ls1 \<noteq> []\<close> show ?thesis
+            by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+        qed
+      next
+        (* YYYY6''' *)
+        assume "\<exists>rex. l = [] \<and> r = Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk"
+        then obtain rex where
+          unpacked_INV: "l = [] \<and> r = Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> CL \<noteq> [] \<and> last CL = Bk" by blast
+            (* compute the next state *)
+        with cf_at_stp and \<open>s=12\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (12, [] , Bk # rev CL @ Oc # Bk \<up> Suc rex)  tm_erase_right_then_dblBk_left"
+          by auto
+
+        also
+        have "... = (0, [], Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                    = (0, [], Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+          by auto
+            (* establish measure *)
+        with cf_at_current  show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      next
+        (* YYYY9 *)
+        assume "\<exists>rex. l = [] \<and> r = Bk # Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc)"
+        then obtain rex where
+          unpacked_INV: "l = [] \<and> r = Bk # Bk # rev CL @ Oc # Bk \<up> Suc rex \<and> (CL = [] \<or> last CL = Oc)" by blast
+            (* compute the next state *)
+        with cf_at_stp and \<open>s=12\<close> and SUC_STEP_RED
+        have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp) =
+                step0 (12, [] , Bk # Bk # rev CL @ Oc # Bk \<up> Suc rex) tm_erase_right_then_dblBk_left"
+          by auto
+
+        also
+        have "... = (0, [], Bk# Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+          by (auto simp add: tm_erase_right_then_dblBk_left_def numeral_eqs_upto_12 step.simps steps.simps)
+        finally have "steps0 (1, [Bk, Oc] @ CL, CR) tm_erase_right_then_dblBk_left (Suc stp)
+                    = (0, [], Bk# Bk # rev CL @ Oc # Bk \<up> Suc rex)"
+          by auto
+            (* establish measure *)
+        with cf_at_current  show ?thesis
+          by (auto simp add: measure_tm_erase_right_then_dblBk_left_erp_def)
+      qed
+    qed
+  qed
+qed
+
+
+(* -------------- Total correctness for the ERASE path of tm_erase_right_then_dblBk_left ------------------ *)
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_CL_is_Nil:
+  assumes "noDblBk CL"
+  and "noDblBk CR"
+  and "CL = []"
+  shows "\<lbrace> \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex ) \<rbrace>"
+proof (rule tm_erase_right_then_dblBk_left_erp_partial_correctness_CL_is_Nil)
+  from assms show "\<exists>stp. is_final (steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp)"
+    using  tm_erase_right_then_dblBk_left_erp_halts by auto
+next
+  from assms show "noDblBk CL" by auto
+next
+  from assms show "noDblBk CR" by auto
+next
+  from assms show "CL = []" by auto
+qed
+
+lemma tm_erase_right_then_dblBk_left_correctness_CL_ew_Bk:
+  assumes "noDblBk CL"
+  and "noDblBk CR"
+  and "CL \<noteq> []"
+  and "last CL = Bk"   
+  shows "\<lbrace> \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex ) \<rbrace>"
+proof (rule tm_erase_right_then_dblBk_left_erp_partial_correctness_CL_ew_Bk)
+  from assms show "\<exists>stp. is_final (steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp)"
+    using  tm_erase_right_then_dblBk_left_erp_halts by auto
+next
+  from assms show "noDblBk CL" by auto
+next
+  from assms show "noDblBk CR" by auto
+next
+  from assms show "CL \<noteq> []" by auto
+next
+  from assms show "last CL = Bk" by auto
+qed
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_CL_ew_Oc:
+  assumes "noDblBk CL"
+    and "noDblBk CR"
+    and "CL \<noteq> []"
+    and "last CL = Oc"   
+  shows "\<lbrace> \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex ) \<rbrace>"
+proof (rule tm_erase_right_then_dblBk_left_erp_partial_correctness_CL_ew_Oc)
+  from assms show "\<exists>stp. is_final (steps0 (1, [Bk,Oc] @ CL, CR) tm_erase_right_then_dblBk_left stp)"
+    using  tm_erase_right_then_dblBk_left_erp_halts by auto
+next
+  from assms show "noDblBk CL" by auto
+next
+  from assms show "noDblBk CR" by auto
+next
+  from assms show "CL \<noteq> []" by auto
+next
+  from assms show "last CL = Oc" by auto
+qed
+
+(* --- prove some helper theorems to convert results to lists of numeral        --- *)
+
+(*--------------------------------------------------------------------------------- *)
+(* simple case, where we tried to check for exactly one argument and failed         *)
+(*--------------------------------------------------------------------------------- *)
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_eq_Nil_n_eq_1_last_eq_0:
+  assumes "(nl::nat list) \<noteq> []"
+    and "n=1"
+    and "n \<le> length nl"
+    and "last (take n nl) = 0"
+  shows "\<exists>CL CR.
+           [Oc] @ CL = rev(<take n nl>) \<and> noDblBk CL \<and> CL = [] \<and>
+                  CR = (<drop n nl>)    \<and> noDblBk CR"
+proof -
+  have "rev(<take n nl>) = <rev(take n nl)>"
+    by (rule rev_numeral_list)
+  also with assms have "... = <rev( butlast (take n nl) @ [last (take n nl)] )>"
+    by (metis append_butlast_last_id take_eq_Nil zero_neq_one)
+  also have "... = < (rev[(last (take n nl))]) @ (rev ( butlast (take n nl)))>"
+    by simp
+  also with assms have "... = < (rev [0]) @ (rev ( butlast (take n nl)))>" by auto
+  finally have major: "rev(<take n nl>) = <(rev [0]) @ (rev ( butlast (take n nl)))>" by auto
+  with assms have "butlast (take n nl) = []"
+    by (simp add: butlast_take)
+  then have "<(rev [0::nat]) @ (rev ( butlast (take n nl)))> = <(rev [0::nat]) @ (rev [])>"
+    by auto
+  also have "... = <(rev [0::nat])>" by auto
+  also have "... = <[0::nat]>" by auto
+  also have "... = [Oc]"
+    by (simp add: tape_of_list_def tape_of_nat_def )
+  finally have "<(rev [0::nat]) @ (rev ( butlast (take n nl)))> =  [Oc]" by auto
+  with major have "rev(<take n nl>) = [Oc]" by auto
+  then have "[Oc] @ [] = rev(<take n nl>) \<and> noDblBk [] \<and> ([] = [] \<or> [] \<noteq> [] \<and> last [] = Oc) \<and>
+                  (<drop n nl>) = (<drop n nl>)    \<and> noDblBk (<drop n nl>)"
+    by (simp add: noDblBk_Nil noDblBk_tape_of_nat_list)
+  then show ?thesis
+    by blast
+qed
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_neq_Nil_n_eq_1_last_neq_0:
+  assumes "(nl::nat list) \<noteq> []"
+    and "n=1"
+    and "n \<le> length nl"
+    and "0 < last (take n nl)"
+  shows "\<exists>CL CR.
+           [Oc] @ CL = rev(<take n nl>) \<and> noDblBk CL \<and> CL \<noteq> [] \<and> last CL = Oc \<and>
+                  CR = (<drop n nl>)    \<and> noDblBk CR"
+proof -
+  have minor: "rev(<take n nl>) = <rev(take n nl)>"
+    by (rule rev_numeral_list)
+  also with assms have "... = <rev( butlast (take n nl) @ [last (take n nl)] )>"
+    by simp
+  also have "... = <(rev[last (take n nl)]) @ (rev (butlast (take n nl)))>"
+    by simp
+  finally have major: "rev(<take n nl>) = <(rev[(last (take n nl))]) @ (rev ( butlast (take n nl)))>"
+    by auto
+
+  moreover from assms have "[last (take n nl)] \<noteq> []" by auto
+  moreover from  assms have "butlast (take n nl) = []"
+    by (simp add: butlast_take)
+  ultimately have "rev(<take n nl>) = <(rev[(last (take n nl))])>"
+    by auto
+
+  also have "<(rev[(last (take n nl))])> = Oc\<up> Suc  (last (take n nl))"
+  proof -
+    from assms have "<[(last (take n nl))]> = Oc\<up> Suc  (last (take n nl))"
+      by (simp add: tape_of_list_def tape_of_nat_def)
+    then show "<(rev[(last (take n nl))])> = Oc\<up> Suc  (last (take n nl))"
+      by simp
+  qed
+  also have "... = Oc# Oc\<up> (last (take n nl))" by auto
+  finally have "rev(<take n nl>) = Oc# Oc\<up> (last (take n nl))" by auto
+
+  moreover from assms have "Oc\<up> (last (take n nl)) \<noteq> []"
+    by auto
+
+  ultimately have "[Oc] @ (Oc\<up> (last (take n nl))) = rev(<take n nl>) \<and>
+                   noDblBk (Oc\<up> (last (take n nl))) \<and> (Oc\<up> (last (take n nl))) \<noteq> [] \<and> last (Oc\<up> (last (take n nl))) = Oc \<and>
+                  (<drop n nl>) = (<drop n nl>)    \<and> noDblBk (<drop n nl>)" using assms
+    by (simp add: noDblBk_Bk_Oc_rep noDblBk_tape_of_nat_list)
+  then show ?thesis by auto
+qed
+
+(* convenient versions using hd and tl for tm_skip_first_arg *)
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_eq_Nil_last_eq_0':
+  assumes "1 \<le> length (nl:: nat list)"
+    and "hd nl = 0"
+  shows "\<exists>CL CR.
+           [Oc] @ CL = rev(<hd nl>)  \<and> noDblBk CL \<and> CL = [] \<and>
+                  CR = (<tl nl>) \<and> noDblBk CR"
+proof -
+  from assms
+  have  "(nl::nat list) \<noteq> [] \<and> (1::nat)=1 \<and> 1 \<le> length nl \<and> 0 = last (take 1 nl)"
+    by (metis One_nat_def append.simps(1) append_butlast_last_id butlast_take diff_Suc_1 
+        hd_take   le_numeral_extra(4) length_0_conv less_numeral_extra(1) list.sel(1)
+        not_one_le_zero take_eq_Nil zero_less_one)
+  then have  "\<exists>n. (nl::nat list) \<noteq> [] \<and> n=1 \<and> n \<le> length nl \<and> 0 = last (take n nl)"
+    by blast
+  then obtain n where
+    w_n: "(nl::nat list) \<noteq> [] \<and> n=1 \<and> n \<le> length nl \<and> 0 = last (take n nl)" by blast
+  then have "\<exists>CL CR.
+           [Oc] @ CL = rev(<take n nl>) \<and> noDblBk CL \<and> CL = [] \<and>
+                  CR = (<drop n nl>)    \<and> noDblBk CR"
+    using tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_eq_Nil_n_eq_1_last_eq_0
+    by auto
+  then obtain CL CR where
+    w_CL_CR: "[Oc] @ CL = rev (<take n nl>) \<and> noDblBk CL \<and> CL = [] \<and> CR = <drop n nl> \<and> noDblBk CR" by blast
+  with assms w_n show ?thesis
+    by (simp add:  noDblBk_Nil noDblBk_tape_of_nat_list   rev_numeral tape_of_nat_def)
+qed
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_neq_Nil_last_neq_0':
+  assumes "1 \<le> length (nl::nat list)"
+    and "0 < hd nl"
+  shows "\<exists>CL CR.
+           [Oc] @ CL = rev(<hd nl>) \<and> noDblBk CL \<and> CL \<noteq> [] \<and> last CL = Oc \<and>
+                  CR = (<tl nl>)    \<and> noDblBk CR"
+proof -
+  from assms
+  have  "(nl::nat list) \<noteq> [] \<and> (1::nat)=1 \<and> 1 \<le> length nl \<and> 0 < last (take 1 nl)"
+    by (metis append.simps(1) append_butlast_last_id butlast_take cancel_comm_monoid_add_class.diff_cancel
+        ex_least_nat_le hd_take le_trans list.sel(1) list.size(3)
+        neq0_conv not_less not_less_zero take_eq_Nil zero_less_one zero_neq_one)
+  then have  "\<exists>n. (nl::nat list) \<noteq> [] \<and> n=1 \<and> n \<le> length nl \<and> 0 < last (take n nl)"
+    by blast
+  then obtain n where
+    w_n: "(nl::nat list) \<noteq> [] \<and> n=1 \<and> n \<le> length nl \<and> 0 < last (take n nl)" by blast
+  then have "\<exists>CL CR.
+           [Oc] @ CL = rev(<take n nl>) \<and> noDblBk CL \<and> CL \<noteq> [] \<and> last CL = Oc \<and>
+                  CR = (<drop n nl>)    \<and> noDblBk CR"
+    using tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_neq_Nil_n_eq_1_last_neq_0
+    by auto
+  with assms w_n show ?thesis 
+    by (simp add: drop_Suc take_Suc tape_of_list_def )
+qed
+
+(*--------------------------------------------------------------------------------- *)
+(* generic case , where we tried to check for more than one one argument and failed *)
+(*--------------------------------------------------------------------------------- *)
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_neq_Nil_n_gt_1_last_eq_0:
+  assumes "(nl::nat list) \<noteq> []"
+    and "1<n"
+    and "n \<le> length nl"
+    and "last (take n nl) = 0"
+  shows "\<exists>CL CR.
+           [Oc] @ CL = rev(<take n nl>) \<and> noDblBk CL \<and> CL \<noteq> [] \<and> last CL = Oc \<and>
+                  CR = (<drop n nl>) \<and> noDblBk CR"
+proof -
+  have minor: "rev(<take n nl>) = <rev(take n nl)>"
+    by (rule rev_numeral_list)
+  also with assms have "... = <rev( butlast (take n nl) @ [last (take n nl)] )>"   
+    by (metis append_butlast_last_id not_one_less_zero take_eq_Nil)
+  also have "... = < (rev [(last (take n nl))]) @ (rev ( butlast (take n nl)))>"
+    by simp
+  also with assms have "... = <(rev [0]) @ (rev ( butlast (take n nl)))>" by auto
+  finally have major: "rev(<take n nl>) = <(rev [0]) @ (rev ( butlast (take n nl)))>" by auto
+
+  moreover have "<(rev [0::nat])> = [Oc]"
+    by (simp add: tape_of_list_def tape_of_nat_def )
+  moreover with assms have not_Nil: "rev (butlast (take n nl)) \<noteq> []"
+    by (simp add: butlast_take)
+  ultimately have "rev(<take n nl>) = [Oc] @ [Bk] @ <rev (butlast (take n nl))>"
+    using  tape_of_nat_def tape_of_nat_list_cons_eq by auto
+
+  then show ?thesis
+    using major and minor and not_Nil
+    by (metis append_Nil append_is_Nil_conv append_is_Nil_conv  last_append last_appendR  list.sel(3)
+        noDblBk_tape_of_nat_list noDblBk_tape_of_nat_list_imp_noDblBk_tl 
+        numeral_list_last_is_Oc rev.simps(1) rev_append snoc_eq_iff_butlast tl_append2)
+qed
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_neq_Nil_n_gt_1_last_neq_0:
+  assumes "(nl::nat list) \<noteq> []"
+    and "1 < n"
+    and "n \<le> length nl"
+    and "0 < last (take n nl)"
+  shows "\<exists>CL CR.
+           [Oc] @ CL = rev(<take n nl>) \<and> noDblBk CL \<and> CL \<noteq> [] \<and> last CL = Oc \<and>
+                  CR = (<drop n nl>)    \<and> noDblBk CR"
+proof -
+  have minor: "rev(<take n nl>) = <rev(take n nl)>"
+    by (rule rev_numeral_list)
+  also with assms have "... = <rev( butlast (take n nl) @ [last (take n nl)] )>"   
+    by (metis append_butlast_last_id not_one_less_zero take_eq_Nil)
+  also have "... = <(rev [(last (take n nl))]) @ (rev ( butlast (take n nl)))>"
+    by simp
+  finally have major: "rev(<take n nl>) = <(rev[(last (take n nl))]) @ (rev ( butlast (take n nl)))>"
+    by auto
+
+  moreover from assms have "[last (take n nl)] \<noteq> []" by auto
+  moreover from  assms have "butlast (take n nl) \<noteq> []"
+    by (simp add: butlast_take)
+  ultimately have "rev(<take n nl>) = <(rev[(last (take n nl))])> @[Bk] @ <(rev ( butlast (take n nl)))>"
+    by (metis append_numeral_list rev.simps(1) rev_rev_ident rev_singleton_conv)
+
+  also have "<(rev[(last (take n nl))])> = Oc\<up> Suc  (last (take n nl))"
+  proof -
+    from assms have "<[(last (take n nl))]> = Oc\<up> Suc  (last (take n nl))"
+      by (simp add: tape_of_list_def tape_of_nat_def)
+    then show "<(rev[(last (take n nl))])> = Oc\<up> Suc  (last (take n nl))"
+      by simp
+  qed
+  also have "... = Oc# Oc\<up> (last (take n nl))" by auto
+  finally have "rev(<take n nl>) = Oc# Oc\<up> (last (take n nl))  @[Bk] @ <(rev ( butlast (take n nl)))>"
+    by auto
+
+  moreover from assms have "Oc\<up> (last (take n nl)) \<noteq> []"
+    by auto
+
+  ultimately have "[Oc] @ (Oc\<up> (last (take n nl))  @[Bk] @ <(rev ( butlast (take n nl)))>)
+                    = rev(<take n nl>) \<and> noDblBk (Oc\<up> (last (take n nl))  @[Bk] @ <(rev ( butlast (take n nl)))>) \<and>
+                    (Oc\<up> (last (take n nl))  @[Bk] @ <(rev ( butlast (take n nl)))>) \<noteq> [] \<and>
+                     last (Oc\<up> (last (take n nl))  @[Bk] @ <(rev ( butlast (take n nl)))>) = Oc \<and>
+                  (<drop n nl>) = (<drop n nl>)    \<and> noDblBk (<drop n nl>)"
+
+    using assms 
+      \<open><rev [last (take n nl)]> = Oc \<up> Suc (last (take n nl))\<close>
+      \<open>Oc \<up> Suc (last (take n nl)) = Oc # Oc \<up> last (take n nl)\<close>
+      \<open>butlast (take n nl) \<noteq> []\<close> \<open>rev (<take n nl>) = <rev [last (take n nl)]> @ [Bk] @ <rev (butlast (take n nl))>\<close>
+    by (smt
+        append_Cons append_Nil append_Nil2 append_eq_Cons_conv butlast.simps(1) butlast.simps(2)
+        butlast_append last_ConsL last_append last_appendR  list.sel(3) list.simps(3) minor noDblBk_tape_of_nat_list
+        noDblBk_tape_of_nat_list_imp_noDblBk_tl numeral_list_last_is_Oc rev_is_Nil_conv self_append_conv)
+  then show ?thesis by auto
+qed
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_neq_Nil_n_gt_1:
+  assumes "(nl::nat list) \<noteq> []"
+    and "1<n"
+    and "n \<le> length nl"
+  shows "\<exists>CL CR.
+           [Oc] @ CL = rev(<take n nl>) \<and> noDblBk CL \<and> CL \<noteq> [] \<and> last CL = Oc \<and>
+                  CR = (<drop n nl>) \<and> noDblBk CR"
+proof (cases  "last (take n nl)")
+  case 0
+  with assms show ?thesis
+    using tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_neq_Nil_n_gt_1_last_eq_0
+    by auto
+next
+  case (Suc nat)
+  with assms show ?thesis
+    using tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_neq_Nil_n_gt_1_last_neq_0
+    by auto
+qed
+
+(*--------------------------------------------------------------------------------- *)
+(* For now, we only proof a result for n = 1 supporting tm_check_for_one_arg        *)
+(*--------------------------------------------------------------------------------- *)
+
+(*----------------------------------------------------------------------------------------------------- *)
+(* ENHANCE: formalise generic tm_skip_n_args                                                            *)
+(* ENHANCE: formalise matching results for tm_erase_right_then_dblBk_left_erp_total_correctness_one_arg *)
+(*----------------------------------------------------------------------------------------------------- *)
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_one_arg:
+  assumes "1 \<le> length (nl::nat list)"
+  shows "\<lbrace> \<lambda>tap. tap = (Bk# rev(<hd nl>), <tl nl>) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ (<hd nl>) @ [Bk] @ Bk \<up> rex ) \<rbrace>"
+proof (cases "hd nl")
+  case 0
+  then have "hd nl = 0" .
+  with assms
+  have "\<exists>CL CR.
+           [Oc] @ CL = rev(<hd nl>)  \<and> noDblBk CL \<and> CL = [] \<and>
+                  CR = (<tl nl>) \<and> noDblBk CR"
+    using tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_eq_Nil_last_eq_0'
+    by blast
+  then obtain CL CR where
+    w_CL_CR: "[Oc] @ CL = rev(<hd nl>)  \<and> noDblBk CL \<and> CL = [] \<and>
+                  CR = (<tl nl>) \<and> noDblBk CR" by blast
+
+  show ?thesis
+  proof (rule Hoare_consequence)
+    (*  1. \<lambda>tap. tap = (Bk # rev (<hd nl>), <tl nl>) \<mapsto> ?P *)
+    from assms and w_CL_CR  show "(\<lambda>tap. tap = (Bk # rev (<hd nl>), <tl nl>)) \<mapsto> (\<lambda>tap. tap = ([Bk,Oc] @ CL, CR))"
+      using Cons_eq_appendI append_self_conv assert_imp_def by auto
+  next
+    (*  1. \<lbrace>\<lambda>tap. tap = ([Bk, Oc] @ CL, CR)\<rbrace> tm_erase_right_then_dblBk_left \<lbrace>?Q\<rbrace> *)
+    from assms and w_CL_CR
+      show "\<lbrace> \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex ) \<rbrace>"
+      using tm_erase_right_then_dblBk_left_erp_total_correctness_CL_is_Nil
+      by blast
+  next
+    (*  1. \<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex) \<mapsto> \<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ <hd nl> @ [Bk] @ Bk \<up> rex) *)
+    show "(\<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex)) \<mapsto> (\<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ <hd nl> @ [Bk] @ Bk \<up> rex))"  
+      using Cons_eq_append_conv   assert_imp_def rev_numeral  w_CL_CR by fastforce
+  qed
+
+next
+  case (Suc nat)
+  then have "0 < hd nl" by auto
+  with assms
+  have "\<exists>CL CR.
+           [Oc] @ CL = rev(<hd nl>) \<and> noDblBk CL \<and> CL \<noteq> [] \<and> last CL = Oc \<and>
+                  CR = (<tl nl>)    \<and> noDblBk CR"
+    using tm_erase_right_then_dblBk_left_erp_total_correctness_helper_CL_neq_Nil_last_neq_0'
+    by auto
+  then obtain CL CR where
+    w_CL_CR: "[Oc] @ CL = rev(<hd nl>) \<and> noDblBk CL \<and> CL \<noteq> [] \<and> last CL = Oc \<and>
+                  CR = (<tl nl>)    \<and> noDblBk CR" by blast
+  show ?thesis
+  proof (rule Hoare_consequence)
+    (* 1. \<lambda>tap. tap = (Bk # rev (<hd nl>), <tl nl>) \<mapsto> ?P *)
+    from assms and w_CL_CR show "(\<lambda>tap. tap = (Bk # rev (<hd nl>), <tl nl>)) \<mapsto> (\<lambda>tap. tap = ([Bk,Oc] @ CL, CR))"
+      by (simp add: w_CL_CR assert_imp_def)
+  next
+    (* \<lbrace>\<lambda>tap. tap = ([Bk, Oc] @ CL, CR)\<rbrace> tm_erase_right_then_dblBk_left \<lbrace>?Q\<rbrace> *)
+    from assms and w_CL_CR
+    show "\<lbrace> \<lambda>tap. tap = ([Bk,Oc] @ CL, CR) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ (rev CL) @ [Oc, Bk] @ Bk \<up> rex ) \<rbrace>"
+      using tm_erase_right_then_dblBk_left_erp_total_correctness_CL_ew_Oc
+      by blast
+  next
+    (* \<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex) \<mapsto> \<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ <hd nl> @ [Bk] @ Bk \<up> rex) *)
+    show "(\<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ rev CL @ [Oc, Bk] @ Bk \<up> rex)) \<mapsto> (\<lambda>tap. \<exists>rex. tap = ([], [Bk, Bk] @ <hd nl> @ [Bk] @ Bk \<up> rex))"
+      using Cons_eq_append_conv   assert_imp_def rev_numeral  w_CL_CR  
+      by (simp add: assert_imp_def rev_numeral replicate_app_Cons_same  tape_of_nat_def)
+  qed
+qed
+
+
+(* ----------------------- tm_check_for_one_arg ----------------------- 
+ * Prove total correctness for COMPOSED machine tm_check_for_one_arg
+ * This is done via the rules for the composition operator seq_tm
+ * -------------------------------------------------------------------- *)
+
+(* we have
+
+DO_NOTHING path
+
+corollary tm_skip_first_arg_correct_Nil':
+  "length nl = 0
+   \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_skip_first_arg \<lbrace>\<lambda>tap.       tap = ( []           , [Bk] ) \<rbrace>"
+
+lemma tm_skip_first_arg_len_eq_1_total_correctness':
+  "length nl = 1
+   \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list> )\<rbrace> tm_skip_first_arg \<lbrace> \<lambda>tap. tap = ([Bk],  <[hd nl]> @[Bk])\<rbrace>"
+
+lemma tm_erase_right_then_dblBk_left_dnp_total_correctness:
+ "\<lbrace> \<lambda>tap. tap = ([], r ) \<rbrace> 
+    tm_erase_right_then_dblBk_left
+  \<lbrace> \<lambda>tap. tap = ([Bk,Bk], r ) \<rbrace>"
+
+---
+
+ERASE path
+
+lemma tm_skip_first_arg_len_gt_1_total_correctness:
+  assumes "1 < length (nl::nat list)"
+  shows "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list> )\<rbrace> tm_skip_first_arg \<lbrace> \<lambda>tap. tap = (Bk# <rev [hd nl]>, <tl nl>) \<rbrace>"
+
+lemma tm_erase_right_then_dblBk_left_erp_total_correctness_one_arg:
+  assumes "1 \<le> length (nl::nat list)"
+  shows "\<lbrace> \<lambda>tap. tap = (Bk# rev(<hd nl>), <tl nl>) \<rbrace> 
+           tm_erase_right_then_dblBk_left
+         \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ (<hd nl>) @ [Bk] @ Bk \<up> rex ) \<rbrace>"
+
+*)
+
+(*
+let tm_check_for_one_arg = foldl1' seqcomp_tm [ tm_skip_first_arg, tm_erase_right_then_dblBk_left ]
+*)
+
+definition 
+  tm_check_for_one_arg :: "instr list"
+  where
+    "tm_check_for_one_arg \<equiv> tm_skip_first_arg |+| tm_erase_right_then_dblBk_left"
+
+
+lemma tm_check_for_one_arg_total_correctness_Nil:
+  "length nl = 0
+   \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_check_for_one_arg \<lbrace>\<lambda>tap. tap = ([Bk,Bk], [Bk] ) \<rbrace>"
+proof -
+  assume major: "length nl = 0"
+  have "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> (tm_skip_first_arg |+| tm_erase_right_then_dblBk_left) \<lbrace>\<lambda>tap. tap = ([Bk,Bk], [Bk] ) \<rbrace>"
+  proof (rule Hoare_plus_halt)
+    show "composable_tm0 tm_skip_first_arg"
+      by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+          tm_skip_first_arg_def tm_erase_right_then_dblBk_left_def)
+  next
+    from major show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_skip_first_arg \<lbrace>\<lambda>tap. tap = ( [] , [Bk] ) \<rbrace>"
+      using tm_skip_first_arg_correct_Nil'
+      by simp
+  next
+    from major show "\<lbrace>\<lambda>tap. tap = ([], [Bk])\<rbrace> tm_erase_right_then_dblBk_left \<lbrace>\<lambda>tap. tap = ([Bk, Bk], [Bk])\<rbrace>"
+      using tm_erase_right_then_dblBk_left_dnp_total_correctness
+      by simp
+  qed
+  then show ?thesis
+    unfolding tm_check_for_one_arg_def
+    by auto
+qed
+
+lemma tm_check_for_one_arg_total_correctness_len_eq_1:
+  "length nl = 1
+   \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_check_for_one_arg \<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <nl> @ [Bk])\<rbrace>"
+proof -
+  assume major: "length nl = 1"
+  have " \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
+          (tm_skip_first_arg |+| tm_erase_right_then_dblBk_left)
+         \<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <nl> @ [Bk])\<rbrace>"
+  proof (rule Hoare_plus_halt)
+    show "composable_tm0 tm_skip_first_arg"
+      by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+          tm_skip_first_arg_def tm_erase_right_then_dblBk_left_def)
+  next
+    from major have "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_skip_first_arg \<lbrace> \<lambda>tap. tap = ([Bk],  <[hd nl]> @[Bk])\<rbrace>"
+      using tm_skip_first_arg_len_eq_1_total_correctness'
+      by simp
+    moreover from major have  "(nl::nat list) = [hd nl]"
+      by (metis diff_self_eq_0 length_0_conv length_tl list.exhaust_sel zero_neq_one)
+    ultimately
+    show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_skip_first_arg \<lbrace> \<lambda>tap. tap = ([Bk],  <nl> @[Bk])\<rbrace>" using major
+      by auto
+  next
+    from major
+    have "\<lbrace>\<lambda>tap. tap = ([], <nl> @ [Bk])\<rbrace> tm_erase_right_then_dblBk_left \<lbrace>\<lambda>tap. tap = ([Bk, Bk], <nl> @ [Bk])\<rbrace>"
+      using tm_erase_right_then_dblBk_left_dnp_total_correctness
+      by simp
+        (* Add a blank on the initial left tape *)
+    with major have "\<exists>stp. is_final (steps0 (1, [],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp) \<and>
+                           (steps0 (1, [],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp = (0, [Bk, Bk], <nl> @ [Bk]))"
+      unfolding Hoare_halt_def
+      by (smt Hoare_halt_def Pair_inject  holds_for.elims(2) is_final.elims(2))
+    then obtain stp where
+      w_stp: "is_final (steps0 (1, [],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp) \<and>
+               (steps0 (1, [],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp = (0, [Bk, Bk], <nl> @ [Bk]))" by blast
+
+    then have "is_final (steps0 (1, Bk \<up> 0,<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp) \<and>
+               (steps0 (1, Bk \<up> 0,<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp = (0, Bk \<up> 2, <nl> @ [Bk]))"
+      by (simp add: is_finalI numeral_eqs_upto_12(1))
+    then have "\<exists>z3. z3 \<le> 0 + 1 \<and>
+                is_final (steps0 (1, Bk \<up> (0+1),<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp) \<and>
+                 (steps0 (1, Bk \<up> (0+1),<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp = (0, Bk \<up> (2+z3), <nl> @ [Bk]))"
+      by (metis is_finalI  steps_left_tape_EnlargeBkCtx)
+    then have "is_final (steps0 (1, [Bk],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp) \<and>
+                   (\<exists>z4. steps0 (1, [Bk],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp = (0, Bk \<up> z4, <nl> @ [Bk]))"
+      by (metis One_nat_def add.left_neutral replicate_0 replicate_Suc)
+    then have "\<exists>n. is_final (steps0 (1, [Bk],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left n) \<and>
+                   (\<exists>z4. steps0 (1, [Bk],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left n = (0, Bk \<up> z4, <nl> @ [Bk]))"
+      by blast
+    then show "\<lbrace>\<lambda>tap. tap = ([Bk], <nl::nat list> @ [Bk])\<rbrace>
+                 tm_erase_right_then_dblBk_left
+               \<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <nl::nat list> @ [Bk])\<rbrace>"
+      using Hoare_halt_def Hoare_unhalt_def holds_for.simps by auto
+  qed
+  then show ?thesis
+    unfolding tm_check_for_one_arg_def
+    by auto
+qed
+
+(* Old version of tm_check_for_one_arg_total_correctness_len_eq_1:
+ * Keep this proof as an example
+ * The proof shows how to add blanks on the initial left tape, if you need some for composition with some predecessor tm
+ *)
+
+(*
+lemma tm_check_for_one_arg_total_correctness_len_eq_1:
+  "length nl = 1
+   \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_check_for_one_arg \<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <nl> @ [Bk])\<rbrace>"
+proof -
+  assume major: "length nl = 1"
+  have " \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
+          (tm_skip_first_arg |+| tm_erase_right_then_dblBk_left)
+         \<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <nl> @ [Bk])\<rbrace>"
+  proof (rule Hoare_plus_halt)
+    show "composable_tm0 tm_skip_first_arg"
+      by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+          tm_skip_first_arg_def tm_erase_right_then_dblBk_left_def)
+  next
+    from major have "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_skip_first_arg \<lbrace> \<lambda>tap. tap = ([Bk],  <[hd nl]> @[Bk])\<rbrace>"
+      using tm_skip_first_arg_len_eq_1_total_correctness'
+      by simp
+    moreover from major have  "(nl::nat list) = [hd nl]"
+      by (metis diff_self_eq_0 length_0_conv length_tl list.exhaust_sel zero_neq_one)
+    ultimately
+    show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_skip_first_arg \<lbrace> \<lambda>tap. tap = ([Bk],  <nl> @[Bk])\<rbrace>" using major
+      by auto
+  next
+    from major
+    have "\<lbrace>\<lambda>tap. tap = ([], <nl> @ [Bk])\<rbrace> tm_erase_right_then_dblBk_left \<lbrace>\<lambda>tap. tap = ([Bk, Bk], <nl> @ [Bk])\<rbrace>"
+      using tm_erase_right_then_dblBk_left_dnp_total_correctness
+      by simp
+        (* Add a blank on the initial left tape *)
+        (* Note: since we proved 
+
+              \<lbrace>\<lambda>tap. tap = ([], <nl> @ [Bk])\<rbrace> tm_erase_right_then_dblBk_left \<lbrace>\<lambda>tap. tap = ([Bk, Bk], <nl> @ [Bk])\<rbrace>
+
+           we need to add a blank on the left tape.
+           This is no problem, since blanks on the left tape do not matter.
+           However, adding blanks also changes the resulting left tape.
+           Instead of      \<lbrace>\<lambda>tap. tap = ([Bk, Bk], <nl> @ [Bk])\<rbrace>
+           we end up with  \<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <nl> @ [Bk])\<rbrace>
+
+           If we had proved  
+              \<lbrace>\<lambda>tap. tap = ([Bk], <nl> @ [Bk])\<rbrace> tm_erase_right_then_dblBk_left \<lbrace>\<lambda>tap. tap = ([Bk, Bk], <nl> @ [Bk])\<rbrace>
+
+           in the first place, there would be no need for this weakened result.
+
+           But since trailing blanks on the final left tape do not matter either, this is no real problem.
+        *)
+    with major have "\<exists>stp. is_final (steps0 (1, [],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp) \<and>
+                           (steps0 (1, [],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp = (0, [Bk, Bk], <nl> @ [Bk]))"
+      unfolding Hoare_halt_def
+      by (smt Hoare_halt_def Pair_inject  holds_for.elims(2) is_final.elims(2))
+    then obtain stp where
+      w_stp: "is_final (steps0 (1, [],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp) \<and>
+               (steps0 (1, [],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp = (0, [Bk, Bk], <nl> @ [Bk]))" by blast
+
+    then have "is_final (steps0 (1, Bk \<up> 0,<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp) \<and>
+               (steps0 (1, Bk \<up> 0,<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp = (0, Bk \<up> 2, <nl> @ [Bk]))"
+      by (simp add: is_finalI numeral_eqs_upto_12(1))
+    then have "\<exists>z3. z3 \<le> 0 + 1 \<and>
+                is_final (steps0 (1, Bk \<up> (0+1),<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp) \<and>
+                 (steps0 (1, Bk \<up> (0+1),<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp = (0, Bk \<up> (2+z3), <nl> @ [Bk]))"
+      by (metis is_finalI  steps_left_tape_EnlargeBkCtx)
+    then have "is_final (steps0 (1, [Bk],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp) \<and>
+                   (\<exists>z4. steps0 (1, [Bk],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left stp = (0, Bk \<up> z4, <nl> @ [Bk]))"
+      by (metis One_nat_def add.left_neutral replicate_0 replicate_Suc)
+    then have "\<exists>n. is_final (steps0 (1, [Bk],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left n) \<and>
+                   (\<exists>z4. steps0 (1, [Bk],<nl::nat list>@ [Bk]) tm_erase_right_then_dblBk_left n = (0, Bk \<up> z4, <nl> @ [Bk]))"
+      by blast
+    then show "\<lbrace>\<lambda>tap. tap = ([Bk], <nl::nat list> @ [Bk])\<rbrace>
+                 tm_erase_right_then_dblBk_left
+               \<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <nl::nat list> @ [Bk])\<rbrace>"
+      using Hoare_halt_def Hoare_unhalt_def holds_for.simps by auto
+  qed
+  then show ?thesis
+    unfolding tm_check_for_one_arg_def
+    by auto
+qed
+
+*)
+lemma tm_check_for_one_arg_total_correctness_len_gt_1:
+  "length nl > 1
+   \<Longrightarrow>  \<lbrace>\<lambda>tap. tap = ([], <nl::nat list> )\<rbrace> tm_check_for_one_arg \<lbrace> \<lambda>tap. \<exists> l. tap = ( [],  [Bk,Bk] @ <[hd nl]> @ Bk \<up> l) \<rbrace>"
+proof -
+  assume major: "length nl > 1"
+  have " \<lbrace>\<lambda>tap. tap = ([], <nl::nat list> )\<rbrace>
+          (tm_skip_first_arg |+| tm_erase_right_then_dblBk_left)
+         \<lbrace> \<lambda>tap. \<exists> l. tap = ( [],  [Bk,Bk] @ <[hd nl]> @ Bk \<up> l) \<rbrace>"
+  proof (rule Hoare_plus_halt)
+    show "composable_tm0 tm_skip_first_arg"
+      by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+          tm_skip_first_arg_def tm_erase_right_then_dblBk_left_def)
+  next
+    from major show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list> )\<rbrace> tm_skip_first_arg \<lbrace> \<lambda>tap. tap = (Bk# <rev [hd nl]>, <tl nl>) \<rbrace>"
+      using tm_skip_first_arg_len_gt_1_total_correctness
+      by simp
+  next
+    from major
+    have "\<lbrace> \<lambda>tap. tap = (Bk# rev(<hd nl>), <tl nl>) \<rbrace> tm_erase_right_then_dblBk_left \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ (<hd nl>) @ [Bk] @ Bk \<up> rex ) \<rbrace>"
+      using tm_erase_right_then_dblBk_left_erp_total_correctness_one_arg
+      by simp
+    then have "\<lbrace> \<lambda>tap. tap = (Bk# <rev [hd nl]>, <tl nl>) \<rbrace> tm_erase_right_then_dblBk_left \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ <[hd nl]> @ [Bk] @ Bk \<up> rex ) \<rbrace>"
+      by (simp add:  rev_numeral rev_numeral_list tape_of_list_def )
+    then have "\<lbrace> \<lambda>tap. tap = (Bk# <rev [hd nl]>, <tl nl>) \<rbrace> tm_erase_right_then_dblBk_left \<lbrace> \<lambda>tap. \<exists>rex. tap = ([], [Bk,Bk] @ <[hd nl]> @ Bk \<up> (Suc rex) ) \<rbrace>"
+      by force
+    then show "\<lbrace>\<lambda>tap. tap = (Bk # <rev [hd nl]>, <tl nl>)\<rbrace> tm_erase_right_then_dblBk_left \<lbrace>\<lambda>tap. \<exists>l. tap = ([], [Bk, Bk] @ <[hd nl]> @ Bk \<up> l)\<rbrace>"
+      by (smt Hoare_haltI Hoare_halt_def holds_for.elims(2) holds_for.simps)
+  qed
+  then show ?thesis
+    unfolding tm_check_for_one_arg_def
+    by auto
+qed
+
+(* ---------- tm_strong_copy ---------- *)
+
+definition
+  tm_strong_copy :: "instr list"
+  where
+    "tm_strong_copy \<equiv> tm_check_for_one_arg |+| tm_weak_copy"
+
+(* Prove total correctness for COMPOSED machine tm_strong_copy.
+ * This is done via the rules for the composition operator seq_tm.
+ *)
+
+lemma tm_strong_copy_total_correctness_Nil:
+  "length nl = 0
+   \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_strong_copy \<lbrace>\<lambda>tap. tap = ([Bk,Bk,Bk,Bk],[]) \<rbrace>"
+proof -
+  assume major: "length nl = 0"
+  have " \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
+          tm_check_for_one_arg |+| tm_weak_copy
+         \<lbrace>\<lambda>tap. tap = ([Bk,Bk,Bk,Bk],[]) \<rbrace>"
+  proof (rule Hoare_plus_halt)
+    show "composable_tm0 tm_check_for_one_arg"
+      by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+          tm_weak_copy_def
+          tm_check_for_one_arg_def
+          tm_skip_first_arg_def
+          tm_erase_right_then_dblBk_left_def)
+  next
+    from major show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_check_for_one_arg \<lbrace>\<lambda>tap. tap = ([Bk,Bk], [Bk] ) \<rbrace>"
+      using tm_check_for_one_arg_total_correctness_Nil
+      by simp
+  next
+    from major show "\<lbrace>\<lambda>tap. tap = ([Bk, Bk], [Bk])\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk, Bk, Bk, Bk], [])\<rbrace>"
+      using tm_weak_copy_correct11'
+      by simp
+  qed
+  then show ?thesis
+    unfolding tm_strong_copy_def
+    by auto
+qed
+
+lemma tm_strong_copy_total_correctness_len_gt_1:
+  "1 < length nl
+   \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_strong_copy \<lbrace> \<lambda>tap. \<exists>l. tap = ([Bk,Bk], <[hd nl]> @ Bk \<up> l) \<rbrace>"
+proof -
+  assume major: "1 < length nl"
+  have " \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
+          tm_check_for_one_arg |+| tm_weak_copy
+         \<lbrace> \<lambda>tap. \<exists> l. tap = ([Bk,Bk], <[hd nl]> @ Bk \<up> l) \<rbrace>"
+  proof (rule Hoare_plus_halt)
+    show "composable_tm0 tm_check_for_one_arg"
+      by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+          tm_weak_copy_def
+          tm_check_for_one_arg_def
+          tm_skip_first_arg_def
+          tm_erase_right_then_dblBk_left_def)
+  next
+    from major show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_check_for_one_arg \<lbrace> \<lambda>tap. \<exists> l. tap = ( [],  [Bk,Bk] @ <[hd nl]> @ Bk \<up> l) \<rbrace>"
+      using tm_check_for_one_arg_total_correctness_len_gt_1
+      by simp
+  next
+    show "\<lbrace>\<lambda>tap. \<exists>l. tap = ([], [Bk, Bk] @ <[hd nl]> @ Bk \<up> l)\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>l. tap = ([Bk, Bk], <[hd nl]> @ Bk \<up> l)\<rbrace>"
+    proof -
+      have "\<And>r.\<lbrace>\<lambda>tap. tap = ([], [Bk,Bk]@r) \<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk,Bk], r) \<rbrace>"
+        using tm_weak_copy_correct13' by simp
+      then have "\<And>r. \<exists>stp. is_final (steps0 (1, [],[Bk,Bk]@r) tm_weak_copy stp) \<and>
+                           (steps0 (1, [],[Bk,Bk]@r) tm_weak_copy stp = (0, [Bk, Bk], r))"
+        unfolding Hoare_halt_def
+        by (smt Hoare_halt_def Pair_inject  holds_for.elims(2) is_final.elims(2))
+      then have "\<And>l. \<exists>stp. is_final (steps0 (1, [],[Bk,Bk]@<[hd nl]> @ Bk \<up> l) tm_weak_copy stp) \<and>
+                           (steps0 (1, [],[Bk,Bk]@<[hd nl]> @ Bk \<up> l) tm_weak_copy stp = (0, [Bk, Bk], <[hd nl]> @ Bk \<up> l))"
+        by blast
+      then show ?thesis
+        using Hoare_halt_def holds_for.simps by fastforce
+    qed
+  qed
+  then show ?thesis
+    unfolding tm_strong_copy_def
+    by auto
+qed
+
+lemma tm_strong_copy_total_correctness_len_eq_1:
+  "1 = length nl
+   \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_strong_copy \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd nl, hd nl]> @ Bk \<up> l) \<rbrace>"
+proof -
+  assume major: "1 = length nl"
+  have " \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
+           tm_check_for_one_arg |+| tm_weak_copy
+         \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd nl, hd nl]> @ Bk \<up> l) \<rbrace>"
+  proof (rule Hoare_plus_halt)
+    show "composable_tm0 tm_check_for_one_arg"
+      by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+          tm_weak_copy_def
+          tm_check_for_one_arg_def
+          tm_skip_first_arg_def
+          tm_erase_right_then_dblBk_left_def)
+  next
+    from major show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_check_for_one_arg \<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <nl> @ [Bk])\<rbrace>"
+      using tm_check_for_one_arg_total_correctness_len_eq_1
+      by simp
+  next
+    have "\<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <[hd nl]> @[Bk])\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd nl, hd nl]> @ Bk \<up> l) \<rbrace>"
+      using tm_weak_copy_correct6
+      by simp
+    moreover from major have "<nl> = <[hd nl]>" 
+      by (metis diff_self_eq_0 length_0_conv length_tl list.exhaust_sel zero_neq_one)
+    ultimately show "\<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <nl> @ [Bk])\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd nl, hd nl]> @ Bk \<up> l)\<rbrace>"
+      by auto
+  qed
+  then show ?thesis
+    unfolding tm_strong_copy_def
+    by auto
+qed
+
+end
diff --git a/thys/Universal_Turing_Machine/TM_Playground.thy b/thys/Universal_Turing_Machine/TM_Playground.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/TM_Playground.thy
@@ -0,0 +1,97 @@
+(* Title: thys/TM_Playground.thy
+   Author: Franz Regensburger (FABR) 02/2022
+ *)
+
+theory TM_Playground 
+  imports
+    StrongCopyTM
+begin
+
+(* Playground *)
+
+(* ad numerals *)
+
+value "[1::nat,2,3,4] ! 0"
+value "[1::nat,2,3,4] ! 1"
+
+value "<2::nat>"
+value "tape_of (2::nat)"
+
+value "<(0::nat,1::nat)>"
+value "tape_of_nat_prod (0::nat,1::nat)"
+
+value "<([0,1::nat],[0,1::nat])>"
+value "tape_of_nat_prod ([0,1::nat],[0,1::nat])"
+
+value "tape_of_nat_list [2,0,3::nat]"
+value "<[2,0,3::nat]>"
+
+(* ad fetch function *)
+
+
+lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 0 Bk = (Nop , 0)" by auto
+lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 0 Oc = (Nop , 0)" by auto
+
+lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 1 Bk = (R , 3)" by auto
+lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 1 Oc = (WB, 2)" by auto
+
+lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 3 Bk = (WO, 0)"
+  by (simp add: numeral_eqs_upto_12)
+
+lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 3 Oc = (WB, 2)"
+  by (simp add: numeral_eqs_upto_12)
+
+(* fetch last instruction of program, which is explicitly given by the instr list *)
+lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 4 Bk = (L, 8)"
+  by (simp add: numeral_eqs_upto_12)
+
+(* fetch instruction outside of explicitly given instr list *)
+lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 4 Oc = (Nop, 0)"
+  by (simp add: numeral_eqs_upto_12)
+
+lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 10 Bk = (Nop, 0)"
+  by (simp add: numeral_eqs_upto_12)
+
+lemma "fetch [(R, 3),(WB,2), (R,1),(R,1), (WO,0),(WB,2), (L,8)] 10 Oc = (Nop, 0)"
+  by (simp add: numeral_eqs_upto_12)
+
+
+(* ad Hoare triples *)
+
+(* This result can be validated by a simple test run *)
+lemma 
+  "\<lbrace>\<lambda>(l1, r1). (l1,r1) = ([], [Oc,Oc] )\<rbrace> tm_weak_copy \<lbrace>\<lambda>(l0,r0). \<exists>k l. (l0,r0) = (Bk \<up> k, [Oc,Oc,Bk,Oc,Oc] @ Bk \<up> l)\<rbrace>"
+proof -
+  have "\<lbrace>\<lambda>tap. tap = ([], <[1::nat]>) \<rbrace> tm_weak_copy \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd [1::nat], hd [1::nat]]> @ Bk \<up> l) \<rbrace>"    
+    by (simp add: tm_weak_copy_correct5)
+  then have "\<lbrace>\<lambda>tap. tap = ([], <[1::nat]>) \<rbrace> tm_weak_copy \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[1::nat, 1::nat]> @ Bk \<up> l) \<rbrace>"
+    by force
+  moreover have "<[1::nat]> = [Oc,Oc]"
+    by (simp add: tape_of_list_def tape_of_nat_def)
+  moreover have "<[1::nat, 1::nat]> = [Oc,Oc,Bk,Oc,Oc]"
+    by (simp add: tape_of_list_def tape_of_nat_def)
+  ultimately have "\<lbrace>\<lambda>tap. tap = ([], <[1::nat]>) \<rbrace> tm_weak_copy \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd [1::nat], hd [1::nat]]> @ Bk \<up> l) \<rbrace>"
+    by simp
+  then show ?thesis
+    by (smt Hoare_haltI Hoare_halt_E0 \<open><[1, 1]> = [Oc, Oc, Bk, Oc, Oc]\<close> \<open><[1]> = [Oc, Oc]\<close>
+        case_prodD case_prodI holds_for.simps is_final_eq list.discI list.inject list.sel(1)
+        not_Cons_self2 tape_of_list_def tape_of_nat_def tape_of_nat_list.elims tape_of_nat_list.simps(3))
+qed
+
+(* However, this general result can never be validated by testing. It must be verified by a proof *)
+lemma 
+  "\<forall>n. \<lbrace>\<lambda>tap. tap = ([], Oc\<up>(n+1))\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k,  Oc\<up>(n+1) @ [Bk] @ Oc\<up>(n+1) @ Bk \<up> l) \<rbrace>"
+proof 
+  fix n
+  have "\<lbrace>\<lambda>tap. tap = ([], <[n::nat]>)\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[n, n]> @ Bk \<up> l) \<rbrace>"
+    by (rule tm_weak_copy_correct5)
+  moreover have "<[n::nat]> =  Oc\<up>(Suc n)"
+    by (simp add: tape_of_list_def tape_of_nat_def)
+  moreover have "<[n, n]> =  Oc\<up>(Suc n) @ [Bk] @ Oc\<up>(Suc n)"
+    by (simp add: tape_of_list_def tape_of_nat_def)
+  ultimately have X: "\<lbrace>\<lambda>tap. tap = ([], Oc\<up>(Suc n))\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k,  Oc\<up>(Suc n) @ [Bk] @ Oc\<up>(Suc n) @ Bk \<up> l) \<rbrace>"
+    by simp
+  show "\<lbrace>\<lambda>tap. tap = ([], Oc\<up>(n+1))\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k,  Oc\<up>(n+1) @ [Bk] @ Oc\<up>(n+1) @ Bk \<up> l) \<rbrace>" using X by auto
+qed
+
+end
diff --git a/thys/Universal_Turing_Machine/Turing.thy b/thys/Universal_Turing_Machine/Turing.thy
--- a/thys/Universal_Turing_Machine/Turing.thy
+++ b/thys/Universal_Turing_Machine/Turing.thy
@@ -1,452 +1,362 @@
 (* Title: thys/Turing.thy
    Author: Jian Xu, Xingyuan Zhang, and Christian Urban
    Modifications: Sebastiaan Joosten
-*)
+   Modifications, comments by Franz Regensburger (FABR) 02/2022
+ *)
 
 chapter \<open>Turing Machines\<close>
 
 theory Turing
   imports Main
 begin
 
-section \<open>Basic definitions of Turing machine\<close>
+section \<open>Some lemmas about natural numbers used for rewriting\<close>
 
-datatype action = W0 | W1 | L | R | Nop
+(* ------ Important properties used in subsequent theories ------ *)
+
+(*
+  Num.numeral_1_eq_Suc_0: Numeral1 = Suc 0
+  Num.numeral_2_eq_2: 2 = Suc (Suc 0)
+  Num.numeral_3_eq_3: 3 = Suc (Suc (Suc 0))
+*)
+
+lemma numeral_4_eq_4: "4 = Suc 3"
+  by auto
+
+lemma numeral_eqs_upto_12:
+  shows "2 = Suc 1"
+    and "3 = Suc 2"
+    and "4 = Suc 3" 
+    and "5 = Suc 4" 
+    and "6 = Suc 5" 
+    and "7 = Suc 6"
+    and "8 = Suc 7" 
+    and "9 = Suc 8" 
+    and "10 = Suc 9"
+    and "11 = Suc 10"
+    and "12 = Suc 11"
+  by simp_all
+
+
+section \<open>Basic Definitions for Turing Machines\<close>
+
+datatype action = WB | WO | L | R | Nop
 
 datatype cell = Bk | Oc
 
+text\<open>Remark: the constructors @{term W0} and @{term W1} were renamed into @{term WB} and @{term WO}
+respectively because this makes a better match with the constructors @{term Bk} and @{term Oc} of 
+type @{typ cell}.\<close>
+
 type_synonym tape = "cell list \<times> cell list"
 
 type_synonym state = nat
 
 type_synonym instr = "action \<times> state"
 
 type_synonym tprog = "instr list \<times> nat"
 
+(* The type tprog0 is the type of un-shifted Turing machines (offset = 0).
+ *
+ * FABR note:
+ * Every (tm:: instr list) is a proper Turing machine.
+ *
+ * However, tm may not be composable with other Turing machines.
+ * For the sequential composition tm |+| tm' the machine tm must be 'well-formed'.
+ * See theory ComposableTMs.thy for more details.
+ *
+ * We will prove in theory ComposableTMs.thy that for every 
+ * Turing machine tm, which is not well-formed, there is a machine
+ *    (mk_composable0 tm)
+ * that is well-formed and has the same behaviour as tm.
+ *
+ * Thus, all Turing machines can be made composable :-)
+ *)
+
 type_synonym tprog0 = "instr list"
 
 type_synonym config = "state \<times> tape"
 
 fun nth_of where
   "nth_of xs i = (if i \<ge> length xs then None else Some (xs ! i))"
 
-lemma nth_of_map [simp]:
+lemma nth_of_map (* [simp]*): (* this lemma is used nowhere *)
   shows "nth_of (map f p) n = (case (nth_of p n) of None \<Rightarrow> None | Some x \<Rightarrow> Some (f x))"
   by simp
 
 fun 
   fetch :: "instr list \<Rightarrow> state \<Rightarrow> cell \<Rightarrow> instr"
   where
     "fetch p 0 b = (Nop, 0)"
   | "fetch p (Suc s) Bk = 
      (case nth_of p (2 * s) of
         Some i \<Rightarrow> i
       | None \<Rightarrow> (Nop, 0))"
   |"fetch p (Suc s) Oc = 
      (case nth_of p ((2 * s) + 1) of
          Some i \<Rightarrow> i
        | None \<Rightarrow> (Nop, 0))"
 
 lemma fetch_Nil [simp]:
   shows "fetch [] s b = (Nop, 0)"
   by (cases s,force) (cases b;force)
 
+(* Simpler code without usage of function nth_of *)
+lemma fetch_imp [code]: "fetch p n b = (
+    let len = length p
+    in
+    if n = 0
+    then (Nop, 0)
+    else if b = Bk
+         then if len \<le> 2*n -2
+              then (Nop,0)
+              else (p ! (2*n-2))
+         else if len \<le> 2*n-1
+              then (Nop,0)
+              else (p ! (2*n-1))
+  )"
+  by (cases n; cases b)(auto)
+
+(* ------------------------------------ *)
+(* Some arithmetic properties           *)
+(* ------------------------------------ *)
+
+lemma even_le_div2_imp_le_times_2: "m     div 2 < (Suc n) \<and> ((m::nat) mod 2 = 0) \<Longrightarrow> m \<le> 2*n" by arith
+
+lemma odd_le_div2_imp_le_times_2: "(m+1) div 2 < (Suc n) \<and> ((m::nat) mod 2 \<noteq> 0) \<Longrightarrow> m \<le> 2*n" by arith
+
+lemma odd_div2_plus_1_eq: "(n::nat) mod 2 \<noteq> 0 \<Longrightarrow> (n div 2) + 1 = (n+1) div 2"
+proof (induct n)
+  case 0
+  then show ?case by auto
+next
+  case (Suc n)
+  then show ?case by arith
+qed
+
+(* ---------------------------------- *)
+(* A lemma about the list function tl *)
+(* ---------------------------------- *)
+
+lemma list_length_tl_neq_Nil: "1 < length (nl::nat list) \<Longrightarrow> tl nl \<noteq> []"
+proof
+  assume "1 < length nl" and "tl nl = []"
+  then have "length (tl nl) = 0" by auto
+  with \<open>1 < length nl\<close> and length_tl
+  show False by auto
+qed
+
+(* --- A function for executing actions on the tape --- *)
+
 fun 
   update :: "action \<Rightarrow> tape \<Rightarrow> tape"
   where 
-    "update W0 (l, r) = (l, Bk # (tl r))" 
-  | "update W1 (l, r) = (l, Oc # (tl r))"
+    "update WB (l, r) = (l, Bk # (tl r))" 
+  | "update WO (l, r) = (l, Oc # (tl r))"
   | "update L (l, r) = (if l = [] then ([], Bk # r) else (tl l, (hd l) # r))" 
   | "update R (l, r) = (if r = [] then (Bk # l, []) else ((hd r) # l, tl r))" 
   | "update Nop (l, r) = (l, r)"
 
 abbreviation 
   "read r == if (r = []) then Bk else hd r"
 
 fun step :: "config \<Rightarrow> tprog \<Rightarrow> config"
   where 
     "step (s, l, r) (p, off) = 
      (let (a, s') = fetch p (s - off) (read r) in (s', update a (l, r)))"
 
 abbreviation
   "step0 c p \<equiv> step c (p, 0)"
 
 fun steps :: "config \<Rightarrow> tprog \<Rightarrow> nat \<Rightarrow> config"
   where
     "steps c p 0 = c" |
     "steps c p (Suc n) = steps (step c p) p n"
 
 abbreviation
   "steps0 c p n \<equiv> steps c (p, 0) n"
 
+
 lemma step_red [simp]: 
   shows "steps c p (Suc n) = step (steps c p n) p"
   by (induct n arbitrary: c) (auto)
 
 lemma steps_add [simp]: 
   shows "steps c p (m + n) = steps (steps c p m) p n"
   by (induct m arbitrary: c) (auto)
 
 lemma step_0 [simp]: 
   shows "step (0, (l, r)) p = (0, (l, r))"
   by (cases p, simp)
 
+lemma step_0': "step (0, tap) p = (0, tap)" by (cases tap) auto
+
+
 lemma steps_0 [simp]: 
   shows "steps (0, (l, r)) p n = (0, (l, r))"
   by (induct n) (simp_all)
 
 fun
   is_final :: "config \<Rightarrow> bool"
   where
     "is_final (s, l, r) = (s = 0)"
 
 lemma is_final_eq: 
-  shows "is_final (s, tp) = (s = 0)"
-  by (cases tp) (auto)
+  shows "is_final (s, tap) = (s = 0)"
+  by (cases tap) (auto)
 
 lemma is_finalI [intro]:
-  shows "is_final (0, tp)"
+  shows "is_final (0, tap)"
   by (simp add: is_final_eq)
 
 lemma after_is_final:
   assumes "is_final c"
   shows "is_final (steps c p n)"
   using assms 
   by(induct n;cases c;auto)
 
 lemma is_final:
   assumes a: "is_final (steps c p n1)"
     and b: "n1 \<le> n2"
   shows "is_final (steps c p n2)"
 proof - 
   obtain n3 where eq: "n2 = n1 + n3" using b by (metis le_iff_add)
   from a show "is_final (steps c p n2)" unfolding eq
     by (simp add: after_is_final)
 qed
 
+(* steps add *)
+lemma stable_config_after_final_add:
+  assumes "steps (1, l, r) p n1      = (0, l', r')"
+  shows   "steps (1, l, r) p (n1+n2) = (0, l', r')"
+proof -
+  from assms have "is_final (steps (1, l, r) p n1)" by  (auto simp add: is_final_eq)
+  moreover have "n1 \<le> (n1+n2)" by auto
+  ultimately have "is_final (steps (1, l, r) p (n1+n2))" by (rule  is_final)
+  with assms show ?thesis by (auto simp add: is_final_eq)
+qed
+
+lemma stable_config_after_final_add_2:
+  assumes "steps (s, l, r) p n1      = (0, l', r')"
+  shows   "steps (s, l, r) p (n1+n2) = (0, l', r')"
+proof -
+  from assms have "is_final (steps (s, l, r) p n1)" by  (auto simp add: is_final_eq)
+  moreover have "n1 \<le> (n1+n2)" by auto
+  ultimately have "is_final (steps (s, l, r) p (n1+n2))" by (rule  is_final)
+  with assms show ?thesis by (auto simp add: is_final_eq)
+qed
+
+(* steps \<le> *)
+
+lemma stable_config_after_final_ge:
+  assumes a: "steps (1, l, r) p n1 = (0, l', r')" and b: "n1 \<le> n2"
+  shows   "steps (1, l, r) p n2 = (0, l', r')"
+proof -
+  from b have "\<exists>k. n2 = n1 + k" by arith
+  then obtain k where w: "n2 = n1 + k" by blast
+  with a have "steps (1, l, r) p ( n1 + k) = (0, l', r')"
+    by (auto simp add: stable_config_after_final_add)
+  with w show ?thesis by auto
+qed
+
+lemma stable_config_after_final_ge_2:
+  assumes a: "steps (s, l, r) p n1 = (0, l', r')" and b: "n1 \<le> n2"
+  shows   "steps (s, l, r) p n2 = (0, l', r')"
+proof -
+  from b have "\<exists>k. n2 = n1 + k" by arith
+  then obtain k where w: "n2 = n1 + k" by blast
+  with a have "steps (s, l, r) p ( n1 + k) = (0, l', r')"
+    by (auto simp add: stable_config_after_final_add)
+  with w show ?thesis by auto
+qed
+
+(* steps0 \<le> *)
+
+lemma stable_config_after_final_ge':
+  assumes "steps0 (1, l, r) p n1 = (0, l', r')" and b: "n1 \<le> n2"
+  shows   "steps0 (1, l, r) p n2 = (0, l', r')"
+proof -
+  from assms have "steps (1, l, r) (p, 0) n1 = (0, l', r')" by auto
+  from this and  assms(2) show "steps (1, l, r) (p,0) n2 = (0, l', r')"
+    by (rule stable_config_after_final_ge)
+qed
+
+lemma stable_config_after_final_ge_2':
+  assumes "steps0 (s, l, r) p n1 = (0, l', r')" and b: "n1 \<le> n2"
+  shows   "steps0 (s, l, r) p n2 = (0, l', r')"
+proof -
+  from assms have "steps (s, l, r) (p, 0) n1 = (0, l', r')" by auto
+  from this and  assms(2) show "steps (s, l, r) (p,0) n2 = (0, l', r')"
+    by (rule stable_config_after_final_ge_2)
+qed
+
 lemma not_is_final:
   assumes a: "\<not> is_final (steps c p n1)"
     and b: "n2 \<le> n1"
   shows "\<not> is_final (steps c p n2)"
 proof (rule notI)
   obtain n3 where eq: "n1 = n2 + n3" using b by (metis le_iff_add)
   assume "is_final (steps c p n2)"
   then have "is_final (steps c p n1)" unfolding eq
     by (simp add: after_is_final)
   with a show "False" by simp
 qed
 
 (* if the machine is in the halting state, there must have 
    been a state just before the halting state *)
+
 lemma before_final: 
-  assumes "steps0 (1, tp) A n = (0, tp')"
-  shows "\<exists> n'. \<not> is_final (steps0 (1, tp) A n') \<and> steps0 (1, tp) A (Suc n') = (0, tp')"
+  assumes "steps0 (1, tap) A n = (0, tap')"
+  shows "\<exists> n'. \<not> is_final (steps0 (1, tap) A n') \<and> steps0 (1, tap) A (Suc n') = (0, tap')"
   using assms
-proof(induct n arbitrary: tp')
-  case (0 tp')
-  have asm: "steps0 (1, tp) A 0 = (0, tp')" by fact
-  then show "\<exists>n'. \<not> is_final (steps0 (1, tp) A n') \<and> steps0 (1, tp) A (Suc n') = (0, tp')"
+proof(induct n arbitrary: tap')
+  case (0 tap')
+  have asm: "steps0 (1, tap) A 0 = (0, tap')" by fact
+  then show "\<exists>n'. \<not> is_final (steps0 (1, tap) A n') \<and> steps0 (1, tap) A (Suc n') = (0, tap')"
     by simp
 next
-  case (Suc n tp')
-  have ih: "\<And>tp'. steps0 (1, tp) A n = (0, tp') \<Longrightarrow>
-    \<exists>n'. \<not> is_final (steps0 (1, tp) A n') \<and> steps0 (1, tp) A (Suc n') = (0, tp')" by fact
-  have asm: "steps0 (1, tp) A (Suc n) = (0, tp')" by fact
-  obtain s l r where cases: "steps0 (1, tp) A n = (s, l, r)"
+  case (Suc n tap')
+  have ih: "\<And>tap'. steps0 (1, tap) A n = (0, tap') \<Longrightarrow>
+    \<exists>n'. \<not> is_final (steps0 (1, tap) A n') \<and> steps0 (1, tap) A (Suc n') = (0, tap')" by fact
+  have asm: "steps0 (1, tap) A (Suc n) = (0, tap')" by fact
+  obtain s l r where cases: "steps0 (1, tap) A n = (s, l, r)"
     by (auto intro: is_final.cases)
-  then show "\<exists>n'. \<not> is_final (steps0 (1, tp) A n') \<and> steps0 (1, tp) A (Suc n') = (0, tp')"
+  then show "\<exists>n'. \<not> is_final (steps0 (1, tap) A n') \<and> steps0 (1, tap) A (Suc n') = (0, tap')"
   proof (cases "s = 0")
     case True (* in halting state *)
-    then have "steps0 (1, tp) A n = (0, tp')"
+    then have "steps0 (1, tap) A n = (0, tap')"
       using asm cases by (simp del: steps.simps)
     then show ?thesis using ih by simp
   next
     case False (* not in halting state *)
-    then have "\<not> is_final (steps0 (1, tp) A n) \<and> steps0 (1, tp) A (Suc n) = (0, tp')"
+    then have "\<not> is_final (steps0 (1, tap) A n) \<and> steps0 (1, tap) A (Suc n) = (0, tap')"
       using asm cases by simp
     then show ?thesis by auto
   qed
 qed
 
 lemma least_steps: 
-  assumes "steps0 (1, tp) A n = (0, tp')"
-  shows "\<exists> n'. (\<forall>n'' < n'. \<not> is_final (steps0 (1, tp) A n'')) \<and> 
-               (\<forall>n'' \<ge> n'. is_final (steps0 (1, tp) A n''))"
+  assumes "steps0 (1, tap) A n = (0, tap')"
+  shows "\<exists> n'. (\<forall>n'' < n'. \<not> is_final (steps0 (1, tap) A n'')) \<and> 
+               (\<forall>n'' \<ge> n'. is_final (steps0 (1, tap) A n''))"
 proof -
   from before_final[OF assms] 
   obtain n' where
-    before: "\<not> is_final (steps0 (1, tp) A n')" and
-    final: "steps0 (1, tp) A (Suc n') = (0, tp')" by auto
+    before: "\<not> is_final (steps0 (1, tap) A n')" and
+    final: "steps0 (1, tap) A (Suc n') = (0, tap')" by auto
   from before
-  have "\<forall>n'' < Suc n'. \<not> is_final (steps0 (1, tp) A n'')"
+  have "\<forall>n'' < Suc n'. \<not> is_final (steps0 (1, tap) A n'')"
     using not_is_final by auto
   moreover
   from final 
-  have "\<forall>n'' \<ge> Suc n'. is_final (steps0 (1, tp) A n'')" 
+  have "\<forall>n'' \<ge> Suc n'. is_final (steps0 (1, tap) A n'')" 
     using is_final[of _ _ "Suc n'"] by (auto simp add: is_final_eq)
   ultimately
-  show "\<exists> n'. (\<forall>n'' < n'. \<not> is_final (steps0 (1, tp) A n'')) \<and> (\<forall>n'' \<ge> n'. is_final (steps0 (1, tp) A n''))"
+  show "\<exists> n'. (\<forall>n'' < n'. \<not> is_final (steps0 (1, tap) A n'')) \<and> (\<forall>n'' \<ge> n'. is_final (steps0 (1, tap) A n''))"
     by blast
 qed
 
-
-
-(* well-formedness of Turing machine programs *)
-abbreviation "is_even n \<equiv> (n::nat) mod 2 = 0"
-
-fun 
-  tm_wf :: "tprog \<Rightarrow> bool"
-  where
-    "tm_wf (p, off) = (length p \<ge> 2 \<and> is_even (length p) \<and> 
-                    (\<forall>(a, s) \<in> set p. s \<le> length p div 2 + off \<and> s \<ge> off))"
-
-abbreviation
-  "tm_wf0 p \<equiv> tm_wf (p, 0)"
-
-abbreviation exponent :: "'a \<Rightarrow> nat \<Rightarrow> 'a list" ("_ \<up> _" [100, 99] 100)
-  where "x \<up> n == replicate n x"
-
-lemma hd_repeat_cases:
-  "P (hd (a \<up> m @ r)) \<longleftrightarrow> (m = 0 \<longrightarrow> P (hd r)) \<and> (\<forall>nat. m = Suc nat \<longrightarrow> P a)"
-  by (cases m,auto)
-
-class tape =
-  fixes tape_of :: "'a \<Rightarrow> cell list" ("<_>" 100)
-
-
-instantiation nat::tape begin
-definition tape_of_nat where "tape_of_nat (n::nat) \<equiv> Oc \<up> (Suc n)"
-instance by standard
-end
-
-type_synonym nat_list = "nat list"
-
-instantiation list::(tape) tape begin
-fun tape_of_nat_list :: "('a::tape) list \<Rightarrow> cell list" 
-  where 
-    "tape_of_nat_list [] = []" |
-    "tape_of_nat_list [n] = <n>" |
-    "tape_of_nat_list (n#ns) = <n> @ Bk # (tape_of_nat_list ns)"
-definition tape_of_list where "tape_of_list \<equiv> tape_of_nat_list"
-instance by standard
-end
-
-instantiation prod:: (tape, tape) tape begin
-fun tape_of_nat_prod :: "('a::tape) \<times> ('b::tape) \<Rightarrow> cell list" 
-  where "tape_of_nat_prod (n, m) = <n> @ [Bk] @ <m>" 
-definition tape_of_prod where "tape_of_prod \<equiv> tape_of_nat_prod"
-instance by standard
-end
-
-fun 
-  shift :: "instr list \<Rightarrow> nat \<Rightarrow> instr list"
-  where
-    "shift p n = (map (\<lambda> (a, s). (a, (if s = 0 then 0 else s + n))) p)"
-
-fun 
-  adjust :: "instr list \<Rightarrow> nat \<Rightarrow> instr list"
-  where
-    "adjust p e = map (\<lambda> (a, s). (a, if s = 0 then e else s)) p"
-
-abbreviation
-  "adjust0 p \<equiv> adjust p (Suc (length p div 2))"
-
-lemma length_shift [simp]: 
-  shows "length (shift p n) = length p"
-  by simp
-
-lemma length_adjust [simp]: 
-  shows "length (adjust p n) = length p"
-  by (induct p) (auto)
-
-
-(* composition of two Turing machines *)
-fun
-  tm_comp :: "instr list \<Rightarrow> instr list \<Rightarrow> instr list" ("_ |+| _" [0, 0] 100)
-  where
-    "tm_comp p1 p2 = ((adjust0 p1) @ (shift p2 (length p1 div 2)))"
-
-lemma tm_comp_length:
-  shows "length (A |+| B) = length A + length B"
-  by auto
-
-lemma tm_comp_wf[intro]: 
-  "\<lbrakk>tm_wf (A, 0); tm_wf (B, 0)\<rbrakk> \<Longrightarrow> tm_wf (A |+| B, 0)"
-  by (fastforce)
-
-lemma tm_comp_step: 
-  assumes unfinal: "\<not> is_final (step0 c A)"
-  shows "step0 c (A |+| B) = step0 c A"
-proof -
-  obtain s l r where eq: "c = (s, l, r)" by (metis is_final.cases) 
-  have "\<not> is_final (step0 (s, l, r) A)" using unfinal eq by simp
-  then have "case (fetch A s (read r)) of (a, s) \<Rightarrow> s \<noteq> 0"
-    by (auto simp add: is_final_eq)
-  then have "fetch (A |+| B) s (read r) = fetch A s (read r)"
-    apply (cases "read r";cases s)
-    by (auto simp: tm_comp_length nth_append)
-  then show "step0 c (A |+| B) = step0 c A" by (simp add: eq) 
-qed
-
-lemma tm_comp_steps:  
-  assumes "\<not> is_final (steps0 c A n)" 
-  shows "steps0 c (A |+| B) n = steps0 c A n"
-  using assms
-proof(induct n)
-  case 0
-  then show "steps0 c (A |+| B) 0 = steps0 c A 0" by auto
-next 
-  case (Suc n)
-  have ih: "\<not> is_final (steps0 c A n) \<Longrightarrow> steps0 c (A |+| B) n = steps0 c A n" by fact
-  have fin: "\<not> is_final (steps0 c A (Suc n))" by fact
-  then have fin1: "\<not> is_final (step0 (steps0 c A n) A)" 
-    by (auto simp only: step_red)
-  then have fin2: "\<not> is_final (steps0 c A n)"
-    by (metis is_final_eq step_0 surj_pair) 
-
-  have "steps0 c (A |+| B) (Suc n) = step0 (steps0 c (A |+| B) n) (A |+| B)" 
-    by (simp only: step_red)
-  also have "... = step0 (steps0 c A n) (A |+| B)" by (simp only: ih[OF fin2])
-  also have "... = step0 (steps0 c A n) A" by (simp only: tm_comp_step[OF fin1])
-  finally show "steps0 c (A |+| B) (Suc n) = steps0 c A (Suc n)"
-    by (simp only: step_red)
-qed
-
-lemma tm_comp_fetch_in_A:
-  assumes h1: "fetch A s x = (a, 0)"
-    and h2: "s \<le> length A div 2" 
-    and h3: "s \<noteq> 0"
-  shows "fetch (A |+| B) s x = (a, Suc (length A div 2))"
-  using h1 h2 h3
-  apply(cases s;cases x)
-  by(auto simp: tm_comp_length nth_append)
-
-lemma tm_comp_exec_after_first:
-  assumes h1: "\<not> is_final c" 
-    and h2: "step0 c A = (0, tp)"
-    and h3: "fst c \<le> length A div 2"
-  shows "step0 c (A |+| B) = (Suc (length A div 2), tp)"
-  using h1 h2 h3
-  apply(case_tac c)
-  apply(auto simp del: tm_comp.simps)
-   apply(case_tac "fetch A a Bk")
-   apply(simp del: tm_comp.simps)
-   apply(subst tm_comp_fetch_in_A;force)
-  apply(case_tac "fetch A a (hd ca)")
-  apply(simp del: tm_comp.simps)
-  apply(subst tm_comp_fetch_in_A)
-     apply(auto)[4]
-  done
-
-lemma step_in_range: 
-  assumes h1: "\<not> is_final (step0 c A)"
-    and h2: "tm_wf (A, 0)"
-  shows "fst (step0 c A) \<le> length A div 2"
-  using h1 h2
-  apply(cases c;cases "fst c";cases "hd (snd (snd c))")
-  by(auto simp add: Let_def case_prod_beta')
-
-lemma steps_in_range: 
-  assumes h1: "\<not> is_final (steps0 (1, tp) A stp)"
-    and h2: "tm_wf (A, 0)"
-  shows "fst (steps0 (1, tp) A stp) \<le> length A div 2"
-  using h1
-proof(induct stp)
-  case 0
-  then show "fst (steps0 (1, tp) A 0) \<le> length A div 2" using h2
-    by (auto)
-next
-  case (Suc stp)
-  have ih: "\<not> is_final (steps0 (1, tp) A stp) \<Longrightarrow> fst (steps0 (1, tp) A stp) \<le> length A div 2" by fact
-  have h: "\<not> is_final (steps0 (1, tp) A (Suc stp))" by fact
-  from ih h h2 show "fst (steps0 (1, tp) A (Suc stp)) \<le> length A div 2"
-    by (metis step_in_range step_red)
-qed
-
-(* if A goes into the final state, then A |+| B will go into the first state of B *)
-lemma tm_comp_next: 
-  assumes a_ht: "steps0 (1, tp) A n = (0, tp')"
-    and a_wf: "tm_wf (A, 0)"
-  obtains n' where "steps0 (1, tp) (A |+| B) n' = (Suc (length A div 2), tp')"
-proof -
-  assume a: "\<And>n. steps (1, tp) (A |+| B, 0) n = (Suc (length A div 2), tp') \<Longrightarrow> thesis"
-  obtain stp' where fin: "\<not> is_final (steps0 (1, tp) A stp')" and h: "steps0 (1, tp) A (Suc stp') = (0, tp')"
-    using before_final[OF a_ht] by blast
-  from fin have h1:"steps0 (1, tp) (A |+| B) stp' = steps0 (1, tp) A stp'"
-    by (rule tm_comp_steps)
-  from h have h2: "step0 (steps0 (1, tp) A stp') A = (0, tp')"
-    by (simp only: step_red)
-
-  have "steps0 (1, tp) (A |+| B) (Suc stp') = step0 (steps0 (1, tp) (A |+| B) stp') (A |+| B)" 
-    by (simp only: step_red)
-  also have "... = step0 (steps0 (1, tp) A stp') (A |+| B)" using h1 by simp
-  also have "... = (Suc (length A div 2), tp')" 
-    by (rule tm_comp_exec_after_first[OF fin h2 steps_in_range[OF fin a_wf]])
-  finally show thesis using a by blast
-qed
-
-lemma tm_comp_fetch_second_zero:
-  assumes h1: "fetch B s x = (a, 0)"
-    and hs: "tm_wf (A, 0)" "s \<noteq> 0"
-  shows "fetch (A |+| B) (s + (length A div 2)) x = (a, 0)"
-  using h1 hs
-  by(cases x; cases s; fastforce simp: tm_comp_length nth_append)
-
-lemma tm_comp_fetch_second_inst:
-  assumes h1: "fetch B sa x = (a, s)"
-    and hs: "tm_wf (A, 0)" "sa \<noteq> 0" "s \<noteq> 0"
-  shows "fetch (A |+| B) (sa + length A div 2) x = (a, s + length A div 2)"
-  using h1 hs
-  by(cases x; cases sa; fastforce simp: tm_comp_length nth_append)
-
-
-lemma tm_comp_second:
-  assumes a_wf: "tm_wf (A, 0)"
-    and steps: "steps0 (1, l, r) B stp = (s', l', r')"
-  shows "steps0 (Suc (length A div 2), l, r)  (A |+| B) stp 
-    = (if s' = 0 then 0 else s' + length A div 2, l', r')"
-  using steps
-proof(induct stp arbitrary: s' l' r')
-  case 0
-  then show ?case by simp
-next
-  case (Suc stp s' l' r')
-  obtain s'' l'' r'' where a: "steps0 (1, l, r) B stp = (s'', l'', r'')"
-    by (metis is_final.cases)
-  then have ih1: "s'' = 0 \<Longrightarrow> steps0 (Suc (length A div 2), l, r) (A |+| B) stp = (0, l'', r'')"
-    and ih2: "s'' \<noteq> 0 \<Longrightarrow> steps0 (Suc (length A div 2), l, r) (A |+| B) stp = (s'' + length A div 2, l'', r'')"
-    using Suc by (auto)
-  have h: "steps0 (1, l, r) B (Suc stp) = (s', l', r')" by fact
-
-  { assume "s'' = 0"
-    then have ?case using a h ih1 by (simp del: steps.simps) 
-  } moreover
-  { assume as: "s'' \<noteq> 0" "s' = 0"
-    from as a h 
-    have "step0 (s'', l'', r'') B = (0, l', r')" by (simp del: steps.simps)
-    with as have ?case
-      apply(cases "fetch B s'' (read r'')")
-      by (auto simp add: tm_comp_fetch_second_zero[OF _ a_wf] ih2[OF as(1)]
-          simp del: tm_comp.simps steps.simps)
-  } moreover
-  { assume as: "s'' \<noteq> 0" "s' \<noteq> 0"
-    from as a h
-    have "step0 (s'', l'', r'') B = (s', l', r')" by (simp del: steps.simps)
-    with as have ?case
-      apply(simp add: ih2[OF as(1)] del: tm_comp.simps steps.simps)
-      apply(case_tac "fetch B s'' (read r'')")
-      apply(auto simp add: tm_comp_fetch_second_inst[OF _ a_wf as] simp del: tm_comp.simps)
-      done
-  }
-  ultimately show ?case by blast
-qed
-
-
-lemma tm_comp_final:
-  assumes "tm_wf (A, 0)"  
-    and "steps0 (1, l, r) B stp = (0, l', r')"
-  shows "steps0 (Suc (length A div 2), l, r)  (A |+| B) stp = (0, l', r')"
-  using tm_comp_second[OF assms] by (simp)
+lemma at_least_one_step:"steps0 (1, [], r) tm n = (0,tap) \<Longrightarrow> 0 < n"
+  by (cases n)(auto)
 
 end
-
diff --git a/thys/Universal_Turing_Machine/TuringComputable.thy b/thys/Universal_Turing_Machine/TuringComputable.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/TuringComputable.thy
@@ -0,0 +1,699 @@
+(* Title: thys/TuringComputable.thy
+   Author: Franz Regensburger (FABR) 03/2022
+ *)
+
+section \<open>Turing Computable Functions\<close>
+
+theory TuringComputable
+  imports
+    "HaltingProblems_K_H"
+begin
+
+(* -------------------------------------------------------------------------- *)
+
+(*
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+*)
+
+subsection \<open>Definition of Partial Turing Computability\<close>
+
+text \<open>We present two variants for a definition of Partial Turing Computability,
+ which we prove to be equivalent, later on.\<close>
+
+subsubsection \<open>Definition Variant 1\<close>
+
+definition turing_computable_partial :: "(nat list \<Rightarrow> nat option) \<Rightarrow> bool"
+  where "turing_computable_partial f \<equiv> (\<exists>tm. \<forall>ns n.
+          (f ns = Some n \<longrightarrow> (\<exists>stp k l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) \<and>
+          (f ns = None   \<longrightarrow> \<not>\<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>))"
+
+(* Major consequences of the definition *)
+
+(* This is for documentation and explanation: turing_computable_partial_unfolded_into_TMC_yields_TMC_has_conditions *)
+lemma turing_computable_partial_unfolded_into_TMC_yields_TMC_has_conditions:
+ "turing_computable_partial f \<equiv> (\<exists>tm. \<forall>ns n.
+          (f ns = Some n \<longrightarrow>   TMC_yields_num_res tm ns n) \<and>
+          (f ns = None   \<longrightarrow> \<not> TMC_has_num_res  tm ns   ) )"
+  unfolding TMC_yields_num_res_def TMC_has_num_res_def
+  by (simp add: turing_computable_partial_def)
+
+(* This is for rewriting *)
+lemma turing_computable_partial_unfolded_into_Hoare_halt_conditions:
+ "turing_computable_partial f \<longleftrightarrow> (\<exists>tm. \<forall>ns n.
+          (f ns = Some n \<longrightarrow>  \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk\<up> l) \<rbrace> ) \<and>
+          (f ns = None   \<longrightarrow> \<not>\<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l) \<rbrace>))"
+  unfolding turing_computable_partial_def
+proof
+  assume "\<exists>tm. \<forall>ns n. (f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) \<and>
+                      (f ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l) \<rbrace>)"
+  then obtain tm where
+    w_tm1:"\<forall>ns n. (f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) \<and>
+                 (f ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l) \<rbrace>)"
+    by blast
+  have "\<forall>ns n. (f ns = Some n \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>) \<and>
+               (f ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l) \<rbrace>)"
+    apply (safe)
+  proof -
+    (* ---- Some case *)
+    show "\<And>ns n. f ns = Some n \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n> @ Bk \<up> l)\<rbrace>"
+    proof -
+      fix ns n
+      assume "f ns = Some n"
+      with w_tm1 have F1: "\<exists>stp k l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)" by auto
+      show "\<lbrace>\<lambda>tap.  tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+      proof (rule Hoare_haltI)
+        fix l r
+        assume "(l, r) = ([]::cell list, <ns::nat list>)"
+        then show "\<exists>stp. is_final (steps0 (1, l, r) tm stp) \<and> (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) holds_for steps0 (1, l, r) tm stp"
+          by (metis (mono_tags, lifting) F1 holds_for.simps is_finalI)
+      qed
+    qed
+  next
+    (* ---- None case *)
+    show "\<And>ns n. \<lbrakk>f ns = None; \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace> \<rbrakk> \<Longrightarrow> False"
+    proof -
+      fix ns n
+      assume "f ns = None" and "\<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+      with w_tm1 show False
+        by simp
+    qed
+  qed
+  then show "\<exists>tm. \<forall>ns n. (f ns = Some n \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n> @ Bk \<up> l)\<rbrace>) \<and>
+            (f ns = None \<longrightarrow> \<not> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>)"
+    by auto
+next
+  assume "\<exists>tm. \<forall>ns n. (f ns = Some n \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>) \<and>
+                      (f ns = None \<longrightarrow> \<not> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>)"
+  then obtain tm where
+    w_tm2: "\<forall>ns n. (f ns = Some n \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>) \<and>
+                   (f ns = None \<longrightarrow> \<not> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>)"
+    by blast
+  have "\<forall>ns n. (f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) \<and>
+               (f ns = None \<longrightarrow> \<not> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>)"
+    apply (safe)
+  proof -
+    (* ---- Some case *)
+    show "\<And>ns n . f ns = Some n \<Longrightarrow> \<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <n> @ Bk \<up> l)"
+    proof -
+      fix ns n z
+      assume "f ns = Some n"
+      with w_tm2 have "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>" by blast
+
+      then show "\<exists>stp k l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+        by (smt Hoare_halt_def holds_for.elims(2) is_final.elims(2) snd_conv)
+    qed
+  next
+    (* ---- None case *)
+    show "\<And>ns n. \<lbrakk>f ns = None; \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>\<rbrakk> \<Longrightarrow> False"
+    proof -
+      fix ns n
+      assume "f ns = None" and "\<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+      with w_tm2 show False
+        by simp
+    qed
+  qed
+  then
+  show "\<exists>tm. \<forall>ns n. (f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) \<and>
+                    (f ns = None \<longrightarrow> \<not> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>)"
+    by blast
+qed
+
+
+(* --------------------------------------------------------------------------------------------------------- *)
+
+subsubsection \<open>Characteristic Functions of Sets\<close>
+
+definition chi_fun :: "(nat list) set \<Rightarrow> (nat list \<Rightarrow> nat option)"
+  where
+    "chi_fun nls = (\<lambda>nl. if nl \<in> nls then Some 1 else Some 0)"
+
+lemma chi_fun_0_iff: "nl \<notin> nls \<longleftrightarrow> chi_fun nls nl = Some 0"
+  unfolding chi_fun_def by auto
+
+lemma chi_fun_1_iff: "nl \<in> nls \<longleftrightarrow> chi_fun nls nl = Some 1"
+  unfolding chi_fun_def by auto
+
+lemma chi_fun_0_I: "nl \<notin> nls \<Longrightarrow> chi_fun nls nl = Some 0"
+  unfolding chi_fun_def by auto
+
+lemma chi_fun_0_E: "(chi_fun nls nl = Some 0 \<Longrightarrow> P) \<Longrightarrow> nl \<notin> nls \<Longrightarrow> P"
+  unfolding chi_fun_def by auto
+
+lemma chi_fun_1_I: "nl \<in> nls \<Longrightarrow> chi_fun nls nl = Some 1"
+  unfolding chi_fun_def by auto
+
+lemma chi_fun_1_E: "(chi_fun nls nl = Some 1 \<Longrightarrow> P) \<Longrightarrow> nl \<in> nls \<Longrightarrow> P"
+  unfolding chi_fun_def by auto
+
+(* --------------------------------------------------------------------------------------------------------- *)
+
+subsubsection \<open>Relation between Partial Turing Computability and Turing Decidability\<close>
+
+text \<open>If a set A is Turing Decidable its characteristic function is Turing Computable partial and vice versa.
+Please note, that although the characteristic function has an option type it will always yield Some value.
+\<close>
+
+theorem turing_decidable_imp_turing_computable_partial:
+  "turing_decidable A \<Longrightarrow> turing_computable_partial (chi_fun A)"
+proof -
+  assume "turing_decidable A"
+  then have
+    "(\<exists>D. (\<forall>nl. 
+         (nl \<in> A \<longrightarrow> \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk\<up> l))\<rbrace>)
+       \<and> (nl \<notin> A \<longrightarrow> \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk\<up> l))\<rbrace>)
+     ))"
+    unfolding turing_decidable_def by auto
+
+  then obtain D where w_D:
+    "(\<forall>nl. 
+         (nl \<in> A \<longrightarrow> \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk\<up> l))\<rbrace>)
+       \<and> (nl \<notin> A \<longrightarrow> \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk\<up> l))\<rbrace>)
+     )" by blast
+
+  then have F1:
+    "(\<forall>nl. 
+         (chi_fun A nl = Some 1 \<longrightarrow> \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk\<up> l))\<rbrace>)
+       \<and> (chi_fun A nl = Some 0 \<longrightarrow> \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk\<up> l))\<rbrace>)
+     )" using chi_fun_def by force
+
+  have F2: "\<forall>nl. (chi_fun A nl = Some 1 \<or> chi_fun A nl = Some 0)" using chi_fun_def
+    by simp
+
+  show ?thesis
+  proof (rule turing_computable_partial_unfolded_into_Hoare_halt_conditions[THEN iffD2])
+    have "\<forall>ns n. (chi_fun A ns = Some n \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> D \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n> @ Bk \<up> l)\<rbrace>) \<and>
+                 (chi_fun A ns = None \<longrightarrow> \<not> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> D \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>)"
+      apply (safe)
+    proof -
+      show "\<And>ns n. chi_fun A ns = Some n \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> D \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n> @ Bk \<up> l)\<rbrace>"
+      proof -
+        fix ns :: "nat list" and n :: nat
+        assume "chi_fun A ns = Some n"
+        then have "Some n = Some 1 \<or> Some n = Some 0"
+          by (metis F2)
+        then show "\<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> D \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n> @ Bk \<up> l)\<rbrace>"
+          using \<open>chi_fun A ns = Some n\<close> F1 by blast
+      qed
+    next
+      show " \<And>ns n. \<lbrakk>chi_fun A ns = None; \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> D \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace> \<rbrakk> \<Longrightarrow> False"
+        by (metis F2 option.distinct(1))
+    qed
+    then show "\<exists>tm. \<forall>ns n.
+                    (chi_fun A ns = Some n \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>) \<and>
+                    (chi_fun A ns = None \<longrightarrow> \<not> \<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>)"     
+      using F2 option.simps(3) by blast 
+  qed
+qed
+
+theorem turing_computable_partial_imp_turing_decidable:
+  "turing_computable_partial (chi_fun A) \<Longrightarrow> turing_decidable A"
+proof -
+  assume "turing_computable_partial (chi_fun A)"
+  then have "\<exists>tm. \<forall>ns n.
+            (chi_fun A ns = Some n \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>) \<and>
+            (chi_fun A ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace> )"
+    using turing_computable_partial_unfolded_into_Hoare_halt_conditions[THEN iffD1] by auto
+
+  then obtain tm where w_tm: "\<forall>ns n.
+            (chi_fun A ns = Some n \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>) \<and>
+            (chi_fun A ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)"
+    by auto
+  then have "\<forall>ns.
+          (ns \<in> A \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>) \<and>
+          (ns \<notin> A \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>)"
+    by (blast intro: chi_fun_0_I chi_fun_1_I)
+
+  then have "(\<exists>D.(\<forall>ns.
+          (ns \<in> A \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>) \<and>
+          (ns \<notin> A \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> tm \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>) ))"
+    by auto
+
+  then show ?thesis using turing_decidable_def by auto
+qed
+
+corollary turing_computable_partial_iff_turing_decidable:
+ "turing_decidable A \<longleftrightarrow> turing_computable_partial (chi_fun A)"
+  by (auto simp add: turing_computable_partial_imp_turing_decidable turing_decidable_imp_turing_computable_partial)
+
+subsubsection \<open>Examples for uncomputable functions\<close>
+
+text \<open>Now, we prove that the characteristic functions of the undecidable sets K1 and H1 are both uncomputable.\<close>
+
+context hpk
+begin
+
+theorem "\<not>(turing_computable_partial (chi_fun K1))"
+  using not_Turing_decidable_K1 turing_computable_partial_imp_turing_decidable by blast
+
+theorem "\<not>(turing_computable_partial (chi_fun H1))"
+  using not_Turing_decidable_H1 turing_computable_partial_imp_turing_decidable by blast
+
+end
+
+subsubsection \<open>The Function associated with a Turing Machine\<close>
+
+text \<open>With every Turing machine, we can associate a function.\<close>
+
+(* 
+Compare to definition of \<psi>\<^sub>P(r1, ... , rm)
+in the book
+
+[DSW94, pp 29]
+Computability, Complexity, and Languages
+Davis, Sigal and Weyuker
+Academic Press, 2nd Edition, 1994
+ISBN 0-12-206382-1
+
+Relation between our notion fun_of_tm and \<psi>\<^sub>P of [DSW94, pp 29]
+
+  \<psi>\<^sub>P(r1, ... , rm) = y  \<longleftrightarrow>  fun_of_tm tm <[r1, ... , rm]> = Some y
+
+and 
+
+  \<psi>\<^sub>P(r1, ... , rm)\<up>  \<longleftrightarrow>  fun_of_tm tm <[r1, ... , rm]> = None
+
+Note: for the GOTO pgms of [DSW94] the question whether the program P halts
+      with a standard tape or with a non-standard tape does not matter since
+      there are no tapes to consider. There are only registers with values.
+      If the program P halts on input (r1, ... , rm) it yields a result, always.
+
+      On the other hand, our Turing machines may reach the final state 0
+      with a non-standard tape and thus provide no valid output.
+
+      In such a case, fun_of_tm tm <[r1, ... , rm]> = None per definition.
+*)
+
+definition fun_of_tm :: "tprog0 \<Rightarrow> (nat list \<Rightarrow> nat option)"
+  where "fun_of_tm tm ns \<equiv>
+           (if \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>
+            then 
+              let result =
+                 (THE n. \<exists>stp k l. (steps0 (1, ([], <ns>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))
+              in Some result                     
+            else None)"
+
+text \<open>Some immediate consequences of the definition.\<close>
+
+(* This is for documentation and explanation: fun_of_tm_unfolded_into_TMC_yields_TMC_has_conditions *)
+
+lemma fun_of_tm_unfolded_into_TMC_yields_TMC_has_conditions:  
+   "fun_of_tm tm  \<equiv>
+      (\<lambda>ns. (if TMC_has_num_res tm ns
+             then 
+               let result = (THE n. TMC_yields_num_res tm ns n)
+               in Some result                     
+             else None)
+       )"          
+  unfolding TMC_yields_num_res_def TMC_has_num_res_def          
+  using fun_of_tm_def by presburger
+
+lemma fun_of_tm_is_None:
+  assumes "\<not>(\<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)"
+  shows "fun_of_tm tm ns = None"
+proof -
+  from assms show "fun_of_tm tm ns = None" by (auto simp add: fun_of_tm_def)
+qed
+
+lemma fun_of_tm_is_None_rev:
+  assumes "fun_of_tm tm ns = None"
+  shows "\<not>(\<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)"
+  using assms fun_of_tm_def by auto
+
+corollary fun_of_tm_is_None_iff: "fun_of_tm tm ns = None \<longleftrightarrow> \<not>(\<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)"
+  by (auto simp add: fun_of_tm_is_None fun_of_tm_is_None_rev)
+
+(* This is for documentation and explanation: fun_of_tm_is_None_iff' *)
+corollary fun_of_tm_is_None_iff': "fun_of_tm tm ns = None \<longleftrightarrow> \<not> TMC_has_num_res tm ns"
+  unfolding TMC_has_num_res_def
+  by (auto simp add: fun_of_tm_is_None fun_of_tm_is_None_rev )
+
+lemma fun_of_tm_ex_Some_n':
+  assumes "\<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+  shows "\<exists>n. fun_of_tm tm ns = Some n"
+  using assms fun_of_tm_def by auto
+
+lemma fun_of_tm_ex_Some_n'_rev:
+  assumes "\<exists>n. fun_of_tm tm ns = Some n"
+  shows "\<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+  using assms fun_of_tm_is_None by fastforce
+
+corollary fun_of_tm_ex_Some_n'_iff:
+ "(\<exists>n. fun_of_tm tm ns = Some n)
+  \<longleftrightarrow>
+  \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+  by (auto simp add: fun_of_tm_ex_Some_n' fun_of_tm_ex_Some_n'_rev)
+
+subsubsection \<open>Stronger results about uniqueness of results\<close>
+
+corollary Hoare_halt_on_numeral_list_yields_unique_list_result_iff:
+  "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr ml lr. tap = (Bk \<up> kr, <ml::nat list> @ Bk \<up> lr)\<rbrace>
+    \<longleftrightarrow>
+    (\<exists>!ml. \<exists>stp k l. steps0 (1,[], <nl::nat list>) p stp = (0, Bk \<up> k, <ml::nat list> @ Bk \<up> l))"
+proof
+  assume A: "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr ml lr. tap = (Bk \<up> kr,  <ml::nat list> @ Bk \<up> lr)\<rbrace>"
+  show "\<exists>!ml. \<exists>stp k l. steps0 (1, [], <nl::nat list>) p stp = (0, Bk \<up> k, <ml::nat list> @ Bk \<up> l)"
+  proof (rule ex_ex1I)
+    show "\<exists>ml stp k l. steps0 (1, [], <nl::nat list>) p stp = (0, Bk \<up> k, <ml::nat list> @ Bk \<up> l)"
+      using A
+      using Hoare_halt_iff by auto
+  next
+    show "\<And>ml y. \<lbrakk>\<exists>stp k l. steps0 (1, [], <nl::nat list>) p stp = (0, Bk \<up> k, <ml::nat list> @ Bk \<up> l);
+                   \<exists>stp k l. steps0 (1, [], <nl::nat list>) p stp = (0, Bk \<up> k, <y::nat list> @ Bk \<up> l)\<rbrakk> \<Longrightarrow> ml = y"
+      by (metis nat_le_linear prod.inject prod.inject stable_config_after_final_ge' unique_Bk_postfix_numeral_list)
+  qed
+next
+  assume "(\<exists>!ml. \<exists>stp k l. steps0 (1,[], <nl::nat list>) p stp = (0, Bk \<up> k, <ml::nat list> @ Bk \<up> l))"
+  then show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr ml lr. tap = (Bk \<up> kr, <ml::nat list> @ Bk \<up> lr)\<rbrace>"
+    using Hoare_halt_on_numeral_imp_list_result_rev by blast
+qed
+
+corollary Hoare_halt_on_numeral_yields_unique_result_iff:
+  "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)))\<rbrace>
+  \<longleftrightarrow>
+  (\<exists>!n. \<exists>stp k l. steps0 (1,[], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
+proof 
+  assume A: "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+  show "\<exists>!n. \<exists>stp k l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+  proof (rule ex_ex1I)
+    show "\<exists>n stp k l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+      using A 
+      using Hoare_halt_on_numeral_imp_result by blast
+  next
+    show "\<And>n y. \<lbrakk>\<exists>stp k l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l);
+                 \<exists>stp k l. steps0 (1, [], <ns>) p stp = (0, Bk \<up> k, <y> @ Bk \<up> l)\<rbrakk> \<Longrightarrow> n = y"
+      by (smt before_final is_final_eq le_less least_steps less_Suc_eq not_less_iff_gr_or_eq snd_conv unique_decomp_std_tap)
+  qed
+next
+  assume "\<exists>!n. \<exists>stp k l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+    using Hoare_halt_on_numeral_imp_result_rev by blast
+qed
+
+(* --- *)
+
+lemma fun_of_tm_is_Some_unique_value:
+  assumes "steps0 (1, ([], <ns>)) tm stp = (0, Bk \<up> k1, <n::nat> @ Bk \<up> l1)"
+  shows "fun_of_tm tm ns = Some n"
+proof -
+  from assms have F0: "TMC_has_num_res tm ns"   
+    using Hoare_halt_on_numeral_imp_result_rev TMC_has_num_res_def by blast
+  then have 
+  "fun_of_tm tm ns = (
+        let result =
+            (THE n. \<exists>stp k l. (steps0 (1, ([], <ns>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))
+        in Some result)"
+    by (simp add: F0 TMC_has_num_res_def fun_of_tm_def fun_of_tm_ex_Some_n' )
+  then have F1: "fun_of_tm tm ns =
+                 Some (THE n. \<exists>stp k l. (steps0 (1, ([], <ns>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
+    by auto
+  have "(THE n. \<exists>stp k l. (steps0 (1, ([], <ns>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)) = n"
+  proof (rule the1I2)
+    from F0
+    have F2: "(\<exists>!n.\<exists>stp k l. (steps0 (1, ([], <ns>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"      
+      using Hoare_halt_on_numeral_imp_result_rev Hoare_halt_on_numeral_yields_unique_result_iff assms by blast
+    then 
+    show "\<exists>!n. \<exists>stp k l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+      by auto
+  next
+    show "\<And>x. \<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <x> @ Bk \<up> l) \<Longrightarrow> x = n"
+      using Hoare_halt_on_numeral_imp_result_rev Hoare_halt_on_numeral_yields_unique_result_iff assms by blast
+  qed
+  then show ?thesis
+    using F1 by blast
+qed
+
+(* --- *)
+
+lemma fun_of_tm_ex_Some_n:
+  assumes "\<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+  shows "\<exists>stp k n l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l) \<and>
+                     fun_of_tm tm ns = Some (n::nat)"
+  using Hoare_halt_on_numeral_imp_result assms fun_of_tm_is_Some_unique_value by blast
+
+lemma fun_of_tm_ex_Some_n_rev:
+  assumes "\<exists>stp k n l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l) \<and>
+                       fun_of_tm tm ns = Some n"
+  shows "\<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+proof -
+  from assms have "\<exists>stp k n l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+    by blast
+
+  then show ?thesis    
+    using Hoare_haltE Hoare_haltI assms fun_of_tm_ex_Some_n'_rev steps.simps(1)
+    by auto
+qed
+
+corollary fun_of_tm_ex_Some_n_iff:
+  "(\<exists>stp k n l. (steps0 (1, ([], <ns>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l) \<and>
+                fun_of_tm tm ns = Some n)
+    \<longleftrightarrow>
+   \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+  using fun_of_tm_ex_Some_n fun_of_tm_ex_Some_n_rev
+  by blast
+
+(* --- *)
+
+lemma fun_of_tm_eq_Some_n_imp_same_numeral_result:
+  assumes "fun_of_tm tm ns = Some n"
+  shows "\<exists>stp k l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)" 
+  by (metis (no_types, lifting) assms assms fun_of_tm_def fun_of_tm_ex_Some_n_iff fun_of_tm_is_None option.inject option.simps(3))
+
+lemma numeral_result_n_imp_fun_of_tm_eq_n:
+  assumes "\<exists>stp k l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+  shows "fun_of_tm tm ns = Some n"
+  using  assms fun_of_tm_is_Some_unique_value by blast
+
+corollary numeral_result_n_iff_fun_of_tm_eq_n:
+  "fun_of_tm tm ns = Some n
+  \<longleftrightarrow>
+  (\<exists>stp k l. steps0 (1, [], <ns::nat list>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
+  using fun_of_tm_eq_Some_n_imp_same_numeral_result numeral_result_n_imp_fun_of_tm_eq_n
+  by blast
+
+(* This is for documentation and explanation: numeral_result_n_iff_fun_of_tm_eq_n' *)
+corollary numeral_result_n_iff_fun_of_tm_eq_n':
+  "fun_of_tm tm ns = Some n \<longleftrightarrow> TMC_yields_num_res tm ns n"
+  using fun_of_tm_eq_Some_n_imp_same_numeral_result numeral_result_n_imp_fun_of_tm_eq_n
+  unfolding TMC_yields_num_res_def
+  by blast
+
+subsubsection \<open>Definition of Turing computability Variant 2\<close>
+
+definition turing_computable_partial' :: "(nat list \<Rightarrow> nat option) \<Rightarrow> bool"
+  where "turing_computable_partial' f \<equiv> \<exists>tm. fun_of_tm tm = f"
+
+lemma turing_computable_partial'I:
+  "(\<And>ns. fun_of_tm tm ns = f ns) \<Longrightarrow> turing_computable_partial' f"
+  unfolding turing_computable_partial'_def
+proof -
+  assume "(\<And>ns. fun_of_tm tm ns = f ns)"
+  then have "fun_of_tm tm = f" by (rule ext)
+  then show "\<exists>tm. fun_of_tm tm = f" by auto
+qed
+
+
+subsubsection \<open>Definitional Variants 1 and 2 of Partial Turing Computability are equivalent\<close>
+
+text \<open>Now, we prove the equivalence of the two definitions of Partial Turing Computability.\<close>
+
+lemma turing_computable_partial'_imp_turing_computable_partial:
+  "turing_computable_partial' f \<longrightarrow> turing_computable_partial f"
+  unfolding turing_computable_partial'_def turing_computable_partial_def
+proof
+  assume "\<exists>tm. fun_of_tm tm = f"
+  then obtain tm where w_tm: "fun_of_tm tm = f" by blast
+  show "\<exists>tm. \<forall>ns n. (f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) \<and>
+                    (f ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)"
+  proof
+    show "\<forall>ns n. (f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) \<and>
+                (f ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)"
+    proof
+      fix ns
+      show "\<forall>n. (f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) \<and>
+                (f ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)"
+      proof
+        fix n::nat
+        show "(f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <n> @ Bk \<up> l))) \<and>
+              (f ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)"
+        proof
+          show "f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <n> @ Bk \<up> l))"
+          proof
+            assume "f ns = Some n"
+            with w_tm have A: "fun_of_tm tm ns = Some n" by auto
+            then have "\<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>" using fun_of_tm_ex_Some_n'_rev by auto
+
+            then have "\<exists>stp k m l. (steps0 (1, ([], <ns>)) tm stp) = (0, Bk \<up> k, <m::nat> @ Bk \<up> l) \<and>
+                                    fun_of_tm tm ns = Some m"
+              by (rule fun_of_tm_ex_Some_n)
+
+            with A show "\<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)" by auto
+          qed
+        next
+          show "f ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+          proof
+            assume "f ns = None"
+            with w_tm have A: "fun_of_tm tm ns = None" by auto
+            then show "\<not>(\<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)" by (rule fun_of_tm_is_None_rev)
+          qed
+        qed
+      qed
+    qed
+  qed
+qed
+
+lemma turing_computable_partial_imp_turing_computable_partial':
+  "turing_computable_partial f \<longrightarrow> turing_computable_partial' f"
+  unfolding turing_computable_partial_def
+proof
+  assume major: "\<exists>tm. \<forall>ns n.
+                      (f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) \<and>
+                      (f ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)"
+  show "turing_computable_partial' f"
+  proof -
+    from major obtain tm where w_tm:
+      "\<forall>ns n. (f ns = Some n \<longrightarrow> (\<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) \<and>
+                  (f ns = None \<longrightarrow> \<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>)" by blast
+    show "turing_computable_partial' f"
+    proof (rule turing_computable_partial'I)
+      show "\<And>ns. fun_of_tm tm ns = f ns"
+      proof -
+        fix ns
+        show "fun_of_tm tm ns = f ns"
+        proof (cases "f ns")
+          case None
+          then have "f ns = None" .
+          with w_tm have "\<not> \<lbrace> \<lambda>tap. tap = ([], <ns::nat list>) \<rbrace> tm \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>" by auto
+          then have "fun_of_tm tm ns = None" by (rule fun_of_tm_is_None)
+          with \<open>f ns = None\<close> show ?thesis by auto
+        next
+          case (Some m)
+          then have "f ns = Some m" .
+          with w_tm have B: "(\<exists>stp k l. steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <m::nat> @ Bk \<up> l))" by auto
+          then obtain stp k l where w_stp_k_l: "steps0 (1, [], <ns>) tm stp = (0, Bk \<up> k, <m::nat> @ Bk \<up> l)" by blast
+          then have "\<exists>stp k n l. (steps0 (1, ([], <ns>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)" by blast
+          from this and w_stp_k_l have "fun_of_tm tm ns = Some m"
+            by (simp add: w_stp_k_l fun_of_tm_is_Some_unique_value)
+          with \<open>f ns = Some m\<close> show ?thesis by auto
+        qed
+      qed
+    qed
+  qed
+qed
+
+corollary turing_computable_partial'_turing_computable_partial_iff:
+  "turing_computable_partial' f \<longleftrightarrow> turing_computable_partial f"
+  by (auto simp add: turing_computable_partial'_imp_turing_computable_partial
+      turing_computable_partial_imp_turing_computable_partial')
+
+text \<open>As a now trivial consequence we obtain:\<close>
+
+corollary "turing_computable_partial f \<equiv> \<exists>tm. fun_of_tm tm = f"
+  using turing_computable_partial'_turing_computable_partial_iff turing_computable_partial'_def
+  by auto
+
+
+subsection \<open>Definition of Total Turing Computability\<close>
+
+definition turing_computable_total :: "(nat list \<Rightarrow> nat option) \<Rightarrow> bool"
+  where "turing_computable_total f \<equiv> (\<exists>tm. \<forall>ns. \<exists>n.
+          f ns = Some n \<and>
+          (\<exists>stp k l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)) )"
+
+(* This is for documentation and explanation: turing_computable_total_unfolded_into_TMC_yields_condition *)
+
+lemma turing_computable_total_unfolded_into_TMC_yields_condition:
+  "turing_computable_total f \<equiv> (\<exists>tm. \<forall>ns. \<exists>n. f ns = Some n \<and> TMC_yields_num_res tm ns n )"
+  unfolding TMC_yields_num_res_def
+  by (simp add: turing_computable_total_def)
+
+(* Major consequences of the definition *)
+
+lemma turing_computable_total_imp_turing_computable_partial:
+  "turing_computable_total f \<Longrightarrow> turing_computable_partial f"
+  unfolding turing_computable_total_def turing_computable_partial_def
+  by (metis option.inject option.simps(3))
+
+corollary turing_decidable_imp_turing_computable_total_chi_fun:
+  "turing_decidable A \<Longrightarrow> turing_computable_total (chi_fun A)"
+  unfolding turing_computable_total_unfolded_into_TMC_yields_condition
+proof -
+  assume "turing_decidable A"
+  then have "\<exists>D. (\<forall>nl. 
+         (nl \<in> A \<longrightarrow> TMC_yields_num_res D nl (1::nat) )
+       \<and> (nl \<notin> A \<longrightarrow> TMC_yields_num_res D nl (0::nat) ) )" 
+    unfolding turing_decidable_unfolded_into_TMC_yields_conditions
+    by auto
+  then obtain D where
+    w_D: "\<forall>nl. (nl \<in> A \<longrightarrow> TMC_yields_num_res D nl (1::nat) ) \<and>
+               (nl \<notin> A \<longrightarrow> TMC_yields_num_res D nl (0::nat) )"
+    by blast
+  then have "\<forall>ns. \<exists>n. chi_fun A ns = Some n \<and> TMC_yields_num_res D ns n"
+    by (simp add: w_D chi_fun_0_E chi_fun_def)
+  then show "\<exists>tm. \<forall>ns. \<exists>n. chi_fun A ns = Some n \<and> TMC_yields_num_res tm ns n"
+    by auto
+qed
+
+(* --- alternative definition turing_computable_total' --- *)
+
+definition turing_computable_total' :: "(nat list \<Rightarrow> nat option) \<Rightarrow> bool"
+  where "turing_computable_total' f \<equiv> (\<exists>tm. \<forall>ns. \<exists>n. f ns = Some n \<and> fun_of_tm tm = f)"
+
+theorem turing_computable_total'_eq_turing_computable_total:
+  "turing_computable_total' f = turing_computable_total f"
+proof
+  show "turing_computable_total' f \<Longrightarrow> turing_computable_total f"
+    unfolding turing_computable_total_def unfolding turing_computable_total'_def
+    using fun_of_tm_eq_Some_n_imp_same_numeral_result by blast
+next
+  show "turing_computable_total f \<Longrightarrow> turing_computable_total' f"
+    unfolding turing_computable_total_def unfolding turing_computable_total'_def
+    by (metis numeral_result_n_imp_fun_of_tm_eq_n tape_of_list_def turing_computable_partial'I turing_computable_partial'_def)
+qed
+
+(* --- alternative definition turing_computable_total'' --- *)
+
+definition turing_computable_total'' :: "(nat list \<Rightarrow> nat option) \<Rightarrow> bool"
+  where "turing_computable_total'' f \<equiv> (\<exists>tm. fun_of_tm tm = f \<and> (\<forall>ns. \<exists>n. f ns = Some n))"
+
+theorem turing_computable_total''_eq_turing_computable_total:
+  "turing_computable_total'' f = turing_computable_total f"
+proof
+  show "turing_computable_total'' f \<Longrightarrow> turing_computable_total f"
+    unfolding turing_computable_total_def unfolding turing_computable_total''_def
+    by (meson fun_of_tm_eq_Some_n_imp_same_numeral_result)
+next
+  show "turing_computable_total f \<Longrightarrow> turing_computable_total'' f"
+    unfolding turing_computable_total_def unfolding turing_computable_total''_def
+    by (metis numeral_result_n_imp_fun_of_tm_eq_n tape_of_list_def turing_computable_partial'I turing_computable_partial'_def)
+qed
+
+(* --- Definition for turing_computable_total_on --- *)
+
+definition turing_computable_total_on :: "(nat list \<Rightarrow> nat option) \<Rightarrow> (nat list) set \<Rightarrow> bool"
+  where "turing_computable_total_on f A \<equiv> (\<exists>tm. \<forall>ns.
+          ns \<in> A \<longrightarrow>
+           (\<exists>n. f ns = Some n \<and>
+                (\<exists>stp k l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))) )"
+
+(* This is for documentation and explanation: turing_computable_total_on_unfolded_into_TMC_yields_condition *)
+
+lemma turing_computable_total_on_unfolded_into_TMC_yields_condition:
+  "turing_computable_total_on f A \<equiv> (\<exists>tm. \<forall>ns. ns \<in> A \<longrightarrow> (\<exists>n. f ns = Some n \<and> TMC_yields_num_res tm ns n ))"
+  unfolding TMC_yields_num_res_def
+  by (simp add: turing_computable_total_on_def)
+
+(* Major consequences of the definition *)
+
+lemma turing_computable_total_on_UNIV_imp_turing_computable_total:
+  "turing_computable_total_on f UNIV \<Longrightarrow> turing_computable_total f"
+  by (simp add: turing_computable_total_on_unfolded_into_TMC_yields_condition
+                turing_computable_total_unfolded_into_TMC_yields_condition)
+
+
+end
diff --git a/thys/Universal_Turing_Machine/TuringComputable_aux.thy b/thys/Universal_Turing_Machine/TuringComputable_aux.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/TuringComputable_aux.thy
@@ -0,0 +1,158 @@
+(* Title: thys/TuringComputable_aux.thy
+   Author:  Franz Regensburger (FABR) 04/2022
+ *)
+
+theory TuringComputable_aux
+  imports
+    TuringComputable
+
+begin
+
+(* Auxiliary lemmas that are not used at the moment *)
+
+lemma TMC_has_num_res_impl_result:
+  assumes "TMC_has_num_res p ns"
+  shows "\<exists>stp k n l. (steps0 (1, ([], <ns::nat list>)) p stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+  using Hoare_halt_on_numeral_imp_result
+  using TMC_has_num_res_def assms
+  by blast
+
+lemma TMC_has_num_res_impl_result_rev:
+  assumes "\<exists>stp k n l. (steps0 (1, ([], <ns>)) p stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+  shows "TMC_has_num_res p ns"
+  unfolding TMC_has_num_res_def
+  using Hoare_halt_on_numeral_imp_result_rev
+  using assms tape_of_list_def by auto
+
+corollary TMC_has_num_res_impl_result_iff:
+  "(TMC_has_num_res p ns)
+   \<longleftrightarrow>
+   (\<exists>stp k n l. (steps0 (1, ([], <ns>)) p stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
+  using TMC_has_num_res_impl_result TMC_has_num_res_impl_result_rev by blast
+
+
+lemma TMC_has_num_res_impl_unique_result:
+  assumes "TMC_has_num_res p ns"
+  shows "\<exists>!n. \<exists>stp k l. steps0 (1,[], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+proof (rule ex_ex1I)
+  show "\<exists>n stp k l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+    using assms TMC_has_num_res_impl_result by blast
+next
+  show "\<And>n y. \<lbrakk>\<exists>stp k l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l);
+               \<exists>stp k l. steps0 (1, [], <ns>) p stp = (0, Bk \<up> k, <y> @ Bk \<up> l)\<rbrakk> \<Longrightarrow> n = y"
+    by (smt before_final is_final_eq le_less least_steps less_Suc_eq not_less_iff_gr_or_eq snd_conv unique_decomp_std_tap)
+qed
+
+lemma TMC_has_num_res_impl_unique_result_rev:
+  assumes  "\<exists>!n. \<exists>stp k l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+  shows  "TMC_has_num_res p ns"
+proof -
+  from assms have "\<exists>stp n k l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+    by blast
+  then show ?thesis using TMC_has_num_res_impl_result_rev
+    by blast
+qed
+
+corollary TMC_has_num_res_impl_unique_result_iff:
+  "TMC_has_num_res p ns
+   \<longleftrightarrow>
+   (\<exists>!n.\<exists>stp k l. (steps0 (1, ([], <ns>)) p stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
+  using TMC_has_num_res_impl_unique_result TMC_has_num_res_impl_unique_result_rev
+  by blast
+
+subsection \<open>Hoare halt with single numeral result: least number of steps and uniqueness\<close>
+
+lemma TMC_has_num_res_impl_result_least:
+  assumes "TMC_has_num_res p ns"
+    and "st = (LEAST m. is_final (steps0 (1, [], <ns>) p m))"
+  shows "\<exists> k n l. (steps0 (1, ([], <ns>)) p st) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+proof (rule exE)
+  from assms(1) show "\<exists>stp k n l. (steps0 (1, ([], <ns>)) p stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+    by (rule TMC_has_num_res_impl_result)
+next
+  fix stp
+  assume "\<exists>k n l. steps0 (1, [], <ns>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+  then obtain k n l where w: "steps0 (1, [], <ns>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+    by blast
+
+  then have "\<exists> n'. (\<forall>n'' < n'. \<not> is_final (steps0 (1, ([], <ns>)) p n'')) \<and> 
+               (\<forall>n'' \<ge> n'. is_final (steps0 (1, ([], <ns>)) p n''))"
+    by (rule least_steps)
+
+  then obtain ln where w_ln:" (\<forall>n'' < ln. \<not> is_final (steps0 (1, ([], <ns>)) p n'')) \<and> 
+                                (\<forall>n'' \<ge> ln. is_final (steps0 (1, ([], <ns>)) p n''))" by blast
+  from w_ln have F_ln: "is_final (steps0 (1, [], <ns>) p ln)" by auto
+
+  have F_ln_eq: "(LEAST m. is_final (steps0 (1, [], <ns>) p m)) = ln"
+  proof (rule Least_equality)
+    from w_ln show "is_final (steps0 (1, [], <ns>) p ln)" by auto
+  next
+    fix y
+    assume "is_final (steps0 (1, [], <ns>) p y)"
+    show "ln \<le> y" 
+    proof (rule ccontr)
+      assume "\<not> ln \<le> y"
+      then have "y < ln" by auto
+
+      with w_ln have "\<not> is_final (steps0 (1, ([], <ns>)) p y)" by auto
+      with \<open>is_final (steps0 (1, [], <ns>) p y)\<close> show False by blast
+    qed
+  qed
+  with assms(2) have "st = ln" by auto
+  with F_ln have F_st: "is_final (steps0 (1, [], <ns>) p st)" by auto
+
+  from w have F_stp: "is_final (steps0 (1, [], <ns>) p stp)" by auto
+
+  have "steps0 (1, [], <ns>) p st = (0, Bk \<up> k, <n> @ Bk \<up> l)"
+  proof (cases "stp < st")
+    case True
+    then have "stp < st" .
+    with F_stp and assms(2) have False using not_less_Least by auto
+    then show ?thesis by auto
+  next
+    case False
+    then have "st \<le> stp" by auto
+
+    then show ?thesis
+    proof (cases "steps0 (1, [], <ns>) p st")
+      case (fields a b c)
+      then have "steps0 (1, [], <ns>) p st = (a, b, c)" .
+      moreover with F_st have S0: "a = 0" using is_final_eq[THEN iffD1] by auto
+      ultimately have "steps0 (1, [], <ns>) p st = (0, b, c)" by auto
+      from this and \<open>st \<le> stp\<close> have "steps0 (1, [], <ns>) p stp = (0, b, c)"
+        by (rule stable_config_after_final_ge')
+      with w have "b = Bk \<up> k \<and> c= <n> @ Bk \<up> l" by auto
+      with S0 and \<open>steps0 (1, [], <ns>) p st = (a, b, c)\<close> show ?thesis by auto
+    qed
+  qed
+  then show "\<exists>k n l. steps0 (1, [], <ns>) p st = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)" by auto
+qed
+
+
+lemma TMC_has_num_res_impl_result_is_unique:
+  assumes "TMC_has_num_res p ns"
+    and "st = (LEAST m. is_final (steps0 (1,[], <ns>) p m))"
+  shows "\<exists>!n. \<exists>k l. steps0 (1, [], <ns>) p st = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+proof (rule ex_ex1I)
+  show "\<exists>n k l. steps0 (1, [], <ns>) p st = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+  proof -
+    from assms have "\<exists> k n l. (steps0 (1, ([], <ns>)) p st) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+      by (rule TMC_has_num_res_impl_result_least)
+    then obtain k n l where w_k_n_l: "(steps0 (1, ([], <ns>)) p st) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+      by blast
+    then show "\<exists>n k l. steps0 (1, [], <ns>) p st = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)" by auto
+  qed
+next
+  fix n::nat fix y::nat
+  assume A1: "\<exists>k l. steps0 (1, [], <ns>) p st = (0, Bk \<up> k, <n> @ Bk \<up> l)"
+     and A2: "\<exists>k l. steps0 (1, [], <ns>) p st = (0, Bk \<up> k, <y> @ Bk \<up> l)"
+  from A1 obtain k1 l1 where w_k1_l1: "steps0 (1, [], <ns>) p st = (0, Bk \<up> k1, <n> @ Bk \<up> l1)" by blast
+  from A2 obtain k2 l2 where w_k2_l2: "steps0 (1, [], <ns>) p st = (0, Bk \<up> k2, <y> @ Bk \<up> l2)" by blast
+
+  from w_k1_l1 and w_k2_l2 have "(0, Bk \<up> k1, <n> @ Bk \<up> l1) = (0, Bk \<up> k2, <y> @ Bk \<up> l2)" by auto
+  then have "(Bk \<up> k1, <n> @ Bk \<up> l1) = (Bk \<up> k2, <y> @ Bk \<up> l2)" by auto
+  then have "k1=k2 \<and> n=y \<and> l1=l2" by (rule unique_decomp_std_tap)
+  then show "n = y" by auto
+qed
+
+end
diff --git a/thys/Universal_Turing_Machine/TuringDecidable.thy b/thys/Universal_Turing_Machine/TuringDecidable.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/TuringDecidable.thy
@@ -0,0 +1,148 @@
+(* Title: thys/TuringDecidable.thy
+   Author: Franz Regensburger (FABR) 02/2022
+ *)
+
+section \<open>Turing Decidability\<close>
+
+theory TuringDecidable
+  imports
+    OneStrokeTM
+    Turing_HaltingConditions
+begin
+
+(* -------------------------------------------------------------------------- *)
+
+(*
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+*)
+
+subsection \<open>Turing Decidable Sets and Relations of natural numbers\<close>
+
+text \<open>We use lists of natural numbers in order to model tuples of
+ arity @{term k} of natural numbers,
+ where @{term "0 \<le> (k::nat)"}. 
+\<close>
+
+(*
+ For a relation R of @\<lbrace>term k\<rbrace>-ary tuples use a set nls of nat lists,
+ where each of its elements nl (which is a nat list) has length k.
+    
+     (n1, ... , nk) \<in> R \<longleftrightarrow> [<[n1, ... , nk]>] \<in> nls .
+  
+ For a plain set of natural numbers S simply use a set of singleton nat lists nls
+ where
+
+      n \<in> S \<longleftrightarrow> [<n>] \<in> nls.
+*)
+
+text \<open>Now, we define the notion of {\em Turing Decidable Sets and Relations}.
+In our definition, we directly relate decidability of sets and relations to Turing machines
+and do not adhere to the formal concept of a characteristic function.
+
+However, the notion of a characteristic function is introduced in the theory about Turing
+computable functions.
+\<close>
+
+definition turing_decidable :: "(nat list) set \<Rightarrow> bool"
+  where
+    "turing_decidable nls \<equiv> (\<exists>D. (\<forall>nl. 
+         (nl \<in> nls \<longrightarrow> \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk\<up> l))\<rbrace>)
+       \<and> (nl \<notin> nls \<longrightarrow> \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk\<up> l))\<rbrace>)
+     ))"
+
+(* This is for documentation and explanation: turing_decidable_unfolded_into_TMC_yields_conditions *)
+
+lemma turing_decidable_unfolded_into_TMC_yields_conditions:
+"turing_decidable nls \<equiv> (\<exists>D. (\<forall>nl. 
+         (nl \<in> nls \<longrightarrow> TMC_yields_num_res D nl (1::nat) )
+       \<and> (nl \<notin> nls \<longrightarrow> TMC_yields_num_res D nl (0::nat) )
+     ))"
+  unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
+  by (simp add: turing_decidable_def)
+
+(* --------------------------------------------------------------------------------------------- *)
+
+subsection \<open>Examples for decidable sets of natural numbers\<close>
+
+text \<open>Using the machine OneStrokeTM as a decider
+we are able to proof the decidability of the empty set.
+Moreover, in the theory about Halting Problems, we will show that there are undecidable sets as well.
+Thus, the notion of Turing Decidability is not a trivial concept.
+\<close>
+
+lemma turing_decidable_empty_set_iff:
+  "turing_decidable {} = (\<exists>D. \<forall>(nl:: nat list).
+        \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> D \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up>l))\<rbrace>)"
+  unfolding turing_decidable_def
+  by (simp add: tape_of_nat_def)
+
+theorem turing_decidable_empty_set: "turing_decidable {}"
+  by (rule turing_decidable_empty_set_iff[THEN iffD2])
+     (blast intro: tm_onestroke_total_correctness)
+
+(* For demo in classes *)
+(*
+lemma tm_onestroke_total_correctness':
+  "\<forall>nl. TMC_yields_num_res tm_onestroke nl (0::nat)"
+  unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
+  using tm_onestroke_total_correctness by (simp add: tape_of_nat_def)
+
+theorem turing_decidable_empty_set':
+  "(\<forall>nl. 
+             (nl \<in> {} \<longrightarrow> TMC_yields_num_res tm_onestroke nl (1::nat) )
+           \<and> (nl \<notin> {} \<longrightarrow> TMC_yields_num_res tm_onestroke nl (0::nat) )
+         )"
+  unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
+proof -
+  show "\<forall>nl. (nl \<in> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>) \<and>
+               (nl \<notin> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>)"
+  proof
+    fix nl:: "nat list"
+    show "(nl \<in> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>) \<and>
+          (nl \<notin> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>)"
+    proof
+      show "nl \<in> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>"
+      proof
+        assume "nl \<in> {}" (* nothing can ever be an element of the empty set {}, thus contradiction *)
+        then have False by auto
+        then show "\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>" by auto
+      qed
+    next
+      show "nl \<notin> {} \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>"
+      proof
+        assume "nl \<notin> {}"
+        have "\<forall>nl.\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>"
+          using TMC_yields_num_res_unfolded_into_Hoare_halt tm_onestroke_total_correctness' by blast
+        then show "\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_onestroke \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>" by auto
+      qed
+    qed
+  qed
+qed
+
+corollary "turing_decidable {}"
+  unfolding turing_decidable_unfolded_into_TMC_yields_conditions
+  using turing_decidable_empty_set' by auto
+*)
+
+(* ---------------------------------------------------- *)
+(* ENHANCE: add a means for turing_semi_decidable       *)
+(* ---------------------------------------------------- *)
+
+(* ---------------------------------------------------- *)
+(* ENHANCE: add a means for dove-tailing                *)
+(* ---------------------------------------------------- *)
+
+(* ---------------------------------------------------- *)
+(* ENHANCE: prove advanced theorems about decidability  *)
+(* ---------------------------------------------------- *)
+(* - Step counter theorem ;aka (s,m,n) theorem          *)
+(* - Rice's theorem for Turing Machines                 *)
+(* ---------------------------------------------------- *)
+
+end
diff --git a/thys/Universal_Turing_Machine/TuringReducible.thy b/thys/Universal_Turing_Machine/TuringReducible.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/TuringReducible.thy
@@ -0,0 +1,182 @@
+(* Title: thys/TuringReducible.thy
+   Author: Franz Regensburger (FABR) 02/2022
+ *)
+
+section \<open>Turing Reducibility\<close>
+
+theory TuringReducible
+  imports
+    TuringDecidable
+    StrongCopyTM
+begin
+
+subsection \<open>Definition of Turing Reducibility of Sets and Relations of Natural Numbers\<close>
+
+(* See the book
+   Computability, Complexity, and Languages,
+   Davis, Sigal, Weyuker,
+   Academic Press, 1983,
+   ISBN 0-12-206382-1
+
+   Chapter 4: Diagonalization and Reducibility, pp 91 
+*)
+
+text \<open>Let @{term A} and @{term B} be two sets of lists of natural numbers.
+
+The set @{term A} is called many-one reducible to set @{term B},
+if there is a Turing machine @{term tm} such that
+  for all @{term "a"} we have:
+
+\begin{enumerate}
+  \item the Turing machine always computes a list @{term "b"} of natural numbers
+      from the list @{term "b"} of natural numbers
+
+  \item @{term "a \<in> A"} if and only if
+      the value @{term "b"} computed by @{term tm} from @{term "a"}
+      is an element of set @{term "B"}.
+\end{enumerate}
+
+We generalized our definition to lists, which eliminates the need to encode lists of natural numbers into a single natural number.
+Compare this to the theory of recursive functions, where all values computed must be a single natural number.
+
+Note however, that our notion of reducibility is not stronger than the one used in recursion theory.
+Every finite list of natural numbers can be encoded into a single natural number.
+Our definition is just more convenient for Turing machines, which are capable of producing lists of values.
+\<close>
+
+definition turing_reducible :: "(nat list) set \<Rightarrow> (nat list) set  \<Rightarrow> bool"
+  where
+
+    "turing_reducible A B \<equiv>
+         (\<exists>tm. \<forall>nl::nat list. \<exists>ml::nat list.
+              \<lbrace>(\<lambda>tap. tap = ([], <nl>))\<rbrace> tm \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <ml> @ Bk\<up> l))\<rbrace> \<and>
+              (nl \<in> A \<longleftrightarrow> ml \<in> B)
+         )"
+
+(* This is for documentation and explanation: turing_reducible_unfolded_into_TMC_yields_condition *)
+
+lemma turing_reducible_unfolded_into_TMC_yields_condition:
+    "turing_reducible A B \<equiv>
+         (\<exists>tm. \<forall>nl::nat list. \<exists>ml::nat list.
+              TMC_yields_num_list_res tm nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B)
+         )"
+  unfolding TMC_yields_num_list_res_unfolded_into_Hoare_halt
+  by (simp add: turing_reducible_def)
+
+subsection \<open>Theorems about Turing Reducibility of Sets and Relations of Natural Numbers\<close>
+
+(* A convenience lemma for the main proof *)
+
+lemma turing_reducible_A_B_imp_composable_reducer_ex: "turing_reducible A B
+       \<Longrightarrow>
+       \<exists>Red. composable_tm0 Red \<and>
+             (\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B))"
+proof -
+  assume "turing_reducible A B"
+  then have "\<exists>tm. \<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res tm nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B)"
+    using turing_reducible_unfolded_into_TMC_yields_condition by auto
+
+  then obtain Red' where
+    w_RedTM': "\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res Red' nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B)"
+    by blast
+
+  (* create a composable version Red from the potentially non-composable machine Red' *)
+
+  then have "composable_tm0 (mk_composable0 Red') \<and>
+             (\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res (mk_composable0 Red') nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B))"
+    using w_RedTM' Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list_rev Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list composable_tm0_mk_composable0
+    using TMC_yields_num_list_res_unfolded_into_Hoare_halt by blast
+
+  then show "\<exists>Red. composable_tm0 Red \<and>
+             (\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B))"
+    by (rule exI)
+qed
+
+(* The main theorem about problem reduction *)
+
+theorem turing_reducible_AB_and_decB_imp_decA:
+  "\<lbrakk> turing_reducible A B; turing_decidable B \<rbrakk> \<Longrightarrow> turing_decidable A"
+proof -
+  assume "turing_reducible A B"
+    and  "turing_decidable B"
+
+  (* first, obtain a composable reducer machine Red *)
+
+  from \<open>turing_reducible A B\<close>
+  have "\<exists>Red. composable_tm0 Red \<and>
+               (\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B))"
+    by (rule turing_reducible_A_B_imp_composable_reducer_ex)
+
+  then obtain Red where
+    w_RedTM: "composable_tm0 Red \<and>
+               (\<forall>nl::nat list. \<exists>ml::nat list. TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B))"
+    by blast
+
+  (* second, obtain a decider DB for problem B *)
+
+  from \<open>turing_decidable B\<close>
+  have "(\<exists>D. (\<forall>nl::nat list. 
+           (nl \<in> B \<longrightarrow> TMC_yields_num_res D nl (1::nat))
+         \<and> (nl \<notin> B \<longrightarrow> TMC_yields_num_res D nl (0::nat))
+       ))"
+    unfolding turing_decidable_unfolded_into_TMC_yields_conditions by auto
+
+  then obtain DB where
+    w_DB: "(\<forall>nl. 
+           (nl \<in> B \<longrightarrow> TMC_yields_num_res DB nl (1::nat))
+         \<and> (nl \<notin> B \<longrightarrow> TMC_yields_num_res DB nl (0::nat))
+       )" by blast
+
+  (* third, define the composed machine DA = Red |+| DB that is able to decide A *)
+
+  define DA where "DA = Red |+| DB"
+
+  (* now, go for the main part of the proof *) 
+  show "turing_decidable A"
+    unfolding turing_decidable_unfolded_into_TMC_yields_conditions
+  proof -
+    have "\<forall>nl. (nl \<in> A \<longrightarrow> TMC_yields_num_res DA nl (1::nat)) \<and>
+                 (nl \<notin> A \<longrightarrow> TMC_yields_num_res DA nl (0::nat))"
+    proof (rule allI)
+      fix nl
+      show "(nl \<in> A \<longrightarrow> TMC_yields_num_res DA nl (1::nat)) \<and>
+              (nl \<notin> A \<longrightarrow> TMC_yields_num_res DA nl (0::nat))"
+      proof
+        show "nl \<in> A \<longrightarrow> TMC_yields_num_res DA nl (1::nat)"
+        proof
+          assume "nl \<in> A" 
+          from \<open>nl \<in> A\<close> and w_RedTM
+          obtain ml where w_ml: "composable_tm0 Red \<and> TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B)"
+            by blast  
+          with \<open>nl \<in> A\<close> w_DB have "TMC_yields_num_res (Red |+| DB) nl  (1::nat)"
+            using TMC_yields_num_res_Hoare_plus_halt by auto
+          then show "TMC_yields_num_res DA nl 1"
+            using DA_def by auto
+        qed
+      next
+        show "nl \<notin> A \<longrightarrow>  TMC_yields_num_res DA nl 0"
+        proof
+          assume "nl \<notin> A"
+          from \<open>nl \<notin> A\<close> and w_RedTM
+          obtain ml where w_ml: "composable_tm0 Red \<and> TMC_yields_num_list_res Red nl ml \<and> (nl \<in> A \<longleftrightarrow> ml \<in> B)"
+            by blast
+          with \<open>nl \<notin> A\<close> w_DB have "TMC_yields_num_res (Red |+| DB) nl  (0::nat)"
+            using TMC_yields_num_res_Hoare_plus_halt by auto
+          then show "TMC_yields_num_res DA nl 0"
+            using DA_def by auto
+        qed
+      qed
+    qed
+    then show "\<exists>D. \<forall>nl. (nl \<in> A \<longrightarrow> TMC_yields_num_res D nl 1) \<and> (nl \<notin> A \<longrightarrow> TMC_yields_num_res D nl 0)"
+      by auto
+  qed
+qed
+
+(* The corollary about obtaining undecidability from reducibility *)
+
+corollary turing_reducible_AB_and_non_decA_imp_non_decB:
+  "\<lbrakk>turing_reducible A B; \<not> turing_decidable A \<rbrakk> \<Longrightarrow> \<not>turing_decidable B"
+  using turing_reducible_AB_and_decB_imp_decA 
+  by blast
+
+end
diff --git a/thys/Universal_Turing_Machine/TuringUnComputable_H2.thy b/thys/Universal_Turing_Machine/TuringUnComputable_H2.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/TuringUnComputable_H2.thy
@@ -0,0 +1,376 @@
+(* Title: thys/TuringUnComputable_H2.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+ 
+   Further contributions and enhancements by Franz Regensburger (FABR) 02/2022 :
+
+   - Splitted and reordered theory file Uncomputable.thy into
+     several smaller theory files.
+
+   - Completed the proof of the undecidability of the Halting problem H2.
+
+     The original version by Jian Xu, Xingyuan Zhang, and Christian Urban
+     only formalizes a weaker version of the undecidability result.
+     Their formalization just shows that the set H2 is not
+     decidable by any composable (aka well-formed) Turing machine.
+
+     However, the set H2 might be decidable by some none composable TM.
+     We close this gap in the following and show that no Turing machine,
+     may it be composable or not, is able to decide the set H2.
+
+   - Corrected the presentation of the theory.
+
+     The entire hierarchy of theories formalized in HOL is based on the
+     principle of Conservative Theory Extension.
+
+     One major law of this principle is that for every locale there must be at least
+     one instance proof in order to ensure that the locale is inhabited (has models).
+
+     The original version of the theory TuringUnComputable_H2 intentionally used
+     locale axioms that have no model.
+     There is not a single valid reason to justify this miss-use of the locale concept!
+
+     In our version, we present the theory in accordance with the principle of
+     Conservative Theory Extension.
+ *)
+
+subsection \<open>Existence of an uncomputable Function\<close>
+
+theory TuringUnComputable_H2
+  imports
+     CopyTM
+     DitherTM
+
+begin
+
+(*
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+*)
+
+subsubsection \<open>Undecidability of the General Halting Problem H, Variant 2, revised version\<close>
+
+text \<open>
+  This variant of the decision problem H is discussed in the book
+  Computability and Logic by Boolos, Burgess and Jeffrey~\cite{Boolos07} in chapter 4.
+
+  The proof makes use of the TMs @{term "tm_copy"} and @{term "tm_dither"}.
+  In \cite{Boolos07}, the machines are called {\em copy} and {\em dither}.
+\<close>
+
+fun dummy_code :: "tprog0 \<Rightarrow> nat"  (* the witness for the instantiation of class hph2 *)
+  where "dummy_code tp = 0"
+
+locale hph2 = 
+
+  (* Interestingly, the detailed definition of the coding function @{text "code"}
+     for Turing machines does not affect the final result.
+
+     In the proof there is no need to appeal on properties of the coding function
+     like e.g. injectivity! *)
+
+fixes code :: "instr list \<Rightarrow> nat" 
+
+(* FABR Note about the old formalization:
+
+    * The first axiom states that the Turing machine H is well-formed (composable).
+    * However, this manifests a principle weakness of the old modelling of the locale!
+    *
+    * Due to this locale axiom, we only prove that there exists no composable TM H
+    * that is able to decide the Halting problem 'TMC_has_num_res M ns'
+    *
+    * See theories ComposableTMs.thy and HaltingProblems_K_H.thy for a fix by FABR.
+
+    These are the old locale axioms, which we do not use any longer.
+
+    assumes h_composable[intro]: "composable_tm0 H"
+
+    and h_case:
+    "\<And> M ns.  TMC_has_num_res M ns
+        \<Longrightarrow> \<lbrace>(\<lambda>tap. tap = ([Bk], <(code M, ns)>))\<rbrace> H \<lbrace>(\<lambda>tap. \<exists>k. tap = (Bk \<up> k, <0::nat>))\<rbrace>"
+
+    and nh_case:
+    "\<And> M ns. \<not>  TMC_has_num_res M ns 
+     \<Longrightarrow> \<lbrace>(\<lambda>tap. tap = ([Bk], <(code M, ns)>))\<rbrace> H \<lbrace>(\<lambda>tap. \<exists>k. tap = (Bk \<up> k, <1::nat>))\<rbrace>"
+
+    An additional weakness of these locale axioms are the post-conditions used:
+
+    \<lbrace>(\<lambda>tap. \<exists>k. tap = (Bk \<up> k, <0::nat>))\<rbrace>"
+    \<lbrace>(\<lambda>tap. \<exists>k. tap = (Bk \<up> k, <1::nat>))\<rbrace>"
+
+    These need to be relaxed into: 
+
+    \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @Bk\<up>l)\<rbrace>)
+    \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @Bk\<up>l)\<rbrace>)
+
+    Otherwise, there might simply be no TM that is able to compute just the output
+    <0::nat> or <1:nat> without any further trailing blanks.
+
+*)
+
+begin
+
+text \<open>The function @{term dummy_code} is a witness that the locale hph2 is inhabited.
+
+Note: there just has to be some function with the correct type since we did not
+specify any axioms for the locale. The behaviour of the instance of the locale
+function code does not matter at all.
+
+This detail differs from the locale hpk, where a locale axiom specifies that the
+coding function has to be injective.
+
+Obviously, the entire logical argument of the undecidability proof H2
+relies on the combination of the machines @{term "tm_copy"} and @{term "tm_dither"}.
+\<close>
+ 
+interpretation dummy_code: hph2 "dummy_code :: tprog0 \<Rightarrow> nat"
+proof unfold_locales
+qed
+
+text \<open>The next lemma plays a crucial role in the proof by contradiction.
+Due to our general results about trailing blanks on the left tape,
+we are able to compensate for the additional blank, which is a mandatory
+by-product of the @{term "tm_copy"}.
+\<close>
+
+lemma add_single_BK_to_left_tape:
+  "\<lbrace>\<lambda>tap. tap = ([]  , <(m::nat, m)> ) \<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, r' @Bk\<up>l )\<rbrace>
+  \<Longrightarrow>
+   \<lbrace>\<lambda>tap. tap = ([Bk], <(m     , m)> ) \<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, r' @Bk\<up>l )\<rbrace>"
+proof -
+  assume    "\<lbrace>\<lambda>tap. tap = ([], <(m::nat, m)> ) \<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, r' @Bk\<up>l)\<rbrace>"
+  then have  "\<forall>z.\<lbrace>\<lambda>tap. tap = (Bk \<up> z, <(m::nat, m)> ) \<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, r' @Bk\<up>l)\<rbrace>"
+    using Hoare_halt_add_Bks_left_tape_L1 Hoare_halt_add_Bks_left_tape  by blast
+  then have  "\<lbrace>\<lambda>tap. tap = (Bk \<up> 1, <(m::nat, m)> ) \<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, r' @Bk\<up>l)\<rbrace>"
+    by blast
+  then show ?thesis
+    by (simp add: Hoare_haltE Hoare_haltI)
+qed
+ 
+text \<open>Definition of the General Halting Problem H2.\<close>
+
+definition H2 :: "((instr list) \<times> (nat list)) set"  (* behold the type of the set *)
+  where
+     "H2 \<equiv> {(tm,nl). TMC_has_num_res tm nl }"
+
+text \<open>No Turing Machine is able to decide the General Halting Problem H2.\<close>
+
+lemma existence_of_decider_H2D0_for_H2_imp_False:
+  assumes "\<exists>H2D0'. (\<forall>nl (tm::instr list).
+          ((tm,nl) \<in> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> H2D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk\<up>l)\<rbrace>)
+       \<and>  ((tm,nl) \<notin> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> H2D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l)\<rbrace>) )"
+  shows False
+proof -
+  from assms obtain H2D0' where
+    w_H2D0': "(\<forall>nl (tm::instr list).
+          ((tm,nl) \<in> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> H2D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @Bk\<up>l)\<rbrace>)
+       \<and>  ((tm,nl) \<notin> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> H2D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l)\<rbrace>) )"
+    by blast
+
+(* first, create a composable version of the arbitrary and thus potentially non-composable machine H2D0' *)
+
+  then have "composable_tm0 (mk_composable0 H2D0') \<and> (\<forall>nl (tm::instr list).
+          ((tm,nl) \<in> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> mk_composable0 H2D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @Bk\<up>l)\<rbrace>)
+       \<and>  ((tm,nl) \<notin> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> mk_composable0 H2D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l)\<rbrace>) )"
+
+    by (auto simp add: Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list composable_tm0_mk_composable0 )
+
+  then have "\<exists>H2D0. composable_tm0 H2D0 \<and> (\<forall>nl (tm::instr list).
+          ((tm,nl) \<in> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace>  H2D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @Bk\<up>l)\<rbrace>)
+       \<and>  ((tm,nl) \<notin> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> H2D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l)\<rbrace>) )"
+    by blast
+
+(* here we obtain the composable variant H2D0 of  H2D0' *)
+
+  then obtain H2D0 where w_H2D0: "composable_tm0 H2D0 \<and> (\<forall>nl (tm::instr list).
+          ((tm,nl) \<in> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace>  H2D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @Bk\<up>l)\<rbrace>)
+       \<and>  ((tm,nl) \<notin> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> H2D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l)\<rbrace>) )"
+    by blast
+
+(* define the culprit tm_contra from the diagonal by using tm_copy and tm_dither *)
+
+  define tm_contra where "tm_contra = (tm_copy |+| H2D0 |+| tm_dither)"
+
+  from w_H2D0 have H_composable: "composable_tm0 (tm_copy |+| H2D0)" by auto
+
+(* the stage is set: now, we derive the contradiction *)
+
+  show False
+  proof (cases "(tm_contra, [code tm_contra]) \<in> H2")
+
+    case True  
+    then have "(tm_contra, [code tm_contra]) \<in> H2" .
+
+    then have inH2: "TMC_has_num_res tm_contra [code tm_contra]"
+      by (auto simp add: H2_def)
+
+    show False  (* (tm_contra, [code tm_contra]) \<in> H2  \<Longrightarrow> (tm_contra, [code tm_contra]) \<notin> H2 *)
+    proof -
+
+      (* assertions *)
+      define P1 where "P1 \<equiv> \<lambda>tap. tap = ([]::cell list, <code tm_contra>)"
+      define P2 where "P2 \<equiv> \<lambda>tap. tap = ([Bk]::cell list, <(code tm_contra, code tm_contra)>)"
+      define Q3 where "Q3 \<equiv> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @Bk\<up>l)"
+
+(* the play book for derivation of the contradiction,
+   for the case: (tm_contra, [code tm_contra]) \<in> H2
+
+         \<lbrace>P1\<rbrace> tm_copy \<lbrace>P2\<rbrace>  \<lbrace>P2\<rbrace> H2D0 \<lbrace>Q3\<rbrace>
+         ---------------------------------
+         first: \<lbrace>P1\<rbrace> (tm_copy |+| H2D0) \<lbrace>Q3\<rbrace>    second: \<lbrace>Q3\<rbrace> tm_dither loops
+         -------------------------------------------------------------------
+                        \<lbrace>P1\<rbrace> tm_contra loops
+*)
+
+(* from \<lbrace>P1\<rbrace> tm_copy \<lbrace>P2\<rbrace>  \<lbrace>P2\<rbrace> H2D0 \<lbrace>Q3\<rbrace>   show  first: \<lbrace>P1\<rbrace> (tm_copy |+| H2D0) \<lbrace>Q3\<rbrace> *)
+
+      have first: "\<lbrace>P1\<rbrace> (tm_copy |+| H2D0) \<lbrace>Q3\<rbrace>" 
+      proof (cases rule: Hoare_plus_halt)
+        case A_halt (* of tm_copy *)
+        show "\<lbrace>P1\<rbrace> tm_copy \<lbrace>P2\<rbrace>" unfolding P1_def P2_def tape_of_nat_def
+          by (rule tm_copy_correct)
+      next
+        case B_halt (* of H2D0 *)
+        from \<open>(tm_contra, [code tm_contra]) \<in> H2\<close> and w_H2D0
+        have      "\<lbrace>\<lambda>tap. tap = ([], <(code tm_contra, [code tm_contra])> ) \<rbrace> H2D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @Bk\<up>l)\<rbrace>"          
+          by auto
+        then have "\<lbrace>\<lambda>tap. tap = ([], <(code tm_contra, code tm_contra)  > ) \<rbrace> H2D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @Bk\<up>l)\<rbrace>"
+          by (simp add: Hoare_haltE Hoare_haltI tape_of_list_def tape_of_prod_def)
+
+        then show "\<lbrace>P2\<rbrace> H2D0 \<lbrace>Q3\<rbrace>"
+          unfolding P2_def Q3_def
+          using add_single_BK_to_left_tape
+          by blast
+      next
+        show "composable_tm0 tm_copy" by auto
+      qed
+
+(* second: \<lbrace>P3\<rbrace> tm_dither loops *)
+
+      have second: "\<lbrace>Q3\<rbrace> tm_dither \<up>" unfolding Q3_def
+        using tm_dither_loops''
+        by (simp add: tape_of_nat_def )
+
+(* from first and second show  \<lbrace>P1\<rbrace> tm_contra loops *)
+
+      have "\<lbrace>P1\<rbrace> tm_contra \<up>" 
+        unfolding tm_contra_def
+        by (rule Hoare_plus_unhalt[OF first second H_composable])
+
+(* from \<lbrace>P1\<rbrace> tm_contra \<up>   show  \<not>TMC_has_num_res tm_contra [code tm_contra] *)
+
+      then have "\<not>TMC_has_num_res tm_contra [code tm_contra]"
+        unfolding P1_def
+        
+        by (metis (mono_tags) Hoare_halt_impl_not_Hoare_unhalt
+                  TMC_has_num_res_def inH2 tape_of_list_def tape_of_nat_list.simps(2))
+
+(* thus have contradiction *)
+
+      with inH2 show False by auto
+    qed
+
+  next
+
+    case False
+    then have "(tm_contra, [code tm_contra]) \<notin> H2" .
+    then have not_inH2: "\<not>TMC_has_num_res tm_contra [code tm_contra]"
+      by (auto simp add: H2_def)
+
+    show False  (* (tm_contra, [code tm_contra]) \<notin> H2 \<Longrightarrow> (tm_contra, [code tm_contra]) \<in> H2 *)
+    proof -
+
+      (* assertions *)
+      define P1 where "P1 \<equiv> \<lambda>tap. tap = ([]::cell list, <code tm_contra>)"
+      define P2 where "P2 \<equiv> \<lambda>tap. tap = ([Bk], <(code tm_contra, code tm_contra)>)"
+      define P3 where "P3 \<equiv> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l )"
+
+(* the play book for derivation of the contradiction,
+   for the case: (tm_contra, [code tm_contra]) \<notin> H2
+
+         \<lbrace>P1\<rbrace> tm_copy \<lbrace>P2\<rbrace>  \<lbrace>P2\<rbrace> H2D0 \<lbrace>P3\<rbrace> 
+         --------------------------------
+         first: \<lbrace>P1\<rbrace> (tm_copy |+| H2D0) \<lbrace>P3\<rbrace>   second: \<lbrace>P3\<rbrace> tm_dither \<lbrace>P3\<rbrace>
+         ----------------------------------------------------------------
+                           \<lbrace>P1\<rbrace> tm_contra \<lbrace>P3\<rbrace>
+*)
+
+(* from \<lbrace>P1\<rbrace> tm_copy \<lbrace>P2\<rbrace>  \<lbrace>P2\<rbrace> H2D0 \<lbrace>P3\<rbrace>     show    first: \<lbrace>P1\<rbrace> (tm_copy |+| H2D0) \<lbrace>P3\<rbrace> *)
+
+      have first: "\<lbrace>P1\<rbrace> (tm_copy |+| H2D0) \<lbrace>P3\<rbrace>"
+      proof (cases rule: Hoare_plus_halt)
+        case A_halt (* of tm_copy *)
+        show "\<lbrace>P1\<rbrace> tm_copy \<lbrace>P2\<rbrace>" unfolding P1_def P2_def tape_of_nat_def
+          by (rule tm_copy_correct)
+      next
+        case B_halt (* of H2D0 *)
+        from \<open>(tm_contra, [code tm_contra]) \<notin> H2\<close> and w_H2D0
+        have      "\<lbrace>\<lambda>tap. tap = ([], <(code tm_contra, [code tm_contra])> ) \<rbrace> H2D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l)\<rbrace>"            
+          by auto
+        then have "\<lbrace>\<lambda>tap. tap = ([], <(code tm_contra, code tm_contra)  > ) \<rbrace> H2D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l)\<rbrace>"
+          by (simp add: Hoare_haltE Hoare_haltI tape_of_list_def tape_of_prod_def)
+
+        then show "\<lbrace>P2\<rbrace> H2D0 \<lbrace>P3\<rbrace>"
+          unfolding P2_def P3_def
+          by (rule add_single_BK_to_left_tape)
+      next
+        show "composable_tm0 tm_copy" by simp
+      qed
+
+(* second: \<lbrace>P3\<rbrace> tm_dither \<lbrace>P3\<rbrace> *)
+
+      from tm_dither_halts
+      have "\<lbrace>\<lambda>tap. tap = ([], [Oc, Oc])\<rbrace> tm_dither \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l)\<rbrace>"
+      proof -
+        have "\<forall>n. \<exists>l. steps0 (1, Bk \<up> n, [Oc, Oc]) tm_dither (Suc 1) = (0, Bk \<up> n, [Oc, Oc] @Bk\<up>l)"
+          by (metis One_nat_def tm_dither_halts_aux Suc_1 append.right_neutral replicate.simps(1) )
+        then show ?thesis
+          using Hoare_halt_add_Bks_left_tape_L2 Hoare_halt_del_Bks_left_tape by blast          
+      qed
+
+      then have second: "\<lbrace>P3\<rbrace> tm_dither \<lbrace>P3\<rbrace>" unfolding P3_def       
+      proof -
+        have "Oc # [Oc] = [Oc, Oc]"
+          using One_nat_def replicate_Suc tape_of_nat_def by fastforce
+        then show "\<lbrace>\<lambda>p. \<exists>n na. p = (Bk \<up> n, [Oc, Oc] @ Bk \<up> na)\<rbrace> tm_dither \<lbrace>\<lambda>p. \<exists>n na. p = (Bk \<up> n, [Oc, Oc] @ Bk \<up> na)\<rbrace>"
+          using tm_dither_halts'' by presburger
+      qed
+
+(* from first and second show  \<lbrace>P1\<rbrace> tm_contra \<lbrace>P3\<rbrace> *)
+
+      with first have "\<lbrace>P1\<rbrace> tm_contra \<lbrace>P3\<rbrace>"
+        unfolding tm_contra_def
+      proof (rule Hoare_plus_halt)
+        from H_composable show "composable_tm0 (tm_copy |+| H2D0)" by auto
+      qed
+
+(* from  \<lbrace>P1\<rbrace> tm_contra \<lbrace>P3\<rbrace>    show    TMC_has_num_res tm_contra [code tm_contra] *)
+
+      then have "TMC_has_num_res tm_contra [code tm_contra]" unfolding P1_def P3_def
+        by (simp add: Hoare_haltE Hoare_haltI Hoare_halt_with_OcOc_imp_std_tap tape_of_list_def)
+
+(* thus have contradiction *)
+
+      with not_inH2
+      show ?thesis by auto
+    qed
+  qed
+qed
+
+text \<open>Note: since we did not formalize the concept of Turing Computable Functions and
+ Characteristic Functions of sets yet, we are (at the moment) not able to formalize the existence
+ of an  uncomputable function, namely the characteristic function of the set H2.
+
+ Another caveat is the fact that the set H2 has type @{typ "((instr list) \<times> (nat list)) set"}.
+ This is in contrast to the classical formalization of decision problems, where the sets discussed
+ only contain tuples respectively lists of natural numbers. 
+  \<close>
+end (* locale uncomputable *)
+
+end
+
diff --git a/thys/Universal_Turing_Machine/TuringUnComputable_H2_original.thy b/thys/Universal_Turing_Machine/TuringUnComputable_H2_original.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/TuringUnComputable_H2_original.thy
@@ -0,0 +1,252 @@
+(* Title: thys/TuringUnComputable_H2_original.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+
+   Further contributions by Franz Regensburger (FABR) 02/2022:
+   * Re-ordering of sections
+   * Added comments
+
+   Editorial note FABR:
+   this file was part of the theory file Uncomputable.thy
+   in the original AFP entry. 
+   
+ *)
+
+subsubsection \<open>Undecidability of the General Halting Problem H, Variant 2, original version\<close>
+
+theory TuringUnComputable_H2_original
+  imports
+    DitherTM
+    CopyTM
+
+begin
+
+(*
+declare adjust.simps[simp del]
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+*)
+
+(* Cleanup the global simpset for proofs of several theorems about tm_dither *)
+
+(*
+declare adjust.simps[simp del]
+*)
+
+text \<open>The diagonal argument below shows the undecidability of a variant of the
+ General Halting Problem. Implicitly, we thus show that the General Halting Function
+ (the characteristic function of the Halting Problem) is not Turing computable.\<close>
+
+(*
+
+Turing_HaltingConditions.thy:
+
+definition TMC_has_num_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"
+  where
+    "TMC_has_num_res p ns \<equiv>
+     \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+
+DitherTM.thy:
+
+lemma composable_tm0_tm_dither[intro, simp]: "composable_tm0 tm_dither"
+  by (auto simp: composable_tm.simps tm_dither_def)
+
+CopyTM.thy:
+
+lemma composable_tm0_tm_copy[intro, simp]: "composable_tm0 tm_copy"
+  by (auto simp: tm_copy_def)
+
+*)
+
+text \<open>
+  The following locale specifies that some TM \<open>H\<close> can be used to decide 
+  the {\em General Halting Problem} and \<open>False\<close> is going to be derived 
+  under this locale. Therefore, the undecidability of the  {\em  General Halting Problem}
+  is established.
+
+  The proof makes use of the TMs \<open>tm_copy\<close> and \<open>tm_dither\<close>.
+\<close>
+
+locale uncomputable = 
+  (* Interestingly, the detailed definition of the coding function @{text "code"} for Turing machines
+     does not affect the final result. In the proof there is no need to appeal on properties of the coding function
+     like e.g. injectivity! *)
+
+fixes code :: "instr list \<Rightarrow> nat" 
+  (* 
+   * The TM "H" is the one which is assumed being able to solve the general Halting problem.
+   *)
+  and H :: "instr list"
+
+  (* FABR Note:
+   * The next axiom states that the Turing machine H is well-formed (composable).
+   * However, this manifests a bug in the modelling of this locale!
+   *
+   * Due to this local axiom, we only prove that there exists no composable TM H
+   * that is able to decide the Halting problem 'TMC_has_num_res M ns'
+   *
+   * See theories composableTMs and HaltingProblem_K for a fix by FABR.
+   *
+   *)
+
+assumes h_composable[intro]: "composable_tm0 H"
+
+
+  (*
+   * The following two local axioms specify (claim) that the Turing Machine H
+   * is able to decide the general Halting problem H2.
+   *)
+
+and h_case:
+"\<And> M ns.  TMC_has_num_res M ns \<Longrightarrow> \<lbrace>(\<lambda>tap. tap = ([Bk], <(code M, ns)>))\<rbrace> H \<lbrace>(\<lambda>tap. \<exists>k. tap = (Bk \<up> k, <0::nat>))\<rbrace>"
+and nh_case: 
+"\<And> M ns. \<not>  TMC_has_num_res M ns \<Longrightarrow> \<lbrace>(\<lambda>tap. tap = ([Bk], <(code M, ns)>))\<rbrace> H \<lbrace>(\<lambda>tap. \<exists>k. tap = (Bk \<up> k, <1::nat>))\<rbrace>"
+begin
+
+(* Assertions for the Turing Machine H *)
+abbreviation (input)
+  "pre_H_ass M ns \<equiv> \<lambda>tap. tap = ([Bk], <(code M, ns::nat list)>)"
+
+abbreviation (input)
+  "post_H_halt_ass \<equiv> \<lambda>tap. \<exists>k. tap = (Bk \<up> k, <1::nat>)"
+
+abbreviation (input)
+  "post_H_unhalt_ass \<equiv> \<lambda>tap. \<exists>k. tap = (Bk \<up> k, <0::nat>)"
+
+
+lemma H_halt:
+  assumes "\<not>  TMC_has_num_res M ns" 
+  shows "\<lbrace>pre_H_ass M ns\<rbrace> H \<lbrace>post_H_halt_ass\<rbrace>"
+  using assms nh_case by auto
+
+lemma H_unhalt:
+  assumes " TMC_has_num_res M ns" 
+  shows "\<lbrace>pre_H_ass M ns\<rbrace> H \<lbrace>post_H_unhalt_ass\<rbrace>"
+  using assms h_case by auto
+
+(* The TM tcontra is the culprit that is used to derive a contradiction *)
+
+definition
+  "tcontra \<equiv> (tm_copy |+| H) |+| tm_dither"
+abbreviation
+  "code_tcontra \<equiv> code tcontra"
+
+(* assume tcontra does not halt on its code *)
+lemma tcontra_unhalt: 
+  assumes "\<not>  TMC_has_num_res tcontra [code tcontra]"
+  shows "False"
+proof -
+  (* invariants *)
+  define P1 where "P1 \<equiv> \<lambda>tap. tap = ([]::cell list, <code_tcontra>)"
+  define P2 where "P2 \<equiv> \<lambda>tap. tap = ([Bk], <(code_tcontra, code_tcontra)>)"
+  define P3 where "P3 \<equiv> \<lambda>tap. \<exists>k. tap = (Bk \<up> k, <1::nat>)"
+
+(*
+  \<lbrace>P1\<rbrace> tm_copy \<lbrace>P2\<rbrace>  \<lbrace>P2\<rbrace> H \<lbrace>P3\<rbrace> 
+  ----------------------------
+     \<lbrace>P1\<rbrace> (tm_copy |+| H) \<lbrace>P3\<rbrace>     \<lbrace>P3\<rbrace> tm_dither \<lbrace>P3\<rbrace>
+  ------------------------------------------------
+                 \<lbrace>P1\<rbrace> tcontra \<lbrace>P3\<rbrace>
+  *)
+
+  have H_composable: "composable_tm0 (tm_copy |+| H)" by auto
+
+(* \<lbrace>P1\<rbrace> (tm_copy |+| H) \<lbrace>P3\<rbrace> *)
+  have first: "\<lbrace>P1\<rbrace> (tm_copy |+| H) \<lbrace>P3\<rbrace>" 
+  proof (cases rule: Hoare_plus_halt)
+    case A_halt (* of tm_copy *)
+    show "\<lbrace>P1\<rbrace> tm_copy \<lbrace>P2\<rbrace>" unfolding P1_def P2_def tape_of_nat_def
+      by (rule tm_copy_correct)
+  next
+    case B_halt (* of H *)
+    show "\<lbrace>P2\<rbrace> H \<lbrace>P3\<rbrace>"
+      unfolding P2_def P3_def 
+      using H_halt[OF assms]
+      by (simp add: tape_of_prod_def tape_of_list_def)
+  qed (simp)
+
+(* \<lbrace>P3\<rbrace> tm_dither \<lbrace>P3\<rbrace> *)
+  have second: "\<lbrace>P3\<rbrace> tm_dither \<lbrace>P3\<rbrace>" unfolding P3_def 
+    by (rule tm_dither_halts)
+
+(* \<lbrace>P1\<rbrace> tcontra \<lbrace>P3\<rbrace> *)
+  have "\<lbrace>P1\<rbrace> tcontra \<lbrace>P3\<rbrace>" 
+    unfolding tcontra_def
+    by (rule Hoare_plus_halt[OF first second H_composable])
+
+  with assms show "False"
+    unfolding P1_def P3_def
+    unfolding  TMC_has_num_res_def
+    unfolding Hoare_halt_def 
+    apply(auto) apply(rename_tac n)
+    apply(drule_tac x = n in spec)
+    apply(case_tac "steps0 (Suc 0, [], <code tcontra>) tcontra n")
+    apply(auto simp add: tape_of_list_def)
+    by (metis append_Nil2 replicate_0)
+qed
+
+(* asumme tcontra halts on its code *)
+lemma tcontra_halt: 
+  assumes " TMC_has_num_res tcontra [code tcontra]"
+  shows "False"
+proof - 
+  (* invariants *)
+  define P1 where "P1 \<equiv> \<lambda>tap. tap = ([]::cell list, <code_tcontra>)"
+  define P2 where "P2 \<equiv> \<lambda>tap. tap = ([Bk], <(code_tcontra, code_tcontra)>)"
+  define Q3 where "Q3 \<equiv> \<lambda>tap. \<exists>k. tap = (Bk \<up> k, <0::nat>)"
+
+(*
+  \<lbrace>P1\<rbrace> tm_copy \<lbrace>P2\<rbrace>  \<lbrace>P2\<rbrace> H \<lbrace>Q3\<rbrace> 
+  ----------------------------
+     \<lbrace>P1\<rbrace> (tm_copy |+| H) \<lbrace>Q3\<rbrace>     \<lbrace>Q3\<rbrace> tm_dither loops
+  ------------------------------------------------
+               \<lbrace>P1\<rbrace> tcontra loops
+  *)
+
+  have H_composable: "composable_tm0 (tm_copy |+| H)" by auto
+
+(* \<lbrace>P1\<rbrace> (tm_copy |+| H) \<lbrace>Q3\<rbrace> *)
+  have first: "\<lbrace>P1\<rbrace> (tm_copy |+| H) \<lbrace>Q3\<rbrace>" 
+  proof (cases rule: Hoare_plus_halt)
+    case A_halt (* of tm_copy *)
+    show "\<lbrace>P1\<rbrace> tm_copy \<lbrace>P2\<rbrace>" unfolding P1_def P2_def tape_of_nat_def
+      by (rule tm_copy_correct)
+  next
+    case B_halt (* of H *)
+    then show "\<lbrace>P2\<rbrace> H \<lbrace>Q3\<rbrace>"
+      unfolding P2_def Q3_def using H_unhalt[OF assms]
+      by(simp add: tape_of_prod_def tape_of_list_def)
+  qed (simp)
+
+(* \<lbrace>P3\<rbrace> tm_dither loops *)
+  have second: "\<lbrace>Q3\<rbrace> tm_dither \<up>" unfolding Q3_def 
+    by (rule tm_dither_loops)
+
+(* \<lbrace>P1\<rbrace> tcontra loops *)
+  have "\<lbrace>P1\<rbrace> tcontra \<up>" 
+    unfolding tcontra_def
+    by (rule Hoare_plus_unhalt[OF first second H_composable])
+
+  with assms show "False"
+    unfolding P1_def
+    unfolding  TMC_has_num_res_def
+    unfolding Hoare_halt_def Hoare_unhalt_def
+    by (auto simp add: tape_of_list_def)
+qed
+
+text \<open>
+  Thus \<open>False\<close> is derivable.
+\<close>
+
+lemma false: "False"
+  using tcontra_halt tcontra_unhalt 
+  by auto
+
+end (* locale uncomputable *)
+
+end
+
diff --git a/thys/Universal_Turing_Machine/Turing_HaltingConditions.thy b/thys/Universal_Turing_Machine/Turing_HaltingConditions.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/Turing_HaltingConditions.thy
@@ -0,0 +1,594 @@
+(* Title: thys/Turing_HaltingConditions.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+ 
+   Further contributions by Franz Regensburger (FABR) 02/2022
+ *)
+
+section \<open>Halting Conditions and Standard Halting Configuration\<close>
+
+theory Turing_HaltingConditions
+  imports Turing_Hoare
+begin
+
+subsection \<open>Looping of Turing Machines\<close>
+
+definition TMC_loops :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"
+  where
+    "TMC_loops p ns \<equiv> (\<forall>stp.\<not> is_final (steps0 (1, [], <ns::nat list>) p stp))"
+
+subsection \<open>Reaching the Final State\<close>
+
+definition reaches_final :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"
+  where
+    "reaches_final p ns \<equiv> \<lbrace>(\<lambda>tap. tap = ([], <ns>))\<rbrace> p \<lbrace>(\<lambda>tap. True)\<rbrace>"
+
+text \<open>The definition @{term reaches_final} and all lemmas about it are only needed for the special halting problem K0. \<close>
+
+lemma True_holds_for_all: "(\<lambda>tap. True) holds_for c"
+  by (cases c)(auto)
+
+lemma reaches_final_iff: "reaches_final p ns \<longleftrightarrow> (\<exists>n. is_final (steps0 (1, ([], <ns>)) p n))"
+  by (auto simp add: reaches_final_def Hoare_halt_def True_holds_for_all)
+
+
+
+text \<open>Some lemmas about reaching the Final State.\<close>
+
+lemma Hoare_halt_from_init_imp_reaches_final:
+  assumes "\<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> p \<lbrace>Q\<rbrace>"
+  shows "reaches_final p ns"
+proof -
+  from assms have "\<forall>tap. tap = ([], <ns>) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) p n))"
+    using Hoare_halt_def by auto
+  then show ?thesis
+    using reaches_final_iff by auto
+qed
+
+lemma Hoare_unhalt_impl_not_reaches_final:
+  assumes "\<lbrace>(\<lambda>tap. tap = ([], <ns>))\<rbrace> p \<up>"
+  shows "\<not>(reaches_final p ns)"
+proof 
+  assume "reaches_final p ns"
+  then have "(\<exists>n. is_final (steps0 (1, ([], <ns>)) p n))" by (auto simp add: reaches_final_iff)
+  then obtain n where w_n: "is_final (steps0 (1, ([], <ns>)) p n)" by blast
+  from assms have "\<forall>tap. (\<lambda>tap. tap = ([], <ns>)) tap \<longrightarrow> (\<forall> n . \<not> (is_final (steps0 (1, tap) p n)))"
+    by (auto simp add: Hoare_unhalt_def)
+  then have "\<not> (is_final (steps0 (1, ([], <ns>)) p n))" by blast
+  with w_n show False by auto
+qed
+
+subsection \<open>What is a Standard Tape\<close>
+
+text \<open>A tape is called {\em standard}, if the left tape is empty or contains only blanks and
+the right tape contains a single nonempty block of strokes (occupied cells) followed by zero or more blanks..
+
+Thus, by definition of left and right tape, the head of the machine is always
+scanning the first cell of this single block of strokes.
+
+We extend the notion of a standard tape to lists of numerals as well.
+\<close>
+
+definition std_tap :: "tape \<Rightarrow> bool"
+  where
+    "std_tap tap  \<equiv> (\<exists>k n l. tap = (Bk \<up> k,  <n::nat> @ Bk \<up> l))"
+
+definition std_tap_list :: "tape \<Rightarrow> bool"
+  where
+    "std_tap_list tap  \<equiv> (\<exists>k ml l. tap = (Bk \<up> k,  <ml::nat list> @ Bk \<up> l))"
+
+
+lemma "std_tap tap \<Longrightarrow> std_tap_list tap"
+  unfolding std_tap_def std_tap_list_def
+  by (metis tape_of_list_def tape_of_nat_list.simps(2))
+
+text \<open>A configuration @{term "(st, l, r)"} of a Turing machine is called a {\em standard configuration},
+ if the state  @{term "st"} is the final state $0$ and the @{term "(l, r)"} is a standard tape. 
+\<close>
+
+(* A duplicate from UTM just for comparison of concepts *)
+
+definition TSTD':: "config \<Rightarrow> bool"
+  where
+    "TSTD' c = ((let (st, l, r) = c in 
+             st = 0 \<and> (\<exists> m. l = Bk\<up>(m)) \<and> (\<exists> rs n. r = Oc\<up>(Suc rs) @ Bk\<up>(n))))"
+
+(* Relate definition of TSTD' to std_tap *)
+
+lemma "TSTD' (st, l, r) = ((st = 0) \<and> std_tap (l,r))"
+  unfolding TSTD'_def std_tap_def
+proof -
+  have "(let (st, l, r) = (st, l, r) in st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>rs n. r = Oc \<up> Suc rs @ Bk \<up> n))
+        = (st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>rs n. r = Oc \<up> Suc rs @ Bk \<up> n))"
+    by auto
+  also have "... = (st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>n la. r = (<n::nat> @ Bk \<up> la)))"
+    by (auto simp add: tape_of_nat_def)
+  finally have "(let (st, l, r) = (st, l, r) in st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>rs n. r = Oc \<up> Suc rs @ Bk \<up> n))
+                = (st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>n la. r = (<n::nat> @ Bk \<up> la)))"
+    by (auto simp add: tape_of_nat_def)
+  moreover have "((\<exists>m. l = Bk \<up> m) \<and> (\<exists>n la. r = <n::nat> @ Bk \<up> la)) = (\<exists>k n la. (l, r) = (Bk \<up> k, <n::nat> @ Bk \<up> la))"
+    by auto
+  ultimately show "(let (st, l, r) = (st, l, r)
+                    in  st = 0 \<and> (\<exists>m. l = Bk \<up> m) \<and> (\<exists>rs n. r = Oc \<up> Suc rs @ Bk \<up> n))
+                    = 
+                    (st = 0 \<and> (\<exists>k n la. (l, r) = (Bk \<up> k, <n::nat> @ Bk \<up> la)))"
+    by blast
+qed
+
+subsection \<open>What does Hoare\_halt mean in general?\<close>
+
+text \<open>We say {\em in general} because the result computed on the right tape is not necessarily a numeral but some arbitrary component @{term "r'"} . \<close>
+
+lemma Hoare_halt2_iff:
+"\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, r @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>
+ \<longleftrightarrow>
+ (\<forall>kl ll. \<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr)))"
+proof
+  assume "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, r @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
+  then show "\<forall>kl ll. \<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
+    by (smt Hoare_halt_def Pair_inject holds_for.elims(2) is_final.elims(2))
+next
+  assume "\<forall>kl ll. \<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
+  then show "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, r @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
+  unfolding Hoare_halt_def  
+  using holds_for.simps by fastforce
+qed
+
+lemma Hoare_halt_D:
+  assumes "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, r @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
+  shows "\<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
+proof -
+  from assms show "\<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
+    by (simp add: Hoare_halt2_iff is_final_eq)
+qed
+
+lemma Hoare_halt_I2:
+  assumes "\<And>kl ll. \<exists>n. is_final (steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> kl, r @ Bk \<up> ll)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
+  shows "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, r @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
+  unfolding Hoare_halt_def  
+  using assms holds_for.simps by fastforce
+
+
+lemma Hoare_halt_D_Nil:
+  assumes "\<lbrace>\<lambda>tap. tap = ([], r)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
+  shows "\<exists>n. is_final (steps0 (1, ([], r)) p n) \<and> (\<exists>kr lr. steps0 (1, ([], r)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
+proof -
+  from assms have "\<lbrace>\<lambda>tap. tap = (Bk \<up> 0, r @ Bk \<up> 0)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
+    by simp
+  then have "\<exists>n. is_final (steps0 (1, (Bk \<up> 0, r @ Bk \<up> 0)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> 0, r @ Bk \<up> 0)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
+    using Hoare_halt_E0 append_self_conv assms is_final_eq old.prod.inject prod.inject replicate_0
+    by force
+  then show ?thesis by auto
+qed
+
+lemma Hoare_halt_I2_Nil:
+  assumes "\<exists>n. is_final (steps0 (1, ([], r )) p n) \<and> (\<exists>kr lr. steps0 (1, ([], r )) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
+  shows "\<lbrace>\<lambda>tap. tap = ([], r)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
+proof -
+  from assms have "\<exists>n. is_final (steps0 (1, (Bk \<up> 0, r @ Bk \<up> 0)) p n) \<and> (\<exists>kr lr. steps0 (1, (Bk \<up> 0, r @ Bk \<up> 0)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr))"
+    by auto
+  then have "\<lbrace>\<lambda>tap. tap = (Bk \<up> 0, r @ Bk \<up> 0)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>"
+    using Hoare_halt_iff by auto
+  then show ?thesis by auto
+qed
+
+lemma Hoare_halt2_Nil_iff:
+  "\<lbrace>\<lambda>tap. tap = ([], r)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, r' @ Bk \<up> lr)\<rbrace>
+   \<longleftrightarrow>
+   (\<exists>n. is_final (steps0 (1, ([], r)) p n) \<and> (\<exists>kr lr. steps0 (1, ([], r)) p n = (0, Bk \<up> kr, r' @ Bk \<up> lr)))"
+  using Hoare_halt_D_Nil Hoare_halt_I2_Nil by blast
+
+corollary Hoare_halt_left_tape_Nil_imp_All_left_and_right:
+  assumes "\<lbrace>\<lambda>tap.       tap = ([]    , r         )\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k , r' @ Bk \<up> l)\<rbrace>"
+  shows   "\<lbrace>\<lambda>tap. \<exists>x y. tap = (Bk \<up> x, r @ Bk \<up> y)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k , r' @ Bk \<up> l)\<rbrace>"
+proof -
+  from assms have "\<exists>n. is_final (steps0 (1, ([], r)) p n) \<and> (\<exists>k l. steps0 (1, ([], r)) p n = (0, Bk \<up> k,  r' @ Bk \<up> l))"
+    using Hoare_halt_D_Nil by auto
+  then have "\<And>x y. \<exists>n. is_final (steps0 (1, (Bk \<up> x, r @ Bk \<up> y)) p n) \<and> (\<exists>k l. steps0 (1, (Bk \<up> x, r @ Bk \<up> y)) p n = (0, Bk \<up> k,  r' @ Bk \<up> l))"
+    using ex_steps_left_tape_Nil_imp_All_left_and_right
+    using is_final.simps by force
+  then show ?thesis using Hoare_halt_I2
+    by auto
+qed
+
+subsubsection \<open>What does Hoare\_halt with a numeral list result mean?\<close>
+
+text \<open>About computations that result in numeral lists on the final right tape.\<close>
+
+(* Adding trailing blanks to the initial right tape needs tough lemmas (see BlanksDoNotMatter)  *)
+
+lemma TMC_has_num_res_list_without_initial_Bks_imp_TMC_has_num_res_list_after_adding_Bks_to_initial_right_tape:
+  " \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>
+  \<Longrightarrow>
+    \<lbrace>\<lambda>tap. \<exists>ll. tap = ([], <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+proof -
+  assume A: "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+  then have "\<exists>n. is_final (steps0 (1, ([], <ns::nat list>)) p n) \<and>
+                 (\<exists>ms kr lr. steps0 (1, ([], <ns::nat list>)) p n = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr))"
+    using Hoare_halt_E0 is_finalI by force
+  then obtain stp where
+    w_stp: "is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and>
+            (\<exists>ms kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr))"
+    by blast
+
+  then obtain ms where  "\<exists>kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)" by blast
+
+  then have "\<forall>ll. \<exists>kr lr. steps0 (1, ([], <ns::nat list>@ Bk \<up> ll)) p stp = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)"
+    using ex_steps_left_tape_Nil_imp_All_left_and_right steps_left_tape_ShrinkBkCtx_to_NIL by blast
+
+  then have "\<forall>ll. is_final (steps0 (1, ([], <ns::nat list>@ Bk \<up> ll)) p stp) \<and>
+                 (\<exists>ms kr lr. steps0 (1, ([], <ns::nat list>@ Bk \<up> ll)) p stp = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr))"   
+    by (metis is_finalI)
+
+  then have "\<forall>tap. (\<exists>ll. tap = ([], <ns::nat list> @ Bk \<up> ll))
+                    \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) p n) \<and>
+                             (\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)) holds_for steps0 (1, tap) p n)"
+    using holds_for.simps by force
+  then show ?thesis
+    unfolding Hoare_halt_def
+    by auto
+qed
+
+(* Removing trailing blanks on the initial right tape (is easy) *)
+
+lemma TMC_has_num_res_list_without_initial_Bks_iff_TMC_has_num_res_list_after_adding_Bks_to_initial_right_tape:
+  "\<lbrace>\<lambda>tap.      tap = ([], <ns::nat list>)          \<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>
+    \<longleftrightarrow>
+   \<lbrace>\<lambda>tap. \<exists>ll. tap = ([], <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+proof
+  assume "\<lbrace>\<lambda>tap.      tap = ([], <ns::nat list>)          \<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+  then show "\<lbrace>\<lambda>tap. \<exists>ll. tap = ([], <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+  using  TMC_has_num_res_list_without_initial_Bks_imp_TMC_has_num_res_list_after_adding_Bks_to_initial_right_tape by blast
+next
+  assume "\<lbrace>\<lambda>tap. \<exists>ll. tap = ([], <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+  then show "\<lbrace>\<lambda>tap.      tap = ([], <ns::nat list>)          \<rbrace> p \<lbrace>\<lambda>tap. \<exists>ms kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+    by (simp add: Hoare_halt_def assert_imp_def)
+qed
+
+
+(* In addition we may add or remove blanks on the initial left tape *)
+
+lemma TMC_has_num_res_list_without_initial_Bks_imp_TMC_has_num_res_list_after_adding_Bks_to_initial_left_and_right_tape:
+  " \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap.\<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>
+  \<Longrightarrow>
+    \<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+  using Hoare_halt_left_tape_Nil_imp_All_left_and_right by auto
+
+(*
+proof -
+  assume A: "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap.\<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+
+  then have "\<exists>stp. is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and>
+                   (\<exists> kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr,  <ms::nat list> @ Bk \<up> lr))"
+    using Hoare_halt2_Nil_iff tape_of_list_def tape_of_nat_list.simps(2)  by blast
+
+  then obtain stp where
+    w_stp: "is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and>
+                   (\<exists> kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr,  <ms::nat list> @ Bk \<up> lr))"
+    by blast
+
+  then have "\<forall>kl ll.\<exists>kr lr. steps0 (1, Bk \<up> kl, <ns::nat list> @ Bk \<up> ll) p stp = (0, Bk \<up> kr,  <ms::nat list> @ Bk \<up> lr)"
+    using ex_steps_left_tape_Nil_imp_All_left_and_right steps_left_tape_ShrinkBkCtx_to_NIL by blast
+
+  then have "\<forall>kl ll. is_final (steps0 (1, Bk \<up> kl, <ns::nat list> @ Bk \<up> ll) p stp) \<and>
+                  (\<exists>kr lr. steps0 (1, Bk \<up> kl , <ns::nat list> @ Bk \<up> ll) p stp = (0, Bk \<up> kr,  <ms::nat list> @ Bk \<up> lr))"
+    by (metis is_finalI)
+
+  then have "\<forall>tap. (\<exists>kl ll. tap = (Bk \<up> kl, <ns::nat list> @ Bk \<up> ll) )
+                    \<longrightarrow> (\<exists>stp. is_final (steps0 (1, tap) p stp) \<and>
+                  (\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr,  <ms::nat list> @ Bk \<up> lr)) holds_for steps0 (1, tap) p stp)"
+    using holds_for.simps by force
+  then show ?thesis
+    unfolding Hoare_halt_def
+    by auto
+qed
+*)
+
+lemma TMC_has_num_res_list_without_initial_Bks_iff_TMC_has_num_res_list_after_adding_Bks_to_initial_left_and_right_tape:
+  " \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap.\<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>
+  \<longleftrightarrow>
+    \<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+proof
+  assume "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap.\<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+  then show "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+    using TMC_has_num_res_list_without_initial_Bks_imp_TMC_has_num_res_list_after_adding_Bks_to_initial_left_and_right_tape by auto
+next
+  assume "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, <ns::nat list> @ Bk \<up> ll)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap.\<exists>kr lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+    by (simp add: Hoare_halt_def assert_imp_def)
+qed
+
+
+subsection \<open>Halting in a Standard Configuration\<close>
+
+subsubsection \<open>Definition of Halting in a Standard Configuration\<close>
+
+text \<open>The predicates \<open>TMC_has_num_res p ns\<close> and \<open>TMC_has_num_list_res\<close> describe that
+ a run of the Turing program \<open>p\<close> on input \<open>ns\<close> reaches the final state 0
+ and the final tape produced thereby is standard.
+ Thus, the computation of the Turing machine \<open>p\<close> produced a result, which is
+ either a single numeral or a list of numerals.
+
+Since trailing blanks on the initial left or right tape do not matter,
+we may restrict our definitions to the case where
+ the initial left tape is empty and
+ there are no trailing blanks on the initial right tape!
+\<close>
+
+definition TMC_has_num_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"
+  where
+    "TMC_has_num_res p ns \<equiv>
+     \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+
+lemma TMC_has_num_res_iff: "TMC_has_num_res p ns
+         \<longleftrightarrow>
+       (\<exists>stp. is_final (steps0 (1, [],<ns::nat list>) p stp) \<and>
+              (\<exists>k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)))"
+  unfolding TMC_has_num_res_def
+proof
+  assume "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+  then show "\<exists>stp. is_final (steps0 (1, [], <ns::nat list>) p stp) \<and> (\<exists>k n l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
+    by (smt Hoare_halt_def holds_for.elims(2) is_final.elims(2) is_final_eq)
+next
+  assume "\<exists>stp. is_final (steps0 (1, [], <ns::nat list>) p stp) \<and> (\<exists>k n l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
+  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+    by (metis (mono_tags, lifting) Hoare_halt_def holds_for.simps)
+qed
+
+(* for clarification
+lemma TMC_has_num_res_iff': "TMC_has_num_res p ns \<equiv>
+       (\<exists>stp k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
+  by (smt TMC_has_num_res_iff is_finalI steps_0 steps_add)
+*)
+
+(* --- *)
+
+definition TMC_has_num_list_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"
+  where
+    "TMC_has_num_list_res p ns \<equiv>
+     \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr ms lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+ 
+lemma TMC_has_num_list_res_iff: "TMC_has_num_list_res p ns
+         \<longleftrightarrow>
+       (\<exists>stp. is_final (steps0 (1, [],<ns::nat list>) p stp) \<and>
+              (\<exists>k ms l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk \<up> l)))"
+  unfolding TMC_has_num_list_res_def
+proof
+  assume "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k ms l. tap = (Bk \<up> k, <ms::nat list> @ Bk \<up> l)\<rbrace>"
+  then show "\<exists>stp. is_final (steps0 (1, [], <ns::nat list>) p stp) \<and> (\<exists>k ms l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk \<up> l))"
+    by (smt Hoare_halt_def holds_for.elims(2) is_final.elims(2) is_final_eq)
+next
+  assume "\<exists>stp. is_final (steps0 (1, [], <ns::nat list>) p stp) \<and> (\<exists>k ms l. steps0 (1, [], <ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk \<up> l))"
+  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k ms l.   tap = (Bk \<up> k, <ms::nat list> @ Bk \<up> l)\<rbrace>"
+    by (metis (mono_tags, lifting) Hoare_halt_def holds_for.simps)
+qed
+
+(* for clarification
+lemma TMC_has_num_list_res_iff': "TMC_has_num_list_res p ns \<equiv>
+        (\<exists>stp k ms l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk \<up> l))"
+  by (smt TMC_has_num_list_res_iff is_finalI steps_0 steps_add)
+*)
+
+subsubsection \<open>Relation between TMC\_has\_num\_res and TMC\_has\_num\_list\_res\<close>
+
+text \<open>A computation of a Turing machine, which started on a list of numerals and halts in a
+ standard configuration with a single numeral result is a special case of a halt in a standard configuration that
+halts with a list of numerals.\<close>
+
+(* FABR: this is an important lemma, since it motivates and validates our extension
+ * of various concepts to lists of natural numbers or numerals
+ *)
+
+theorem TMC_has_num_res_imp_TMC_has_num_list_res: 
+  "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>
+   \<Longrightarrow>
+   \<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr ms lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+proof -
+  assume A: "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+
+  then have "\<exists>stp. is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and>
+                 (\<exists>n kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <n::nat> @ Bk \<up> lr))"
+    by (smt Hoare_halt_def holds_for.elims(2) is_final.elims(2) is_final_eq)
+  then obtain stp where
+    w_stp: "is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and>
+                 (\<exists>n kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <n::nat> @ Bk \<up> lr))"
+    by blast
+
+  then have "(\<exists>n kr lr. steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <n::nat> @ Bk \<up> lr))"
+    by auto
+
+  then obtain n kr lr where "steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <n::nat> @ Bk \<up> lr)"
+    by blast
+  then have "steps0 (1, ([], <ns::nat list>)) p stp = (0, Bk \<up> kr, <[n::nat]> @ Bk \<up> lr)"
+    by (simp add: tape_of_list_def)
+  then have "is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and> (\<exists>kr lr. (steps0 (1, ([], <ns::nat list>)) p stp) = (0, Bk \<up> kr, <[n::nat]> @ Bk \<up> lr))"
+    by (simp add: is_final_eq)
+
+  then have "is_final (steps0 (1, ([], <ns::nat list>)) p stp) \<and> (\<exists>ms kr lr. (steps0 (1, ([], <ns::nat list>)) p stp) = (0, Bk \<up> kr, <ms::nat list> @ Bk \<up> lr))"
+    by blast
+
+  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>kr ms lr. tap = (Bk \<up> kr, <ms::nat list> @ Bk \<up> lr)\<rbrace>"
+    by (metis (mono_tags, lifting) Hoare_halt_def  holds_for.simps)
+qed
+
+corollary TMC_has_num_res_imp_TMC_has_num_list_res': "TMC_has_num_res p ns \<Longrightarrow> TMC_has_num_list_res p ns"
+  unfolding TMC_has_num_res_def TMC_has_num_list_res_def 
+  using TMC_has_num_res_imp_TMC_has_num_list_res
+  by auto
+
+
+subsubsection \<open>Convenience Lemmas for Halting Problems \<close>
+
+lemma Hoare_halt_with_Oc_imp_std_tap:
+  assumes "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
+  shows "TMC_has_num_res p ns"
+  unfolding TMC_has_num_res_def
+proof -
+  from assms have F0: "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>"
+    by (auto simp add: tape_of_nat_def)
+  show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+  by (smt F0 Hoare_halt_E0 Hoare_halt_I0)
+qed
+
+lemma Hoare_halt_with_OcOc_imp_std_tap:
+  assumes "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
+  shows "TMC_has_num_res p ns"
+  unfolding TMC_has_num_res_def
+proof -
+  from assms have "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>"
+    by (auto simp add: tape_of_nat_def)
+  then show "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+ by (smt Hoare_haltE Hoare_haltI holds_for.elims(2) holds_for.simps)
+qed
+
+subsubsection \<open>Hoare\_halt on numeral lists with single numeral result\<close>
+(* For automation we use Hoare triples directly instead of the concept TMC_has_num_res.
+ * Reason: reduce number of theorems used by the simplifier.
+ *)
+
+lemma Hoare_halt_on_numeral_imp_result: (* special case of Hoare_halt_D *)
+  assumes "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)))\<rbrace>"
+  shows "\<exists>stp k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk\<up> l)"
+  using TMC_has_num_res_def TMC_has_num_res_iff assms by blast
+
+lemma Hoare_halt_on_numeral_imp_result_rev: (* special case of Hoare_halt_I2 *)
+  assumes "\<exists>stp k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk\<up> l)"
+  shows "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)))\<rbrace>"
+  using TMC_has_num_res_def TMC_has_num_res_iff assms is_final_eq by force
+
+lemma Hoare_halt_on_numeral_imp_result_iff: (* special case of Hoare_halt2_iff *)
+"\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)))\<rbrace>
+ \<longleftrightarrow>
+ (\<exists>stp k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk\<up> l))"
+  using Hoare_halt_on_numeral_imp_result Hoare_halt_on_numeral_imp_result_rev by blast
+
+subsubsection \<open>Hoare\_halt on numeral lists with numeral list result\<close>
+(* For automation we use Hoare triples directly instead of the concept TMC_has_num_list_res.
+ * Reason: reduce number of theorems used by the simplifier.
+ *)
+
+lemma Hoare_halt_on_numeral_imp_list_result: (* special case of Hoare_halt_D *)
+  assumes "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k ms l. tap = (Bk \<up> k, <ms::nat list> @ Bk \<up> l)))\<rbrace>"
+  shows "\<exists>stp k ms l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk\<up> l)"  
+  using TMC_has_num_list_res_def TMC_has_num_list_res_iff assms by blast
+
+lemma Hoare_halt_on_numeral_imp_list_result_rev: (* special case of Hoare_halt_I2 *)
+  assumes "\<exists>stp k ms l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk\<up> l)"
+  shows "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k ms l. tap = (Bk \<up> k, <ms::nat list> @ Bk \<up> l)))\<rbrace>"
+  by (metis (mono_tags, lifting) Hoare_haltI assms holds_for.simps is_finalI)
+
+lemma Hoare_halt_on_numeral_imp_list_result_iff: (* special case of Hoare_halt2_iff *)
+  "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace>(\<lambda>tap. (\<exists>k ms l. tap = (Bk \<up> k, <ms::nat list> @ Bk \<up> l)))\<rbrace>
+   \<longleftrightarrow>
+   (\<exists>stp k ms l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <ms::nat list> @ Bk\<up> l))"  
+  using Hoare_halt_on_numeral_imp_list_result Hoare_halt_on_numeral_imp_list_result_rev by blast
+
+subsection \<open>Trailing left blanks do not matter for computations with result\<close>
+
+(* adding trailing blanks on the initial left tape needs tough lemmas (see BlanksDoNotMatter)  *)
+
+lemma TMC_has_num_res_NIL_impl_TMC_has_num_res_with_left_BKs:
+  "\<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>
+   \<Longrightarrow>
+   \<lbrace>(\<lambda>tap. \<exists>z. tap = (Bk\<up>z, <ns>))\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+proof -
+  assume   "\<lbrace>\<lambda>tap. tap = ([], <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+  then have "\<exists>stp k n l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk\<up> l)"
+    by (rule Hoare_halt_on_numeral_imp_result)
+
+  then obtain n where "\<exists>stp k l. steps0 (1, [],<ns::nat list>) p stp = (0, Bk \<up> k, <n::nat> @ Bk\<up> l)" by blast
+
+  then have "\<forall>z. \<exists>stp k l. (steps0 (1, (Bk\<up>z, <ns::nat list>)) p stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l)"
+    by (rule ex_steps_left_tape_Nil_imp_All)
+
+  then have "\<lbrace>(\<lambda>tap. \<exists>z. tap = (Bk\<up>z, <ns::nat list>))\<rbrace> p \<lbrace> (\<lambda>tap. (\<exists>k l. tap = (Bk \<up> k,  <n::nat> @ Bk \<up> l))) \<rbrace>"
+    by (rule Hoare_halt_add_Bks_left_tape_L2)
+    
+  then show "\<lbrace>\<lambda>tap. \<exists>z. tap = (Bk \<up> z, <ns::nat list>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)\<rbrace>"
+    using Hoare_halt_iff \<open>\<forall>z. \<exists>stp k l. steps0 (1, Bk \<up> z, <ns>) p stp = (0, Bk \<up> k, <n> @ Bk \<up> l)\<close> by fastforce
+qed
+
+(* removing trailing blanks on the initial left tape (is easy) *)
+
+corollary TMC_has_num_res_NIL_iff_TMC_has_num_res_with_left_BKs:
+  " \<lbrace>(\<lambda>tap. tap = ([], <ns::nat list>))\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>
+    \<longleftrightarrow>
+    \<lbrace>(\<lambda>tap. \<exists>z. tap = (Bk\<up>z, <ns>))\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+proof
+  assume "\<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+  then show "\<lbrace>\<lambda>tap. \<exists>z. tap = (Bk \<up> z, <ns>)\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+    using TMC_has_num_res_NIL_impl_TMC_has_num_res_with_left_BKs by blast
+next
+  assume "\<lbrace>\<lambda>tap. \<exists>z. tap = (Bk \<up> z, <ns>)\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+  then show "\<lbrace>\<lambda>tap. tap = ([], <ns>)\<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+    by (simp add: Hoare_halt_def assert_imp_def)
+qed
+
+subsection \<open>About Turing Computations and the result they yield\<close>
+
+definition TMC_yields_num_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool"
+  where "TMC_yields_num_res tm ns n \<equiv> (\<exists>stp k l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
+
+definition TMC_yields_num_list_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> nat list \<Rightarrow> bool"
+  where "TMC_yields_num_list_res tm ns ms \<equiv> (\<exists>stp k l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <ms::nat list> @ Bk \<up> l))"
+
+(* This is for documentation and explanation: TMC_yields_num_res_unfolded_into_Hoare_halt *)
+lemma TMC_yields_num_res_unfolded_into_Hoare_halt:
+  "TMC_yields_num_res tm ns n \<equiv> \<lbrace>(\<lambda>tap. tap = ([], <ns>))\<rbrace> tm \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk\<up> l))\<rbrace>"
+  by (smt Hoare_halt_iff TMC_yields_num_res_def)
+
+(* This is for documentation and explanation: TMC_yields_num_list_res_unfolded_into_Hoare_halt *)
+lemma TMC_yields_num_list_res_unfolded_into_Hoare_halt:
+  "TMC_yields_num_list_res tm ns ms \<equiv> \<lbrace>(\<lambda>tap. tap = ([], <ns>))\<rbrace> tm \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <ms::nat list> @ Bk\<up> l))\<rbrace>"
+  by (smt Hoare_halt_iff TMC_yields_num_list_res_def)
+
+
+(* A variant of rule Hoare_plus_halt using TMC_yields_num_list_res and TMC_yields_num_res *)
+lemma TMC_yields_num_res_Hoare_plus_halt:
+  assumes "TMC_yields_num_list_res tm1 nl r1"
+    and "TMC_yields_num_res tm2 r1 r2"
+    and "composable_tm0 tm1"
+  shows "TMC_yields_num_res (tm1 |+| tm2) nl r2"
+proof -
+  from assms
+  have "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace> tm1 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <r1::nat list> @ Bk \<up> l)\<rbrace>"
+    using TMC_yields_num_list_res_unfolded_into_Hoare_halt 
+    by auto
+  moreover from assms
+  have "\<lbrace>\<lambda>tap. tap = ([], <r1>)\<rbrace> tm2 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <r2> @ Bk \<up> l)\<rbrace>"
+    using TMC_yields_num_res_unfolded_into_Hoare_halt
+      Hoare_halt_def Hoare_halt_iff TMC_yields_num_res_def by blast
+  ultimately
+  have "\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> (tm1 |+| tm2) \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <r2> @ Bk \<up> l)\<rbrace>"  
+    using \<open>composable_tm0 tm1\<close>
+    using Hoare_halt_left_tape_Nil_imp_All_left_and_right Hoare_plus_halt 
+    by (simp add: tape_of_list_def)
+  then show ?thesis
+    using TMC_yields_num_res_unfolded_into_Hoare_halt by auto
+qed
+
+
+(*
+
+ TODO test mixfix notation for TMC_yields_num_res:  \<llangle>tm: ns \<mapsto> n\<rrangle> 
+ TODO test mixfix notation for TMC_has_num_res:     \<llangle>tm: ns\<down>\<rrangle> 
+ 
+    Trial for notation of TMC_yields_num_res tm ns n: 
+    
+      "TMC_yields_num_res tm ns n \<equiv> (\<exists>stp k l. (steps0 (1, ([], <ns::nat list>)) tm stp) = (0, Bk \<up> k, <n::nat> @ Bk \<up> l))"
+    
+         ns \<midarrow><tm>\<rightarrow> n
+    
+         \<llangle>tm: ns \<leadsto> n\<rrangle>   that's good
+    
+         \<llangle>tm: ns \<mapsto> n\<rrangle>   that's good as well
+         
+     TMC_has_num_res 
+    
+      "TMC_has_num_res p ns \<equiv> \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
+    
+         \<llangle>tm: ns\<down>\<rrangle> 
+
+ *)
+
+end
diff --git a/thys/Universal_Turing_Machine/Turing_Hoare.thy b/thys/Universal_Turing_Machine/Turing_Hoare.thy
--- a/thys/Universal_Turing_Machine/Turing_Hoare.thy
+++ b/thys/Universal_Turing_Machine/Turing_Hoare.thy
@@ -1,162 +1,664 @@
 (* Title: thys/Turing_Hoare.thy
    Author: Jian Xu, Xingyuan Zhang, and Christian Urban
    Modifications: Sebastiaan Joosten
-*)
+ 
+   Modifications, comments by Franz Regensburger (FABR) 02/2022
+ *)
 
-chapter \<open>Hoare Rules for TMs\<close>
+section \<open>Hoare Rules for Turing Machines\<close>
 
 theory Turing_Hoare
-  imports Turing
+  imports Numerals
 begin
 
 
+subsection \<open>Hoare\_halt and Hoare\_unhalt for total correctness\<close>
+
+subsubsection \<open>Definition for Hoare\_halt and Hoare\_unhalt conditions\<close>
+
 type_synonym assert = "tape \<Rightarrow> bool"
 
 definition 
   assert_imp :: "assert \<Rightarrow> assert \<Rightarrow> bool" ("_ \<mapsto> _" [0, 0] 100)
   where
     "P \<mapsto> Q \<equiv> \<forall>l r. P (l, r) \<longrightarrow> Q (l, r)"
 
 lemma refl_assert[intro, simp]:
   "P \<mapsto> P"
   unfolding assert_imp_def by simp
 
+(* Purpose of the function holds_for:
+ * We do not need to apply the selector snd on a configuration c if
+ * we just like to apply a predicate to the tape component of the configuration.
+ * 
+ * We may write 
+ *   Q holds_for c
+ *  instead of
+ *   Q (snd c)
+ *)
+
 fun 
   holds_for :: "(tape \<Rightarrow> bool) \<Rightarrow> config \<Rightarrow> bool" ("_ holds'_for _" [100, 99] 100)
   where
     "P holds_for (s, l, r) = P (l, r)"  
 
 lemma is_final_holds[simp]:
   assumes "is_final c"
   shows "Q holds_for (steps c p n) = Q holds_for c"
   using assms 
   by(induct n;cases c,auto)
 
-(* Hoare Rules *)
+(* Hoare notation and rules for total correctness *)
 
-(* halting case *)
+(* halting case:
+   If the pre-condition P holds for a tape
+   then the program p eventually reaches the final state 0 and
+   the post-condition holds for (the tape of) the final configuration.
+ *)
+
 definition
-  Hoare_halt :: "assert \<Rightarrow> tprog0 \<Rightarrow> assert \<Rightarrow> bool" ("({(1_)}/ (_)/ {(1_)})" 50)
+  Hoare_halt :: "assert \<Rightarrow> tprog0 \<Rightarrow> assert \<Rightarrow> bool" ("(\<lbrace>(1_)\<rbrace>/ (_)/ \<lbrace>(1_)\<rbrace>)" 50)
   where
-    "{P} p {Q} \<equiv> (\<forall>tp. P tp \<longrightarrow> (\<exists>n. is_final (steps0 (1, tp) p n) \<and> Q holds_for (steps0 (1, tp) p n)))"
+    "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace> \<equiv> (\<forall>tap. P tap \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) p n) \<and> Q holds_for (steps0 (1, tap) p n) ))"
 
-(* not halting case *)
+(* not halting case:
+   If the pre-condition P holds for a tape
+   then the program p never reaches the final state 0. 
+ *)
 definition
-  Hoare_unhalt :: "assert \<Rightarrow> tprog0 \<Rightarrow> bool" ("({(1_)}/ (_)) \<up>" 50)
+  Hoare_unhalt :: "assert \<Rightarrow> tprog0 \<Rightarrow> bool" ("(\<lbrace>(1_)\<rbrace>/ (_)) \<up>" 50)
   where
-    "{P} p \<up> \<equiv> \<forall>tp. P tp \<longrightarrow> (\<forall> n . \<not> (is_final (steps0 (1, tp) p n)))"
-
+    "\<lbrace>P\<rbrace> p \<up> \<equiv> \<forall>tap. P tap \<longrightarrow> (\<forall> n . \<not>(is_final (steps0 (1, tap) p n)))"
 
 lemma Hoare_haltI:
   assumes "\<And>l r. P (l, r) \<Longrightarrow> \<exists>n. is_final (steps0 (1, (l, r)) p n) \<and> Q holds_for (steps0 (1, (l, r)) p n)"
-  shows "{P} p {Q}"
+  shows "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>"
   unfolding Hoare_halt_def 
   using assms by auto
 
+lemma Hoare_haltE:
+  assumes "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>"
+  and "P (l, r)"
+shows "\<exists>n. is_final (steps0 (1, (l, r)) p n) \<and> Q holds_for (steps0 (1, (l, r)) p n)"
+  using assms by (auto simp add: Hoare_halt_def)
+
 lemma Hoare_unhaltI:
   assumes "\<And>l r n. P (l, r) \<Longrightarrow> \<not> is_final (steps0 (1, (l, r)) p n)"
-  shows "{P} p \<up>"
+  shows "\<lbrace>P\<rbrace> p \<up>"
   unfolding Hoare_unhalt_def 
-  using assms by auto
-
-
-
+  using assms 
+by auto
 
-text \<open>
-  {P} A {Q}   {Q} B {S}  A well-formed
-  -----------------------------------------
-  {P} A |+| B {S}
-\<close>
+lemma Hoare_unhaltE:
+  assumes "\<lbrace>P\<rbrace> p \<up>"
+  and  "P tap"
+shows "\<not> (is_final (steps0 (1, tap) p n))"
+proof
+  assume major: "is_final (steps0 (1, tap) p n)"
+  from assms(1) have "\<forall>tap. P tap \<longrightarrow> (\<forall> n . \<not> (is_final (steps0 (1, tap) p n)))"
+    by (auto simp add: Hoare_unhalt_def)
+  with assms(2) have "(\<forall> n . \<not> (is_final (steps0 (1, tap) p n)))" by blast
+  with major show "False" by auto
+qed
 
+(* Some alternative introduction and elimination rules without intermediate concept holds_for *)
+(* Added by FABR *)
 
-lemma Hoare_plus_halt [case_names A_halt B_halt A_wf]: 
-  assumes A_halt : "{P} A {Q}"
-    and B_halt : "{Q} B {S}"
-    and A_wf : "tm_wf (A, 0)"
-  shows "{P} A |+| B {S}"
+lemma Hoare_halt_iff:
+ "\<lbrace>P\<rbrace> tm \<lbrace>Q\<rbrace>
+   \<longleftrightarrow> 
+  (\<forall>l1 r1. P (l1,r1) \<longrightarrow> (\<exists>stp l0 r0.  steps0 (1, l1,r1) tm stp = (0,l0,r0) \<and> Q (l0,r0)))"
+  unfolding Hoare_halt_def
+proof
+  show " \<forall>tap. P tap \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n)
+         \<Longrightarrow> \<forall>l1 r1. P (l1, r1) \<longrightarrow> (\<exists>stp l0 r0. steps0 (1, l1, r1) tm stp = (0, l0, r0) \<and> Q (l0, r0))"
+    by (metis holds_for.elims(2) is_final.simps)
+next
+  show "\<forall>l1 r1. P (l1, r1) \<longrightarrow> (\<exists>stp l0 r0. steps0 (1, l1, r1) tm stp = (0, l0, r0) \<and> Q (l0, r0))
+         \<Longrightarrow> \<forall>tap. P tap \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n)"
+    by (metis before_final holds_for.simps is_finalI old.prod.exhaust)
+qed
+
+(* Use like this:
+
+    thm Hoare_halt_iff[THEN iffD1]
+    
+    \<lbrace>?P1\<rbrace> ?tm1 \<lbrace>?Q1\<rbrace>
+     \<Longrightarrow> \<forall>l1 r1. ?P1 (l1, r1) \<longrightarrow> (\<exists>stp l0 r0. steps0 (1, l1, r1) ?tm1 stp = (0, l0, r0) \<and> ?Q1 (l0, r0))
+    
+    thm Hoare_halt_iff[THEN iffD2]
+    
+    \<forall>l1 r1. ?P1 (l1, r1) \<longrightarrow> (\<exists>stp l0 r0. steps0 (1, l1, r1) ?tm1 stp = (0, l0, r0) \<and> ?Q1 (l0, r0))
+     \<Longrightarrow> \<lbrace>?P1\<rbrace> ?tm1 \<lbrace>?Q1\<rbrace>
+
+ *)
+
+lemma Hoare_halt_I0:
+assumes "\<And>l1 r1. P(l1, r1) \<Longrightarrow> steps0 (1, l1, r1) tm stp = (0, l0, r0) \<and> Q (l0, r0)"
+shows "\<lbrace>P\<rbrace> tm \<lbrace>Q\<rbrace>"
+  using assms Hoare_halt_iff[THEN iffD2]
+  by blast
+
+lemma Hoare_halt_E0:
+  assumes major: "\<lbrace>P\<rbrace> tm \<lbrace>Q\<rbrace>"
+and "P(l1, r1)"
+shows "\<exists>stp l0 r0. steps0 (1, l1, r1) tm stp = (0, l0, r0) \<and> Q(l0, r0)"
+  using assms Hoare_halt_iff[THEN iffD1]
+  by (auto simp add: Hoare_halt_def)
+
+(* Despite their triviality, the following lemmas explain our general approach in proving total correctness *)
+
+lemma partial_correctness_and_halts_imp_total_correctness': (* mind the parenthesis arround the premise *)
+  assumes partial_corr: "(\<exists>stp l1 r1. P (l1, r1) \<and>  is_final (steps0 (1, l1,r1) tm stp)) \<longrightarrow> \<lbrace>P\<rbrace> tm \<lbrace>Q\<rbrace>"
+  and halts: "(\<exists>stp l1 r1. P (l1, r1) \<and>  is_final (steps0 (1, l1,r1) tm stp))"
+shows "\<lbrace>P\<rbrace> tm \<lbrace>Q\<rbrace>"
+  using halts partial_corr by blast
+
+(* is the same as *)
+
+lemma partial_correctness_and_halts_imp_total_correctness:
+  assumes partial_corr: "\<forall>l1 r1 stp. P (l1, r1) \<and> is_final (steps0 (1, l1,r1) tm stp) \<longrightarrow> \<lbrace>P\<rbrace> tm \<lbrace>Q\<rbrace>"
+  and halts: "(\<exists>stp l1 r1. P (l1, r1) \<and>  is_final (steps0 (1, l1,r1) tm stp))"
+shows "\<lbrace>P\<rbrace> tm \<lbrace>Q\<rbrace>"
+  using halts partial_corr by blast
+
+(* because of simple predicate logic *)
+
+lemma "( (\<exists>stp l1 r1. P (l1, r1) \<and>  is_final (steps0 (1, l1,r1) tm stp)) \<longrightarrow> \<lbrace>P\<rbrace> tm \<lbrace>Q\<rbrace> )
+       \<longleftrightarrow>
+       (  \<forall>stp l1 r1. (P (l1, r1) \<and> is_final (steps0 (1, l1,r1) tm stp)  \<longrightarrow> \<lbrace>P\<rbrace> tm \<lbrace>Q\<rbrace>)  )"
+  by blast
+
+(* --- *)
+
+lemma Hoare_consequence:
+  assumes "P' \<mapsto> P" "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>" "Q \<mapsto> Q'"
+  shows "\<lbrace>P'\<rbrace> p \<lbrace>Q'\<rbrace>"
+  using assms
+  unfolding Hoare_halt_def assert_imp_def
+  by (metis holds_for.simps surj_pair)
+
+subsubsection \<open>Relation between Hoare\_halt and Hoare\_unhalt\<close>
+
+lemma Hoare_halt_impl_not_Hoare_unhalt:
+  assumes "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>" and "P tap"
+  shows "\<not>(\<lbrace>P\<rbrace> p \<up>)"
+proof
+  assume "\<lbrace>P\<rbrace> p \<up>"
+  then have "\<forall>tap. P tap \<longrightarrow> (\<forall> n . \<not> (is_final (steps0 (1, tap) p n)))"
+    by (auto simp add: Hoare_unhalt_def)
+  with \<open>P tap\<close> have L1: "(\<forall> n . \<not> (is_final (steps0 (1, tap) p n)))" by blast
+  from assms have "(\<forall>tap. P tap \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) p n) \<and> Q holds_for (steps0 (1, tap) p n) ))"
+    by (auto simp add: Hoare_halt_def)
+  with \<open>P tap\<close> have "(\<exists>n. is_final (steps0 (1, tap) p n) \<and> Q holds_for (steps0 (1, tap) p n) )"
+    by blast
+  then obtain n where w_n: "is_final (steps0 (1, tap) p n) \<and> Q holds_for (steps0 (1, tap) p n)" by blast
+  then have "is_final (steps0 (1, tap) p n)" by auto
+  with L1 show False by auto
+qed
+
+lemma Hoare_unhalt_impl_not_Hoare_halt:
+  assumes "\<lbrace>P\<rbrace> p \<up>" and "P tap"
+  shows "\<not>(\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>)"
+proof 
+  assume "\<lbrace>P\<rbrace> p \<lbrace>Q\<rbrace>"
+  then have
+    "(\<forall>tap. P tap \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) p n) \<and> Q holds_for (steps0 (1, tap) p n) ))"
+    by (auto simp add: Hoare_halt_def)
+  with \<open>P tap\<close> have "(\<exists>n. is_final (steps0 (1, tap) p n) \<and> Q holds_for (steps0 (1, tap) p n) )"
+    by blast
+  then obtain n where w_n: "is_final (steps0 (1, tap) p n) \<and> Q holds_for (steps0 (1, tap) p n)" by blast
+  then have L1: "is_final (steps0 (1, tap) p n)" by auto
+  from assms have "\<forall>tap. P tap \<longrightarrow> (\<forall> n . \<not> (is_final (steps0 (1, tap) p n)))"
+    by (auto simp add: Hoare_unhalt_def)
+  with \<open>P tap\<close> have "\<not> (is_final (steps0 (1, tap) p n))" by blast
+  with L1 show False by auto
+qed
+
+subsubsection \<open>Hoare\_halt and Hoare\_unhalt for composed Turing Machines\<close>
+
+(*
+    Note: "composable_tm (A, 0)" means: A is a composable Turing program
+
+    \<lbrace>P\<rbrace> A \<lbrace>Q\<rbrace>   \<lbrace>Q\<rbrace> B \<lbrace>S\<rbrace>   (A is composable)
+    ----------------------------------------
+               \<lbrace>P\<rbrace> A |+| B \<lbrace>S\<rbrace>
+*)
+
+lemma Hoare_plus_halt [case_names A_halt B_halt A_composable]: 
+  assumes A_halt : "\<lbrace>P\<rbrace> A \<lbrace>Q\<rbrace>"
+    and B_halt : "\<lbrace>Q\<rbrace> B \<lbrace>S\<rbrace>"
+    and A_composable : "composable_tm (A, 0)"
+  shows "\<lbrace>P\<rbrace> A |+| B \<lbrace>S\<rbrace>"
 proof(rule Hoare_haltI)
   fix l r
   assume h: "P (l, r)"
   then obtain n1 l' r' 
     where "is_final (steps0 (1, l, r) A n1)"  
       and a1: "Q holds_for (steps0 (1, l, r) A n1)"
       and a2: "steps0 (1, l, r) A n1 = (0, l', r')"
     using A_halt unfolding Hoare_halt_def
     by (metis is_final_eq surj_pair) 
   then obtain n2 
     where "steps0 (1, l, r) (A |+| B) n2 = (Suc (length A div 2), l', r')"
-    using A_wf by (rule_tac tm_comp_next) 
+    using A_composable by (rule_tac seq_tm_next) 
   moreover
   from a1 a2 have "Q (l', r')" by (simp)
   then obtain n3 l'' r''
     where "is_final (steps0 (1, l', r') B n3)" 
       and b1: "S holds_for (steps0 (1, l', r') B n3)"
       and b2: "steps0 (1, l', r') B n3 = (0, l'', r'')"
     using B_halt unfolding Hoare_halt_def 
     by (metis is_final_eq surj_pair) 
   then have "steps0 (Suc (length A div 2), l', r')  (A |+| B) n3 = (0, l'', r'')"
-    using A_wf by (rule_tac tm_comp_final) 
+    using A_composable by (rule_tac seq_tm_final) 
   ultimately show 
     "\<exists>n. is_final (steps0 (1, l, r) (A |+| B) n) \<and> S holds_for (steps0 (1, l, r) (A |+| B) n)"
     using b1 b2 by (rule_tac x = "n2 + n3" in exI) (simp)
 qed
 
-text \<open>
-  {P} A {Q}   {Q} B loops   A well-formed
-  ------------------------------------------
-          {P} A |+| B  loops
-\<close>
+(*
+    \<lbrace>P\<rbrace> A \<lbrace>Q\<rbrace>   \<lbrace>Q\<rbrace> B loops   (A is composable)
+    ------------------------------------------
+              \<lbrace>P\<rbrace> A |+| B  loops
+*)
 
-lemma Hoare_plus_unhalt [case_names A_halt B_unhalt A_wf]:
-  assumes A_halt: "{P} A {Q}"
-    and B_uhalt: "{Q} B \<up>"
-    and A_wf : "tm_wf (A, 0)"
-  shows "{P} (A |+| B) \<up>"
+lemma Hoare_plus_unhalt [case_names A_halt B_unhalt A_composable]:
+  assumes A_halt: "\<lbrace>P\<rbrace> A \<lbrace>Q\<rbrace>"
+    and B_uhalt: "\<lbrace>Q\<rbrace> B \<up>"
+    and A_composable : "composable_tm (A, 0)"
+  shows "\<lbrace>P\<rbrace> (A |+| B) \<up>"
 proof(rule_tac Hoare_unhaltI)
   fix n l r 
   assume h: "P (l, r)"
   then obtain n1 l' r'
     where a: "is_final (steps0 (1, l, r) A n1)" 
       and b: "Q holds_for (steps0 (1, l, r) A n1)"
       and c: "steps0 (1, l, r) A n1 = (0, l', r')"
     using A_halt unfolding Hoare_halt_def 
     by (metis is_final_eq surj_pair) 
   then obtain n2 where eq: "steps0 (1, l, r) (A |+| B) n2 = (Suc (length A div 2), l', r')"
-    using A_wf by (rule_tac tm_comp_next)
+    using A_composable by (rule_tac seq_tm_next)
   then show "\<not> is_final (steps0 (1, l, r) (A |+| B) n)"
   proof(cases "n2 \<le> n")
     case True
     from b c have "Q (l', r')" by simp
     then have "\<forall> n. \<not> is_final (steps0 (1, l', r') B n)  "
       using B_uhalt unfolding Hoare_unhalt_def by simp
     then have "\<not> is_final (steps0 (1, l', r') B (n - n2))" by auto
     then obtain s'' l'' r'' 
       where "steps0 (1, l', r') B (n - n2) = (s'', l'', r'')" 
         and "\<not> is_final (s'', l'', r'')" by (metis surj_pair)
     then have "steps0 (Suc (length A div 2), l', r') (A |+| B) (n - n2) = (s''+ length A div 2, l'', r'')"
-      using A_wf by (auto dest: tm_comp_second simp del: tm_wf.simps)
+      using A_composable by (auto dest: seq_tm_second simp del: composable_tm.simps)
     then have "\<not> is_final (steps0 (1, l, r) (A |+| B) (n2 + (n  - n2)))"
-      using A_wf by (simp only: steps_add eq) simp
+      using A_composable by (simp only: steps_add eq) simp
     then show "\<not> is_final (steps0 (1, l, r) (A |+| B) n)" 
       using \<open>n2 \<le> n\<close> by simp
   next 
     case False
     then obtain n3 where "n = n2 - n3"
       using diff_le_self le_imp_diff_is_add nat_le_linear
         add.commute by metis
     moreover
     with eq show "\<not> is_final (steps0 (1, l, r) (A |+| B) n)"
       by (simp add: not_is_final[where ?n1.0="n2"])
   qed
 qed
 
-lemma Hoare_consequence:
-  assumes "P' \<mapsto> P" "{P} p {Q}" "Q \<mapsto> Q'"
-  shows "{P'} p {Q'}"
-  using assms
-  unfolding Hoare_halt_def assert_imp_def
-  by (metis holds_for.simps surj_pair)
+subsection \<open>Trailing Blanks on the left tape do not matter for Hoare\_halt\<close>
+
+text \<open>The following theorems have major impact on the definition of Turing Computability.\<close>
+
+lemma Hoare_halt_add_Bks_left_tape_L1:
+  assumes "\<lbrace> \<lambda>tap. tap = ([], r)\<rbrace> p \<lbrace> (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k,  CR @ Bk \<up> l)) \<rbrace>"
+  shows   "\<forall>z. \<exists>stp k l. (steps0 (1, Bk\<up>z,r) p stp) = (0, Bk \<up> k, CR @ Bk \<up> l)"
+proof -
+  from assms
+  have "\<exists>stp. is_final (steps0 (1, [], r) p stp) \<and> (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, CR @ Bk \<up> l)) holds_for steps0 (1, [], r) p stp"
+    using Hoare_haltE[OF assms] by auto
+  then obtain stp where
+    w: "is_final (steps0 (1, [], r) p stp) \<and> (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, CR @ Bk \<up> l)) holds_for steps0 (1, [], r) p stp" by blast
+  then have  "\<exists>k  l. snd(steps0 (1, [], r) p stp) = (Bk \<up> k, CR @ Bk \<up> l)"
+  proof (cases " steps0 (1, [], r) p stp")
+    case (fields s' l' r')
+    then have "steps0 (1, [], r) p stp = (s', l', r')" .
+    then show ?thesis
+      using w holds_for.simps snd_conv by auto
+  qed
+  moreover from w have "fst (steps0 (1, [], r) p stp) = 0"
+    by (metis is_final_eq surjective_pairing)
+  ultimately have "\<exists>stp k l. steps0 (1, [], r) p stp = (0, Bk \<up> k, CR @ Bk \<up> l)"
+    by (metis surjective_pairing)
+  then have "\<forall>z. \<exists>stp k l. (steps0 (1, (Bk\<up>z, r)) p stp) = (0, Bk \<up> k, CR @ Bk \<up> l)"
+    using steps_left_tape_Nil_imp_All 
+    by blast
+  then show ?thesis
+    by blast
+qed
+
+lemma Hoare_halt_add_Bks_left_tape_L2:
+  assumes "\<forall>z. \<exists>stp k l. (steps0 (1, Bk\<up>z,r) p stp) = (0, Bk \<up> k, CR @ Bk \<up> l)"
+  shows "\<lbrace>(\<lambda>tap. \<exists>z. tap = (Bk\<up>z, r))\<rbrace> p \<lbrace> (\<lambda>tap. (\<exists>k l. tap = (Bk \<up> k,  CR @ Bk \<up> l))) \<rbrace>"
+  unfolding Hoare_halt_def
+proof 
+  fix tap
+  show "(\<exists>z. tap = (Bk \<up> z, r)) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) p n) \<and>
+                                   (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, CR @ Bk \<up> l)) holds_for steps0 (1, tap) p n)"
+  proof
+    assume A: "\<exists>z. tap = (Bk \<up> z, r)"
+    from assms have B: "\<And>z. \<exists>stp k l. steps0 (1, Bk \<up> z, r) p stp = (0, Bk \<up> k, CR @ Bk \<up> l)" by blast
+    from A obtain z2 where w_z: "tap = (Bk \<up> z2, r)" by blast
+    from B obtain stp k l where w: "(steps0 (1, (Bk\<up>z2, r)) p stp) = (0, Bk \<up> k, CR @ Bk \<up> l)"
+      by blast
+
+    show "\<exists>n. is_final (steps0 (1, tap) p n) \<and> (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, CR @ Bk \<up> l)) holds_for steps0 (1, tap) p n"
+    proof
+      show "is_final (steps0 (1, tap) p stp) \<and> (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, CR @ Bk \<up> l)) holds_for steps0 (1, tap) p stp"
+      proof
+        from w and w_z       
+        show "is_final (steps0 (1, tap) p stp)" by (auto simp add: is_final_eq)
+      next
+        from w and w_z show "(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, CR @ Bk \<up> l)) holds_for steps0 (1, tap) p stp"
+          by auto
+      qed
+    qed
+  qed
+qed
+
+theorem Hoare_halt_add_Bks_left_tape:
+  "\<lbrace>(\<lambda>tap.     tap = ([]  , r))\<rbrace> p \<lbrace> (\<lambda>tap. (\<exists>k l. tap = (Bk \<up> k,  CR @ Bk \<up> l))) \<rbrace>
+  \<Longrightarrow>
+   \<forall>z.  \<lbrace>(\<lambda>tap. tap = (Bk\<up>z, r))\<rbrace> p \<lbrace> (\<lambda>tap. (\<exists>k l. tap = (Bk \<up> k,  CR @ Bk \<up> l))) \<rbrace>"
+  using Hoare_halt_add_Bks_left_tape_L1 Hoare_halt_add_Bks_left_tape_L2
+  by (simp add: Hoare_haltI  Hoare_halt_def Pair_inject old.prod.exhaust )
+
+theorem Hoare_halt_del_Bks_left_tape:
+  "\<lbrace>(\<lambda>tap. \<exists>z. tap = (Bk\<up>z, r))\<rbrace> p \<lbrace> (\<lambda>tap. (\<exists>k l. tap = (Bk \<up> k,  CR @ Bk \<up> l))) \<rbrace>
+  \<Longrightarrow>
+   \<lbrace>(\<lambda>tap.     tap = ([]  , r))\<rbrace> p \<lbrace> (\<lambda>tap. (\<exists>k l. tap = (Bk \<up> k,  CR @ Bk \<up> l))) \<rbrace>"
+  unfolding Hoare_halt_def
+  by auto
+
+(* Hoare unhalt *)
+
+lemma is_final_del_Bks: "is_final (steps0 (s, Bk \<up> k, r) tm stp) \<Longrightarrow> is_final (steps0 (s, [], r) tm stp)"
+proof (cases k)
+  assume "is_final (steps0 (s, Bk \<up> k, r) tm stp)"
+    and "k=0"
+  case 0
+  then show ?thesis
+    using \<open>is_final (steps0 (s, Bk \<up> k, r) tm stp)\<close> replicate_0 by auto
+next
+  fix nat
+  assume A: "is_final (steps0 (s, Bk \<up> k, r) tm stp)" and "k = Suc nat"
+  then have B: "0 <k" by auto
+  have "\<exists> l' r'. (steps0 (s, Bk \<up> k, r) tm stp) = (0, l', r')"
+  proof (cases "steps0 (s, Bk \<up> k, r) tm stp")
+    case (fields a b c)
+    then show ?thesis
+      using A is_final_eq by auto
+  qed
+  then obtain l' r' where w: "steps0 (s, Bk \<up> k, r) tm stp = (0, l', r')" by blast
+  then have "steps0 (s, []@Bk \<up> k, r) tm stp = (0, l', r')" by auto
+
+  with B have "\<exists>zb CL'. l' = CL'@Bk\<up>zb  \<and> steps0 (s,[], r) tm stp = (0,CL',r')"
+    using steps_left_tape_ShrinkBkCtx_arbitrary_CL
+    by auto
+  then obtain zb CL' where "l' = CL'@Bk\<up>zb  \<and> steps0 (s,[], r) tm stp = (0,CL',r')" by blast
+  then show ?thesis by auto
+qed
+
+lemma Hoare_unhalt_add_Bks_left_tape_L1:
+  assumes "\<lbrace>\<lambda>tap. tap = ([], r)\<rbrace> p \<up>"
+  shows "\<forall>z. \<lbrace>\<lambda>tap. tap = (Bk \<up> z, r)\<rbrace> p \<up>"
+proof -
+  from assms have "\<And>stp. \<not> is_final (steps0 (1, [], r) p stp)"
+    using Hoare_unhaltE[OF assms] by auto
+  then have "\<And>stp z. \<not> is_final (steps0 (1, Bk \<up> z, r) p stp)"
+    using is_final_del_Bks
+    by blast
+  then show ?thesis
+    by (simp add: Hoare_unhaltI Hoare_unhalt_def)
+qed
+
+subsection \<open>Halt lemmas with respect to function mk\_composable0\<close>
+
+theorem Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list: "\<lbrace>\<lambda>tap. tap = ([], cl)\<rbrace> tm \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], cl)\<rbrace> mk_composable0 tm \<lbrace>Q\<rbrace>" 
+  unfolding Hoare_halt_def
+proof -
+  assume A: "\<forall>tap. (tap = ([], cl)) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n)"
+  show "\<forall>tap. (tap = ([], cl)) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, tap) (mk_composable0 tm) n)"
+  proof
+    fix tap
+    show "(tap = ([], cl)) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, tap) (mk_composable0 tm) n)"
+    proof
+      assume "tap = ([], cl)"
+      with A have "(\<exists>n. is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n)"
+        by auto
+      then obtain n where w_n: "is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n"
+        by blast
+
+      with \<open>tap = ([], cl)\<close> have w_n': "is_final (steps0 (1, [], cl) tm n) \<and> Q holds_for steps0 (1, [], cl) tm n" by auto
+
+      have "\<exists>n. is_final (steps0 (1, [], cl) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, [], cl) (mk_composable0 tm) n"
+
+      proof (cases "\<forall>stp. steps0 (1,[],cl) (mk_composable0 tm) stp = steps0 (1,[], cl) tm stp")
+        case True
+        with w_n' have "is_final (steps0 (1, [], cl) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, [], cl) (mk_composable0 tm) n" by auto
+        then show ?thesis by auto
+      next
+        case False
+        then have "\<exists>stp. steps0 (1, [], cl) (mk_composable0 tm) stp \<noteq> steps0 (1, [], cl) tm stp" by blast
+        then obtain stp where w_stp: "steps0 (1, [], cl) (mk_composable0 tm) stp \<noteq> steps0 (1, [], cl) tm stp" by blast
+
+        show "\<exists>m. is_final (steps0 (1, [], cl) (mk_composable0 tm) m) \<and> Q holds_for steps0 (1, [], cl) (mk_composable0 tm) m"
+        proof -
+          from w_stp have F0: "0 < stp \<and>
+                           (\<exists>fl fr.
+                                   snd (steps0 (1, [], cl) tm stp) = (fl, fr) \<and>
+                                   (\<forall>i < stp. steps0 (1, [], cl) (mk_composable0 tm) i = steps0 (1, [], cl) tm i) \<and>
+                                   (\<forall>j > stp. steps0 (1, [], cl) tm (j) = (0, fl, fr) \<and> 
+                                              steps0 (1, [], cl) (mk_composable0 tm) j =(0, fl, fr)))"
+            by (rule mk_composable0_tm_at_most_one_diff')
+
+          from F0 have "0 < stp" by auto
+
+          from F0 obtain fl fr where w_fl_fr: "snd (steps0 (1, [], cl) tm stp) = (fl, fr) \<and>
+                                   (\<forall>i < stp. steps0 (1, [], cl) (mk_composable0 tm) i = steps0 (1, [], cl) tm i) \<and>
+                                   (\<forall>j > stp. steps0 (1, [], cl) tm (j) = (0, fl, fr) \<and> 
+                                              steps0 (1, [], cl) (mk_composable0 tm) j =(0, fl, fr))" by blast
 
 
+          have "steps0 (1, [], cl) tm (stp+1) = steps0 (1, [], cl) tm  n"
+          proof (cases "steps0 (1, [], cl) tm n")
+            case (fields fsn fln frn)
+            then have "steps0 (1, [], cl) tm n = (fsn, fln, frn)" .
+            with w_n' have "is_final (fsn, fln, frn)" by auto
+            with is_final_eq have "fsn=0" by auto
+            with \<open>steps0 (1, [], cl) tm n = (fsn, fln, frn)\<close>  have "steps0 (1, [], cl) tm n = (0, fln, frn)" by auto
 
-end
\ No newline at end of file
+            show "steps0 (1, [], cl) tm (stp + 1) = steps0 (1, [], cl) tm n"
+            proof (cases "n \<le> stp+1")
+              case True
+              then have "n \<le> stp + 1" .
+              show ?thesis
+              proof -
+                from \<open>steps0 (1, [], cl) tm n = (0, fln, frn)\<close> and \<open>n \<le> stp + 1\<close> have "steps0 (1, [], cl) tm (stp+1) = (0, fln, frn)"
+                  by (rule stable_config_after_final_ge_2')
+                with \<open>fsn=0\<close> and \<open>steps0 (1, [], cl) tm n = (fsn, fln, frn)\<close> show ?thesis by auto
+              qed
+            next
+              case False
+              then have "stp + 1 \<le> n" by arith
+              show ?thesis
+              proof -
+                from w_fl_fr have "steps0 (1, [], cl) tm (stp+1) = (0, fl, fr)" by auto
+                have "steps0 (1, [], cl) tm n = (0, fl, fr)"
+                proof (rule stable_config_after_final_ge_2')
+                  from \<open>steps0 (1, [], cl) tm (stp+1) = (0, fl, fr)\<close> show "steps0 (1, [], cl) tm (stp+1) = (0, fl, fr)" by auto
+                next
+                  from \<open>stp + 1 \<le> n\<close> show "stp + 1 \<le> n" .
+                qed
+                with \<open>steps0 (1, [], cl) tm (stp+1) = (0, fl, fr)\<close> show ?thesis by auto
+              qed
+            qed
+          qed
+
+          with w_n' have "is_final(steps0 (1, [], cl) tm (stp+1)) \<and> Q holds_for steps0 (1, [], cl) tm (stp+1)" by auto
+          moreover from w_fl_fr have "steps0 (1, [], cl) tm (stp+1) = steps0 (1, [], cl) (mk_composable0 tm) (stp+1)" by auto
+          ultimately have "is_final(steps0 (1, [], cl) (mk_composable0 tm) (stp+1)) \<and> Q holds_for steps0 (1, [], cl) (mk_composable0 tm) (stp+1)" by auto
+          then show ?thesis by blast
+        qed
+      qed
+      with \<open>tap = ([], cl)\<close> show "\<exists>n. is_final (steps0 (1, tap) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, tap) (mk_composable0 tm) n" by auto
+    qed
+  qed
+qed
+
+theorem Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list_rev: "\<lbrace>\<lambda>tap. tap = ([], cl)\<rbrace> mk_composable0 tm \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], cl)\<rbrace> tm \<lbrace>Q\<rbrace>" 
+  unfolding Hoare_halt_def
+proof -
+  assume A: "\<forall>tap. tap = ([], cl) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, tap) (mk_composable0 tm) n)"
+  show "\<forall>tap. tap = ([], cl) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n)"
+  proof
+    fix tap
+    show "(tap = ([], cl) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n))"
+    proof
+      assume "tap = ([], cl)"
+      with A have "(\<exists>n. is_final (steps0 (1, tap) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, tap) (mk_composable0 tm) n)"
+        by auto
+      then obtain n where w_n: "is_final (steps0 (1, tap) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, tap) (mk_composable0 tm) n"
+        by blast
+
+      with \<open>tap = ([], cl)\<close> have w_n': "is_final (steps0 (1, [], cl) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, [], cl) (mk_composable0 tm) n" by auto
+
+      have "\<exists>n. is_final (steps0 (1, [], cl) tm n) \<and> Q holds_for steps0 (1, [], cl) tm n"
+
+      proof (cases "\<forall>stp. steps0 (1,[],cl) (mk_composable0 tm) stp = steps0 (1,[], cl) tm stp")
+        case True
+        with w_n' have "is_final (steps0 (1, [], cl)  tm n) \<and> Q holds_for steps0 (1, [], cl)  tm n" by auto
+        then show ?thesis by auto
+      next
+        case False
+        then have "\<exists>stp. steps0 (1, [], cl) (mk_composable0 tm) stp \<noteq> steps0 (1, [], cl) tm stp" by blast
+        then obtain stp where w_stp: "steps0 (1, [], cl) (mk_composable0 tm) stp \<noteq> steps0 (1, [], cl) tm stp" by blast
+
+        show "\<exists>m. is_final (steps0 (1, [], cl) tm m) \<and> Q holds_for steps0 (1, [], cl) tm m"
+        proof -
+          from w_stp have F0: "0 < stp \<and>
+                           (\<exists>fl fr.
+                                   snd (steps0 (1, [], cl) tm stp) = (fl, fr) \<and>
+                                   (\<forall>i < stp. steps0 (1, [], cl) (mk_composable0 tm) i = steps0 (1, [], cl) tm i) \<and>
+                                   (\<forall>j > stp. steps0 (1, [], cl) tm (j) = (0, fl, fr) \<and> 
+                                              steps0 (1, [], cl) (mk_composable0 tm) j =(0, fl, fr)))"
+            by (rule mk_composable0_tm_at_most_one_diff')
+
+          from F0 have "0 < stp" by auto
+
+          from F0 obtain fl fr where w_fl_fr: "snd (steps0 (1, [], cl) tm stp) = (fl, fr) \<and>
+                                   (\<forall>i < stp. steps0 (1, [], cl) (mk_composable0 tm) i = steps0 (1, [], cl) tm i) \<and>
+                                   (\<forall>j > stp. steps0 (1, [], cl) tm (j) = (0, fl, fr) \<and> 
+                                              steps0 (1, [], cl) (mk_composable0 tm) j =(0, fl, fr))" by blast
+
+
+          have "steps0 (1, [], cl) (mk_composable0 tm) (stp+1) = steps0 (1, [], cl) (mk_composable0 tm)  n"
+            by (metis One_nat_def add_Suc_right is_final.elims(2) less_add_one nat_le_linear stable_config_after_final_ge w_fl_fr w_n')
+          with w_n' have "is_final(steps0 (1, [], cl) (mk_composable0 tm) (stp+1)) \<and> Q holds_for steps0 (1, [], cl) (mk_composable0 tm) (stp+1)" by auto
+          moreover from w_fl_fr have "steps0 (1, [], cl) tm (stp+1) = steps0 (1, [], cl) (mk_composable0 tm) (stp+1)" by auto
+          ultimately have "is_final(steps0 (1, [], cl)  tm (stp+1)) \<and> Q holds_for steps0 (1, [], cl) tm (stp+1)" by auto
+          then show ?thesis by blast
+        qed
+      qed
+      with \<open>tap = ([], cl)\<close> show "\<exists>n. is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n" by auto
+    qed
+  qed
+qed
+
+lemma Hoare_unhalt_tm_impl_Hoare_unhalt_mk_composable0_cell_list: "(\<lbrace>\<lambda>tap. tap = ([], cl )\<rbrace> tm \<up>) \<Longrightarrow> (\<lbrace>\<lambda>tap. tap = ([], cl) \<rbrace> (mk_composable0 tm) \<up>)" 
+  unfolding Hoare_unhalt_def
+proof -
+  assume A: " \<forall>tap. (tap = ([], cl)) \<longrightarrow> (\<forall>n. \<not> is_final (steps0 (1, tap) tm n))"
+  show  "\<forall>tap. (tap = ([], cl)) \<longrightarrow> (\<forall>n. \<not> is_final (steps0 (1, tap) (mk_composable0 tm) n))"
+  proof
+    fix tap
+    show "(tap = ([], cl)) \<longrightarrow> (\<forall>n. \<not> is_final (steps0 (1, tap) (mk_composable0 tm) n))"
+    proof
+      assume "tap = ([], cl)"
+      with A have B: "\<forall>n. \<not> is_final (steps0 (1, tap) tm n)" by auto
+
+      show "\<forall>n. \<not> is_final (steps0 (1, tap) (mk_composable0 tm) n)"
+      proof (cases "\<forall>stp. steps0 (1,[], cl) (mk_composable0 tm) stp = steps0 (1,[], cl) tm stp")
+        case True
+        then have "\<forall>stp. steps0 (1, [], cl) (mk_composable0 tm) stp = steps0 (1, [], cl) tm stp" .
+        show ?thesis
+        proof
+          fix n
+
+          from \<open>\<forall>stp. steps0 (1, [], cl) (mk_composable0 tm) stp = steps0 (1, [], cl) tm stp\<close>
+          have "steps0 (1, [], cl) (mk_composable0 tm) n = steps0 (1, [], cl) tm n" by auto
+          moreover from B and \<open>tap = ([], cl)\<close> have "\<not> is_final (steps0 (1, [], cl) tm n)" by auto
+          ultimately have "\<not> is_final (steps0 (1, [], cl)  (mk_composable0 tm) n)" by auto
+          with  \<open>tap = ([], cl)\<close> show "\<not> is_final (steps0 (1, tap)  (mk_composable0 tm) n)" by auto
+        qed
+      next
+        case False
+        then have "\<not> (\<forall>stp. steps0 (1, [], cl) (mk_composable0 tm) stp = steps0 (1, [], cl) tm stp)" .
+        then have "\<exists>stp. steps0 (1, [], cl) (mk_composable0 tm) stp \<noteq> steps0 (1, [], cl) tm stp" by blast
+        then obtain stp where w_stp: "steps0 (1, [], cl) (mk_composable0 tm) stp \<noteq> steps0 (1, [], cl) tm stp" by blast
+
+        show "\<forall>n. \<not> is_final (steps0 (1, tap) (mk_composable0 tm) n)"
+        proof -
+          from w_stp have F0: "0 < stp \<and>
+                           (\<exists>fl fr.
+                                   snd (steps0 (1, [], cl) tm stp) = (fl, fr) \<and>
+                                   (\<forall>i < stp. steps0 (1, [], cl) (mk_composable0 tm) i = steps0 (1, [], cl) tm i) \<and>
+                                   (\<forall>j > stp. steps0 (1, [], cl) tm (j) = (0, fl, fr) \<and> 
+                                              steps0 (1, [], cl) (mk_composable0 tm) j =(0, fl, fr)))"
+            by (rule mk_composable0_tm_at_most_one_diff')
+          then have "(\<exists>fl fr.
+                                   snd (steps0 (1, [], cl) tm stp) = (fl, fr) \<and>
+                                   (\<forall>i < stp. steps0 (1, [], cl) (mk_composable0 tm) i = steps0 (1, [], cl) tm i) \<and>
+                                   (\<forall>j > stp. steps0 (1, [], cl) tm (j) = (0, fl, fr) \<and> 
+                                              steps0 (1, [], cl) (mk_composable0 tm) j =(0, fl, fr)))" by auto
+          then obtain fl fr where w_fl_fr: "snd (steps0 (1, [], cl) tm stp) = (fl, fr) \<and>
+                                   (\<forall>i < stp. steps0 (1, [], cl) (mk_composable0 tm) i = steps0 (1, [], cl) tm i) \<and>
+                                   (\<forall>j > stp. steps0 (1, [], cl) tm (j) = (0, fl, fr) \<and> 
+                                              steps0 (1, [], cl) (mk_composable0 tm) j =(0, fl, fr))" by blast
+          then have "steps0 (1, [], cl) tm (stp+1) = (0, fl, fr)" by auto
+          then have "is_final (steps0 (1, [], cl) tm (stp+1))" by auto
+          with \<open>tap = ([], cl)\<close> have "is_final (steps0 (1, tap) tm (stp+1))" by auto
+          moreover from B have "\<not> is_final (steps0 (1, tap) tm (stp+1))" by blast
+          ultimately have False by auto
+          then show ?thesis by auto
+        qed
+      qed
+    qed
+  qed
+qed
+
+(* --- trivial specializations for cells generated from lists of natural numbers or pairs of such cell lists --- *)
+
+corollary Hoare_halt_tm_impl_Hoare_halt_mk_composable0: "\<lbrace>\<lambda>tap. tap = ([]::cell list, <nl>)\<rbrace> tm \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 tm \<lbrace>Q\<rbrace>"
+  using Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list by auto
+
+corollary Hoare_unhalt_tm_impl_Hoare_unhalt_mk_composable0: "(\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm \<up>) \<Longrightarrow> (\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> (mk_composable0 tm) \<up>)"
+  using Hoare_unhalt_tm_impl_Hoare_unhalt_mk_composable0_cell_list by auto
+
+(* --- *)
+
+corollary Hoare_halt_tm_impl_Hoare_halt_mk_composable0_pair:
+  "\<lbrace>\<lambda>tap. tap = ([], <(nl1,nl2)>)\<rbrace> tm \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <(nl1,nl2)>)\<rbrace> mk_composable0 tm \<lbrace>Q\<rbrace>"
+  using Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list by auto
+
+corollary Hoare_unhalt_tm_impl_Hoare_unhalt_mk_composable0_pair: "(\<lbrace>\<lambda>tap. tap = ([], <(nl1, nl2)>)\<rbrace> tm \<up>) \<Longrightarrow> (\<lbrace>\<lambda>tap. tap = ([], <(nl1,nl2)>)\<rbrace> (mk_composable0 tm) \<up>)"
+  using Hoare_unhalt_tm_impl_Hoare_unhalt_mk_composable0_cell_list by auto
+
+
+section \<open>The Halt Lemma: no infinite descend\<close>
+
+lemma halt_lemma: 
+  "\<lbrakk>wf LE; \<forall>n. (\<not> P (f n) \<longrightarrow> (f (Suc n), (f n)) \<in> LE)\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
+  by (metis wf_iff_no_infinite_down_chain)
+
+end
diff --git a/thys/Universal_Turing_Machine/Turing_aux.thy b/thys/Universal_Turing_Machine/Turing_aux.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/Turing_aux.thy
@@ -0,0 +1,146 @@
+(* Title: thys/Turing_aux.thy
+   Author:  Franz Regensburger (FABR) 04/2022
+ *)
+
+subsection \<open>Auxiliary theorems about Turing Machines\<close>
+
+theory Turing_aux
+  imports Turing
+begin
+
+(* -------------------------------------------- *)
+(* START: enhanced/clarified semantics of fetch *)
+(* -------------------------------------------- *)
+
+fun fetch' :: "instr list \<Rightarrow> state \<Rightarrow> cell \<Rightarrow> instr"
+  where
+    "fetch' []                 s              b = (Nop, 0)"
+
+  | "fetch' [iBk]              0              b  = (Nop, 0)" 
+  | "fetch' [iBk]              (Suc 0)        Bk = iBk" 
+  | "fetch' [iBk]              (Suc 0)        Oc = (Nop, 0)"
+  | "fetch' [iBk]              (Suc (Suc s')) b  = (Nop, 0)"
+
+  | "fetch' (iBk # iOc # inss) 0              b  = (Nop, 0)" 
+  | "fetch' (iBk # iOc # inss) (Suc 0)        Bk = iBk" 
+  | "fetch' (iBk # iOc # inss) (Suc 0)        Oc = iOc"
+  | "fetch' (iBk # iOc # inss) (Suc (Suc s')) b  = fetch' inss (Suc s') b"
+
+lemma fetch'_Nil:
+  shows "fetch' [] s b = (Nop, 0)"
+  by (cases s,force) (cases b;force)
+
+lemma fetch'_eq_fetch_app: "fetch' tm s b = fetch tm s b"
+proof (induct rule: fetch'.induct)
+  case (1 s b)
+  then show ?case by (cases b) (auto simp add: fetch_imp)
+next
+  case (2 iBk b)
+  then show ?case by (cases b) auto
+next
+  case (3 iBk)
+  then show ?case by auto
+next
+  case (4 iBk)
+  then show ?case by auto
+next
+  case (5 iBk s' b)
+  then show ?case by (cases b) auto
+next
+  case (6 iBk iOc inss b)
+  then show ?case by (cases b) auto
+next
+  case (7 iBk iOc inss)
+  then show ?case by  auto
+next
+  case (8 iBk iOc inss)
+  then show ?case by  auto
+next
+  case (9 iBk iOc inss s' b)
+  then show ?case by (cases b) auto
+qed
+
+corollary fetch'_eq_fetch: "fetch' = fetch"
+  by (blast intro: fetch'_eq_fetch_app)
+
+(* ------------------------------------------- *)
+(* END: enhanced/clarified semantics of fetch  *)
+(* ------------------------------------------- *)
+
+(* ------------------------------------------- *)
+(* step function versus step relation          *)
+(* ------------------------------------------- *)
+
+(* Definition for a step relation instead of a step function *)
+
+definition
+  tm_step0_rel :: "tprog0 \<Rightarrow> ((config \<times> config) set)"
+  where
+   "tm_step0_rel tp = {(c1, c2) . step0 c1 tp = c2}"
+
+abbreviation tm_step0_rel_aux :: "[config, tprog0, config] \<Rightarrow> bool"   ("((1_)/ \<Turnstile>\<langle>(_)\<rangle>\<Midarrow>/ (1_))" 50)
+  where
+            "tm_step0_rel_aux c1 tp c2  \<equiv> (c1,c2) \<in> tm_step0_rel tp" 
+
+theorem tm_step0_rel_iff_step0: "(c1 \<Turnstile>\<langle>tp\<rangle>\<Midarrow> c2) \<longleftrightarrow> step0 c1 tp = c2"
+  unfolding tm_step0_rel_def by auto
+
+(* The steps relation is the reflexive and transitive closure of the step relation  *)
+
+definition tm_steps0_rel :: "tprog0 \<Rightarrow> ((config \<times> config) set)"
+  where
+   "tm_steps0_rel tp = rtrancl (tm_step0_rel tp)"
+
+abbreviation tm_steps0_rel_aux :: "[config, tprog0, config] \<Rightarrow> bool"   ("((1_)/ \<Turnstile>\<langle>(_)\<rangle>\<Midarrow>\<^sup>*/ (1_))" 50)
+  where
+            "tm_steps0_rel_aux c1 tp c2  \<equiv> (c1,c2) \<in> tm_steps0_rel tp" 
+
+lemma tm_step0_rel_power: "(tm_step0_rel tp ^^ n) = {(c1,c2) . steps0 c1 tp n = c2}"
+proof (induct n)
+  case 0
+  then show ?case
+    using prod.exhaust relpowp_0_I split_conv 
+       by auto
+next
+  case (Suc n)
+  then have IV: "tm_step0_rel tp ^^ n = {a. case a of (c1, c2) \<Rightarrow> steps0 c1 tp n = c2}"
+    by auto
+  show "tm_step0_rel tp ^^ Suc n = {a. case a of (c1, c2) \<Rightarrow> steps0 c1 tp (Suc n) = c2}"
+  proof 
+    show "tm_step0_rel tp ^^ Suc n \<subseteq> {a. case a of (c1, c2) \<Rightarrow> steps0 c1 tp (Suc n) = c2}"
+      using IV step_red tm_step0_rel_def by auto
+  next
+    show "{a. case a of (c1, c2) \<Rightarrow> steps0 c1 tp (Suc n) = c2} \<subseteq> tm_step0_rel tp ^^ Suc n"
+    proof
+      fix cp
+      assume "cp \<in> {a. case a of (c1, c2) \<Rightarrow> steps0 c1 tp (Suc n) = c2}"
+      then have "\<exists>c1 c2. cp = (c1,c2) \<and> steps0 c1 tp (Suc n) = c2"        
+        using prod.exhaust_sel by blast
+      then obtain c1 c2 where "cp = (c1,c2) \<and> steps0 c1 tp (Suc n) = c2" by blast
+      then show "cp \<in> tm_step0_rel tp ^^ Suc n"
+        using IV step_red  tm_step0_rel_def by auto
+    qed
+  qed
+qed
+
+theorem tm_steps0_rel_iff_steps0: "(c1 \<Turnstile>\<langle>tp\<rangle>\<Midarrow>\<^sup>* c2) \<longleftrightarrow> (\<exists>stp. steps0 c1 tp stp = c2)"
+proof -
+  have major: "((c1 \<Turnstile>\<langle>tp\<rangle>\<Midarrow>\<^sup>* c2)) \<longleftrightarrow> (\<exists>n. (c1,c2) \<in> (tm_step0_rel tp ^^ n))"
+    by (simp add: relpow_code_def rtrancl_power tm_step0_rel_def tm_steps0_rel_def)
+  show ?thesis
+  proof
+    assume "(c1 \<Turnstile>\<langle>tp\<rangle>\<Midarrow>\<^sup>* c2)"
+    with major have "(\<exists>n. (c1,c2) \<in> (tm_step0_rel tp ^^ n))" by auto
+    then obtain n where w_n: "(c1,c2) \<in> (tm_step0_rel tp ^^ n)" by blast
+    then show "\<exists>stp. steps0 c1 tp stp = c2" using tm_step0_rel_power
+      by auto
+  next
+    assume "\<exists>stp. steps0 c1 tp stp = c2"
+    then obtain stp where "steps0 c1 tp stp = c2" by blast
+    then show "(c1 \<Turnstile>\<langle>tp\<rangle>\<Midarrow>\<^sup>* c2)"
+      using tm_step0_rel_power major 
+      by auto
+  qed
+qed
+
+end
diff --git a/thys/Universal_Turing_Machine/UF.thy b/thys/Universal_Turing_Machine/UF.thy
--- a/thys/Universal_Turing_Machine/UF.thy
+++ b/thys/Universal_Turing_Machine/UF.thy
@@ -1,4202 +1,4286 @@
 (* Title: thys/UF.thy
    Author: Jian Xu, Xingyuan Zhang, and Christian Urban
    Modifications: Sebastiaan Joosten
-*)
+   Modifications: Franz Regensburger (FABR) 08/2022
+     added LaTeX sections and text for explaination
+ *)
 
 chapter \<open>Construction of a Universal Function\<close>
 
 theory UF
   imports Rec_Def HOL.GCD Abacus
 begin
 
 text \<open>
   This theory file constructs the Universal Function \<open>rec_F\<close>, which is the UTM defined
   in terms of recursive functions. This \<open>rec_F\<close> is essentially an 
-  interpreter of Turing Machines. Once the correctness of \<open>rec_F\<close> is established,
-  UTM can easil be obtained by compling \<open>rec_F\<close> into the corresponding Turing Machine.
+  interpreter for Turing Machines. Once the correctness of \<open>rec_F\<close> is established,
+  UTM can easily be obtained by compiling \<open>rec_F\<close> into the corresponding Turing Machine.
 \<close>
 
-section \<open>Universal Function\<close>
-
-subsection \<open>The construction of component functions\<close>
+section \<open>Building blocks of the Universal Function rec\_F\<close>
+
+subsection \<open>Some helper functions: Recursive Functions for arithmetic and logic\<close>
 
 text \<open>
   The recursive function used to do arithmetic addition.
 \<close>
+
 definition rec_add :: "recf"
   where
     "rec_add \<equiv>  Pr 1 (id 1 0) (Cn 3 s [id 3 2])"
 
 text \<open>
   The recursive function used to do arithmetic multiplication.
 \<close>
+
 definition rec_mult :: "recf"
   where
     "rec_mult = Pr 1 z (Cn 3 rec_add [id 3 0, id 3 2])"
 
 text \<open>
   The recursive function used to do arithmetic precede.
 \<close>
+
 definition rec_pred :: "recf"
   where
     "rec_pred = Cn 1 (Pr 1 z (id 3 1)) [id 1 0, id 1 0]"
 
 text \<open>
   The recursive function used to do arithmetic subtraction.
 \<close>
+
 definition rec_minus :: "recf" 
   where
     "rec_minus = Pr 1 (id 1 0) (Cn 3 rec_pred [id 3 2])"
 
 text \<open>
   \<open>constn n\<close> is the recursive function which computes 
-  nature number \<open>n\<close>.
+  natural number \<open>n\<close>.
 \<close>
+
 fun constn :: "nat \<Rightarrow> recf"
   where
     "constn 0 = z"  |
     "constn (Suc n) = Cn 1 s [constn n]"
 
 
 text \<open>
   Sign function, which returns 1 when the input argument is greater than \<open>0\<close>.
 \<close>
+
 definition rec_sg :: "recf"
   where
     "rec_sg = Cn 1 rec_minus [constn 1, 
                   Cn 1 rec_minus [constn 1, id 1 0]]"
 
 text \<open>
   \<open>rec_less\<close> compares its two arguments, returns \<open>1\<close> if
   the first is less than the second; otherwise returns \<open>0\<close>.
 \<close>
+
 definition rec_less :: "recf"
   where
     "rec_less = Cn 2 rec_sg [Cn 2 rec_minus [id 2 1, id 2 0]]"
 
 text \<open>
   \<open>rec_not\<close> inverse its argument: returns \<open>1\<close> when the
   argument is \<open>0\<close>; returns \<open>0\<close> otherwise.
 \<close>
+
 definition rec_not :: "recf"
   where
     "rec_not = Cn 1 rec_minus [constn 1, id 1 0]"
 
 text \<open>
   \<open>rec_eq\<close> compares its two arguments: returns \<open>1\<close>
   if they are equal; return \<open>0\<close> otherwise.
 \<close>
+
 definition rec_eq :: "recf"
   where
     "rec_eq = Cn 2 rec_minus [Cn 2 (constn 1) [id 2 0], 
              Cn 2 rec_add [Cn 2 rec_minus [id 2 0, id 2 1], 
                Cn 2 rec_minus [id 2 1, id 2 0]]]"
 
 text \<open>
   \<open>rec_conj\<close> computes the conjunction of its two arguments, 
   returns \<open>1\<close> if both of them are non-zero; returns \<open>0\<close>
   otherwise.
 \<close>
+
 definition rec_conj :: "recf"
   where
     "rec_conj = Cn 2 rec_sg [Cn 2 rec_mult [id 2 0, id 2 1]] "
 
 text \<open>
   \<open>rec_disj\<close> computes the disjunction of its two arguments, 
   returns \<open>0\<close> if both of them are zero; returns \<open>0\<close>
   otherwise.
 \<close>
+
 definition rec_disj :: "recf"
   where
     "rec_disj = Cn 2 rec_sg [Cn 2 rec_add [id 2 0, id 2 1]]"
 
 
 text \<open>
   Computes the arity of recursive function.
 \<close>
 
 fun arity :: "recf \<Rightarrow> nat"
   where
     "arity z = 1" 
   | "arity s = 1"
   | "arity (id m n) = m"
   | "arity (Cn n f gs) = n"
   | "arity (Pr n f g) = Suc n"
   | "arity (Mn n f) = n"
 
 text \<open>
   \<open>get_fstn_args n (Suc k)\<close> returns
   \<open>[id n 0, id n 1, id n 2, \<dots>, id n k]\<close>, 
   the effect of which is to take out the first \<open>Suc k\<close> 
   arguments out of the \<open>n\<close> input arguments.
 \<close>
 
 fun get_fstn_args :: "nat \<Rightarrow>  nat \<Rightarrow> recf list"
   where
     "get_fstn_args n 0 = []"
   | "get_fstn_args n (Suc y) = get_fstn_args n y @ [id n y]"
 
 text \<open>
   \<open>rec_sigma f\<close> returns the recursive functions which 
   sums up the results of \<open>f\<close>:
   \[
   (rec\_sigma f)(x, y) = f(x, 0) + f(x, 1) + \cdots + f(x, y)
   \]
 \<close>
+
 fun rec_sigma :: "recf \<Rightarrow> recf"
   where
     "rec_sigma rf = 
        (let vl = arity rf in 
           Pr (vl - 1) (Cn (vl - 1) rf (get_fstn_args (vl - 1) (vl - 1) @ 
                     [Cn (vl - 1) (constn 0) [id (vl - 1) 0]])) 
              (Cn (Suc vl) rec_add [id (Suc vl) vl, 
                     Cn (Suc vl) rf (get_fstn_args (Suc vl) (vl - 1) 
                         @ [Cn (Suc vl) s [id (Suc vl) (vl - 1)]])]))"
 
 text \<open>
   \<open>rec_exec\<close> is the interpreter function for
-  reursive functions. The function is defined such that 
+  Recursive Functions. The function is defined such that 
   it always returns meaningful results for primitive recursive 
   functions.
 \<close>
 
+subsubsection \<open>Correctness of the helper functions\<close>
+
 declare rec_exec.simps[simp del] constn.simps[simp del]
 
 text \<open>
   Correctness of \<open>rec_add\<close>.
 \<close>
 lemma add_lemma: "\<And> x y. rec_exec rec_add [x, y] =  x + y"
   by(induct_tac y, auto simp: rec_add_def rec_exec.simps)
 
 text \<open>
   Correctness of \<open>rec_mult\<close>.
 \<close>
 lemma mult_lemma: "\<And> x y. rec_exec rec_mult [x, y] = x * y"
   by(induct_tac y, auto simp: rec_mult_def rec_exec.simps add_lemma)
 
 text \<open>
   Correctness of \<open>rec_pred\<close>.
 \<close>
 lemma pred_lemma: "\<And> x. rec_exec rec_pred [x] =  x - 1"
   by(induct_tac x, auto simp: rec_pred_def rec_exec.simps)
 
 text \<open>
   Correctness of \<open>rec_minus\<close>.
 \<close>
 lemma minus_lemma: "\<And> x y. rec_exec rec_minus [x, y] = x - y"
   by(induct_tac y, auto simp: rec_exec.simps rec_minus_def pred_lemma)
 
 text \<open>
   Correctness of \<open>rec_sg\<close>.
 \<close>
 lemma sg_lemma: "\<And> x. rec_exec rec_sg [x] = (if x = 0 then 0 else 1)"
   by(auto simp: rec_sg_def minus_lemma rec_exec.simps constn.simps)
 
 text \<open>
   Correctness of \<open>constn\<close>.
 \<close>
 lemma constn_lemma: "rec_exec (constn n) [x] = n"
   by(induct n, auto simp: rec_exec.simps constn.simps)
 
 text \<open>
   Correctness of \<open>rec_less\<close>.
 \<close>
 lemma less_lemma: "\<And> x y. rec_exec rec_less [x, y] = 
   (if x < y then 1 else 0)"
   by(induct_tac y, auto simp: rec_exec.simps 
       rec_less_def minus_lemma sg_lemma)
 
 text \<open>
   Correctness of \<open>rec_not\<close>.
 \<close>
 lemma not_lemma: 
   "\<And> x. rec_exec rec_not [x] = (if x = 0 then 1 else 0)"
   by(induct_tac x, auto simp: rec_exec.simps rec_not_def
       constn_lemma minus_lemma)
 
 text \<open>
   Correctness of \<open>rec_eq\<close>.
 \<close>
 lemma eq_lemma: "\<And> x y. rec_exec rec_eq [x, y] = (if x = y then 1 else 0)"
   by(induct_tac y, auto simp: rec_exec.simps rec_eq_def constn_lemma add_lemma minus_lemma)
 
 text \<open>
   Correctness of \<open>rec_conj\<close>.
 \<close>
 lemma conj_lemma: "\<And> x y. rec_exec rec_conj [x, y] = (if x = 0 \<or> y = 0 then 0 
                                                        else 1)"
   by(induct_tac y, auto simp: rec_exec.simps sg_lemma rec_conj_def mult_lemma)
 
 text \<open>
   Correctness of \<open>rec_disj\<close>.
 \<close>
 lemma disj_lemma: "\<And> x y. rec_exec rec_disj [x, y] = (if x = 0 \<and> y = 0 then 0
                                                      else 1)"
   by(induct_tac y, auto simp: rec_disj_def sg_lemma add_lemma rec_exec.simps)
 
+subsection \<open>The characteristic function primerec for the set of Primitive Recursive Functions\<close>
 
 text \<open>
-  \<open>primrec recf n\<close> is true iff 
+  \<open>primerec recf n\<close> is true iff 
   \<open>recf\<close> is a primitive recursive function 
   with arity \<open>n\<close>.
 \<close>
 inductive primerec :: "recf \<Rightarrow> nat \<Rightarrow> bool"
   where
     prime_z[intro]:  "primerec z (Suc 0)" |
     prime_s[intro]:  "primerec s (Suc 0)" |
     prime_id[intro!]: "\<lbrakk>n < m\<rbrakk> \<Longrightarrow> primerec (id m n) m" |
     prime_cn[intro!]: "\<lbrakk>primerec f k; length gs = k; 
   \<forall> i < length gs. primerec (gs ! i) m; m = n\<rbrakk> 
   \<Longrightarrow> primerec (Cn n f gs) m" |
     prime_pr[intro!]: "\<lbrakk>primerec f n; 
   primerec g (Suc (Suc n)); m = Suc n\<rbrakk> 
   \<Longrightarrow> primerec (Pr n f g) m" 
 
 inductive_cases prime_cn_reverse'[elim]: "primerec (Cn n f gs) n" 
 inductive_cases prime_mn_reverse: "primerec (Mn n f) m" 
 inductive_cases prime_z_reverse[elim]: "primerec z n"
 inductive_cases prime_s_reverse[elim]: "primerec s n"
 inductive_cases prime_id_reverse[elim]: "primerec (id m n) k"
 inductive_cases prime_cn_reverse[elim]: "primerec (Cn n f gs) m"
 inductive_cases prime_pr_reverse[elim]: "primerec (Pr n f g) m"
 
+subsection \<open>The Recursive Function rec\_sigma\<close>
+
 declare mult_lemma[simp] add_lemma[simp] pred_lemma[simp] 
   minus_lemma[simp] sg_lemma[simp] constn_lemma[simp] 
   less_lemma[simp] not_lemma[simp] eq_lemma[simp]
   conj_lemma[simp] disj_lemma[simp]
 
 text \<open>
   \<open>Sigma\<close> is the logical specification of 
   the recursive function \<open>rec_sigma\<close>.
 \<close>
 function Sigma :: "(nat list \<Rightarrow> nat) \<Rightarrow> nat list \<Rightarrow> nat"
   where
     "Sigma g xs = (if last xs = 0 then g xs
                  else (Sigma g (butlast xs @ [last xs - 1]) +
                        g xs)) "
   by pat_completeness auto
 termination
 proof
   show "wf (measure (\<lambda> (f, xs). last xs))" by auto
 next
   fix g xs
   assume "last (xs::nat list) \<noteq> 0"
   thus "((g, butlast xs @ [last xs - 1]), g, xs)  
                    \<in> measure (\<lambda>(f, xs). last xs)"
     by auto
 qed
 
 declare rec_exec.simps[simp del] get_fstn_args.simps[simp del]
   arity.simps[simp del] Sigma.simps[simp del]
   rec_sigma.simps[simp del]
 
 lemma rec_pr_Suc_simp_rewrite: 
   "rec_exec (Pr n f g) (xs @ [Suc x]) =
                        rec_exec g (xs @ [x] @ 
                         [rec_exec (Pr n f g) (xs @ [x])])"
   by(simp add: rec_exec.simps)
 
 lemma Sigma_0_simp_rewrite:
   "Sigma f (xs @ [0]) = f (xs @ [0])"
   by(simp add: Sigma.simps)
 
 lemma Sigma_Suc_simp_rewrite: 
   "Sigma f (xs @ [Suc x]) = Sigma f (xs @ [x]) + f (xs @ [Suc x])"
   by(simp add: Sigma.simps)
 
 lemma append_access_1[simp]: "(xs @ ys) ! (Suc (length xs)) = ys ! 1"
   by(simp add: nth_append)
 
 lemma get_fstn_args_take: "\<lbrakk>length xs = m; n \<le> m\<rbrakk> \<Longrightarrow> 
   map (\<lambda> f. rec_exec f xs) (get_fstn_args m n)= take n xs"
 proof(induct n)
   case 0 thus "?case"
     by(simp add: get_fstn_args.simps)
 next
   case (Suc n) thus "?case"
     by(simp add: get_fstn_args.simps rec_exec.simps 
         take_Suc_conv_app_nth)
 qed
 
 lemma arity_primerec[simp]: "primerec f n \<Longrightarrow> arity f = n"
   apply(cases f)
        apply(auto simp: arity.simps )
   apply(erule_tac prime_mn_reverse)
   done
 
 lemma rec_sigma_Suc_simp_rewrite: 
   "primerec f (Suc (length xs))
     \<Longrightarrow> rec_exec (rec_sigma f) (xs @ [Suc x]) = 
     rec_exec (rec_sigma f) (xs @ [x]) + rec_exec f (xs @ [Suc x])"
   apply(induct x)
    apply(auto simp: rec_sigma.simps Let_def rec_pr_Suc_simp_rewrite
       rec_exec.simps get_fstn_args_take)
   done      
 
 text \<open>
   The correctness of \<open>rec_sigma\<close> with respect to its specification.
 \<close>
 lemma sigma_lemma: 
   "primerec rg (Suc (length xs))
      \<Longrightarrow> rec_exec (rec_sigma rg) (xs @ [x]) = Sigma (rec_exec rg) (xs @ [x])"
   apply(induct x)
    apply(auto simp: rec_exec.simps rec_sigma.simps Let_def 
       get_fstn_args_take Sigma_0_simp_rewrite
       Sigma_Suc_simp_rewrite) 
   done
 
+subsection \<open>The Recursive Function rec\_accum\<close>
+
 text \<open>
   \<open>rec_accum f (x1, x2, \<dots>, xn, k) = 
            f(x1, x2, \<dots>, xn, 0) * 
            f(x1, x2, \<dots>, xn, 1) *
                \<dots> 
            f(x1, x2, \<dots>, xn, k)\<close>
 \<close>
+
 fun rec_accum :: "recf \<Rightarrow> recf"
   where
     "rec_accum rf = 
        (let vl = arity rf in 
           Pr (vl - 1) (Cn (vl - 1) rf (get_fstn_args (vl - 1) (vl - 1) @ 
                      [Cn (vl - 1) (constn 0) [id (vl - 1) 0]])) 
              (Cn (Suc vl) rec_mult [id (Suc vl) (vl), 
                     Cn (Suc vl) rf (get_fstn_args (Suc vl) (vl - 1) 
                       @ [Cn (Suc vl) s [id (Suc vl) (vl - 1)]])]))"
 
 text \<open>
   \<open>Accum\<close> is the formal specification of \<open>rec_accum\<close>.
 \<close>
 function Accum :: "(nat list \<Rightarrow> nat) \<Rightarrow> nat list \<Rightarrow> nat"
   where
     "Accum f xs = (if last xs = 0 then f xs 
                      else (Accum f (butlast xs @ [last xs - 1]) *
                        f xs))"
   by pat_completeness auto
 termination
 proof
   show "wf (measure (\<lambda> (f, xs). last xs))"
     by auto
 next
   fix f xs
   assume "last xs \<noteq> (0::nat)"
   thus "((f, butlast xs @ [last xs - 1]), f, xs) \<in> 
             measure (\<lambda>(f, xs). last xs)"
     by auto
 qed
 
 lemma rec_accum_Suc_simp_rewrite: 
   "primerec f (Suc (length xs))
     \<Longrightarrow> rec_exec (rec_accum f) (xs @ [Suc x]) = 
     rec_exec (rec_accum f) (xs @ [x]) * rec_exec f (xs @ [Suc x])"
   apply(induct x)
    apply(auto simp: rec_sigma.simps Let_def rec_pr_Suc_simp_rewrite
       rec_exec.simps get_fstn_args_take)
   done  
 
 text \<open>
   The correctness of \<open>rec_accum\<close> with respect to its specification.
 \<close>
 lemma accum_lemma :
   "primerec rg (Suc (length xs))
      \<Longrightarrow> rec_exec (rec_accum rg) (xs @ [x]) = Accum (rec_exec rg) (xs @ [x])"
   apply(induct x)
    apply(auto simp: rec_exec.simps rec_sigma.simps Let_def 
       get_fstn_args_take)
   done
 
 declare rec_accum.simps [simp del]
 
+subsection \<open>The Recursive Function rec\_all\<close>
+
 text \<open>
   \<open>rec_all t f (x1, x2, \<dots>, xn)\<close> 
   computes the charactrization function of the following FOL formula:
   \<open>(\<forall> x \<le> t(x1, x2, \<dots>, xn). (f(x1, x2, \<dots>, xn, x) > 0))\<close>
 \<close>
 fun rec_all :: "recf \<Rightarrow> recf \<Rightarrow> recf"
   where
     "rec_all rt rf = 
     (let vl = arity rf in
        Cn (vl - 1) rec_sg [Cn (vl - 1) (rec_accum rf) 
                  (get_fstn_args (vl - 1) (vl - 1) @ [rt])])"
 
 lemma rec_accum_ex:
   assumes "primerec rf (Suc (length xs))"
   shows "(rec_exec (rec_accum rf) (xs @ [x]) = 0) = 
          (\<exists> t \<le> x. rec_exec rf (xs @ [t]) = 0)"
 proof(induct x)
   case (Suc x)
   with assms show ?case 
     apply(auto simp add: rec_exec.simps rec_accum.simps get_fstn_args_take)
      apply(rename_tac t ta)
      apply(rule_tac x = ta in exI, simp)
     apply(case_tac "t = Suc x", simp_all)
     apply(rule_tac x = t in exI, simp) done
 qed (insert assms,auto simp add: rec_exec.simps rec_accum.simps get_fstn_args_take)
 
-
 text \<open>
   The correctness of \<open>rec_all\<close>.
 \<close>
 lemma all_lemma: 
   "\<lbrakk>primerec rf (Suc (length xs));
     primerec rt (length xs)\<rbrakk>
   \<Longrightarrow> rec_exec (rec_all rt rf) xs = (if (\<forall> x \<le> (rec_exec rt xs). 0 < rec_exec rf (xs @ [x])) then 1
                                                                                               else 0)"
   apply(auto simp: rec_all.simps)
    apply(simp add: rec_exec.simps map_append get_fstn_args_take split: if_splits)
    apply(drule_tac x = "rec_exec rt xs" in rec_accum_ex)
    apply(cases "rec_exec (rec_accum rf) (xs @ [rec_exec rt xs]) = 0", simp_all)
    apply force
   apply(simp add: rec_exec.simps map_append get_fstn_args_take)
   apply(drule_tac x = "rec_exec rt xs" in rec_accum_ex)
   apply(cases "rec_exec (rec_accum rf) (xs @ [rec_exec rt xs]) = 0")
    apply force+
   done
 
+subsection \<open>The Recursive Function rec\_ex\<close>
+
 text \<open>
   \<open>rec_ex t f (x1, x2, \<dots>, xn)\<close> 
   computes the charactrization function of the following FOL formula:
   \<open>(\<exists> x \<le> t(x1, x2, \<dots>, xn). (f(x1, x2, \<dots>, xn, x) > 0))\<close>
 \<close>
 fun rec_ex :: "recf \<Rightarrow> recf \<Rightarrow> recf"
   where
     "rec_ex rt rf = 
        (let vl = arity rf in 
          Cn (vl - 1) rec_sg [Cn (vl - 1) (rec_sigma rf) 
                   (get_fstn_args (vl - 1) (vl - 1) @ [rt])])"
 
 lemma rec_sigma_ex: 
   assumes "primerec rf (Suc (length xs))"
   shows "(rec_exec (rec_sigma rf) (xs @ [x]) = 0) = 
                           (\<forall> t \<le> x. rec_exec rf (xs @ [t]) = 0)"
 proof(induct x)
   case (Suc x)
   from Suc assms show ?case
     by(auto simp add: rec_exec.simps rec_sigma.simps 
         get_fstn_args_take elim:le_SucE)
 qed (insert assms,auto simp: get_fstn_args_take rec_exec.simps rec_sigma.simps)
 
 text \<open>
-  The correctness of \<open>ex_lemma\<close>.
+  The correctness of \<open>rec_ex\<close>.
 \<close>
 lemma ex_lemma:"
   \<lbrakk>primerec rf (Suc (length xs));
    primerec rt (length xs)\<rbrakk>
 \<Longrightarrow> (rec_exec (rec_ex rt rf) xs =
     (if (\<exists> x \<le> (rec_exec rt xs). 0 <rec_exec rf (xs @ [x])) then 1
      else 0))"
   apply(auto simp: rec_exec.simps get_fstn_args_take split: if_splits)
    apply(drule_tac x = "rec_exec rt xs" in rec_sigma_ex, simp)
   apply(drule_tac x = "rec_exec rt xs" in rec_sigma_ex, simp)
   done
 
+subsection \<open>The Recursive Function rec\_Minr\<close>
+
 text \<open>
-  Definition of \<open>Min[R]\<close> on page 77 of Boolos's book.
+  Definition of \<open>Min[R]\<close> on page 77 of Boolos's book~\cite{Boolos07}.
 \<close>
 
 fun Minr :: "(nat list \<Rightarrow> bool) \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat"
   where "Minr Rr xs w = (let setx = {y | y. (y \<le> w) \<and> Rr (xs @ [y])} in 
                         if (setx = {}) then (Suc w)
                                        else (Min setx))"
 
 declare Minr.simps[simp del] rec_all.simps[simp del]
 
 text \<open>
-  The following is a set of auxilliary lemmas about \<open>Minr\<close>.
+  The following is a set of auxiliary lemmas about \<open>Minr\<close>.
 \<close>
 lemma Minr_range: "Minr Rr xs w \<le> w \<or> Minr Rr xs w = Suc w"
   apply(auto simp: Minr.simps)
   apply(subgoal_tac "Min {x. x \<le> w \<and> Rr (xs @ [x])} \<le> x")
    apply(erule_tac order_trans, simp)
   apply(rule_tac Min_le, auto)
   done
 
 lemma expand_conj_in_set: "{x. x \<le> Suc w \<and> Rr (xs @ [x])}
     = (if Rr (xs @ [Suc w]) then insert (Suc w) 
                               {x. x \<le> w \<and> Rr (xs @ [x])}
       else {x. x \<le> w \<and> Rr (xs @ [x])})"
   by (auto elim:le_SucE)
 
 lemma Minr_strip_Suc[simp]: "Minr Rr xs w \<le> w \<Longrightarrow> Minr Rr xs (Suc w) = Minr Rr xs w"
   by(cases "\<forall>x\<le>w. \<not> Rr (xs @ [x])",auto simp add: Minr.simps expand_conj_in_set)
 
 lemma x_empty_set[simp]: "\<forall>x\<le>w. \<not> Rr (xs @ [x]) \<Longrightarrow>  
                            {x. x \<le> w \<and> Rr (xs @ [x])} = {} "
   by auto
 
 lemma Minr_is_Suc[simp]: "\<lbrakk>Minr Rr xs w = Suc w; Rr (xs @ [Suc w])\<rbrakk> \<Longrightarrow> 
                                        Minr Rr xs (Suc w) = Suc w"
   apply(simp add: Minr.simps expand_conj_in_set)
   apply(cases "\<forall>x\<le>w. \<not> Rr (xs @ [x])", auto)
   done
 
 lemma Minr_is_Suc_Suc[simp]: "\<lbrakk>Minr Rr xs w = Suc w; \<not> Rr (xs @ [Suc w])\<rbrakk> \<Longrightarrow> 
                                    Minr Rr xs (Suc w) = Suc (Suc w)"
   apply(simp add: Minr.simps expand_conj_in_set)
   apply(cases "\<forall>x\<le>w. \<not> Rr (xs @ [x])", auto)
   apply(subgoal_tac "Min {x. x \<le> w \<and> Rr (xs @ [x])} \<in> 
                                 {x. x \<le> w \<and> Rr (xs @ [x])}", simp)
   apply(rule_tac Min_in, auto)
   done
 
 lemma Minr_Suc_simp: 
   "Minr Rr xs (Suc w) = 
       (if Minr Rr xs w \<le> w then Minr Rr xs w
        else if (Rr (xs @ [Suc w])) then (Suc w)
        else Suc (Suc w))"
   by(insert Minr_range[of Rr xs w], auto)
 
+
 text \<open>
   \<open>rec_Minr\<close> is the recursive function 
   used to implement \<open>Minr\<close>:
   if \<open>Rr\<close> is implemented by a recursive function \<open>recf\<close>,
   then \<open>rec_Minr recf\<close> is the recursive function used to 
   implement \<open>Minr Rr\<close>
 \<close>
+
 fun rec_Minr :: "recf \<Rightarrow> recf"
   where
     "rec_Minr rf = 
      (let vl = arity rf
       in let rq = rec_all (id vl (vl - 1)) (Cn (Suc vl) 
               rec_not [Cn (Suc vl) rf 
                     (get_fstn_args (Suc vl) (vl - 1) @
                                         [id (Suc vl) (vl)])]) 
       in  rec_sigma rq)"
 
 lemma length_getpren_params[simp]: "length (get_fstn_args m n) = n"
   by(induct n, auto simp: get_fstn_args.simps)
 
 lemma length_app:
   "(length (get_fstn_args (arity rf - Suc 0)
                            (arity rf - Suc 0)
    @ [Cn (arity rf - Suc 0) (constn 0)
            [recf.id (arity rf - Suc 0) 0]]))
     = (Suc (arity rf - Suc 0))"
   apply(simp)
   done
 
 lemma primerec_accum: "primerec (rec_accum rf) n \<Longrightarrow> primerec rf n"
   apply(auto simp: rec_accum.simps Let_def)
   apply(erule_tac prime_pr_reverse, simp)
   apply(erule_tac prime_cn_reverse, simp only: length_app)
   done
 
 lemma primerec_all: "primerec (rec_all rt rf) n \<Longrightarrow>
                        primerec rt n \<and> primerec rf (Suc n)"
   apply(simp add: rec_all.simps Let_def)
   apply(erule_tac prime_cn_reverse, simp)
   apply(erule_tac prime_cn_reverse, simp)
   apply(erule_tac x = n in allE, simp add: nth_append primerec_accum)
   done
 
 declare numeral_3_eq_3[simp]
 
 lemma primerec_rec_pred_1[intro]: "primerec rec_pred (Suc 0)"
   apply(simp add: rec_pred_def)
-  apply(rule_tac prime_cn, auto dest:less_2_cases[unfolded numeral One_nat_def])
+  apply(rule_tac prime_cn, auto dest:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
   done
 
 lemma primerec_rec_minus_2[intro]: "primerec rec_minus (Suc (Suc 0))"
   apply(auto simp: rec_minus_def)
   done
 
 lemma primerec_constn_1[intro]: "primerec (constn n) (Suc 0)"
   apply(induct n)
    apply(auto simp: constn.simps)
   done
 
 lemma primerec_rec_sg_1[intro]: "primerec rec_sg (Suc 0)" 
   apply(simp add: rec_sg_def)
   apply(rule_tac k = "Suc (Suc 0)" in prime_cn)
      apply(auto)
-  apply(auto dest!:less_2_cases[unfolded numeral One_nat_def])
+  apply(auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
     apply( auto)
   done
 
 lemma primerec_getpren[elim]: "\<lbrakk>i < n; n \<le> m\<rbrakk> \<Longrightarrow> primerec (get_fstn_args m n ! i) m"
   apply(induct n, auto simp: get_fstn_args.simps)
   apply(cases "i = n", auto simp: nth_append intro: prime_id)
   done
 
 lemma primerec_rec_add_2[intro]: "primerec rec_add (Suc (Suc 0))"
   apply(simp add: rec_add_def)
   apply(rule_tac prime_pr, auto)
   done
 
 lemma primerec_rec_mult_2[intro]:"primerec rec_mult (Suc (Suc 0))"
   apply(simp add: rec_mult_def )
   apply(rule_tac prime_pr, auto)
   using less_2_cases numeral_2_eq_2 by fastforce
 
 lemma primerec_ge_2_elim[elim]: "\<lbrakk>primerec rf n; n \<ge> Suc (Suc 0)\<rbrakk>   \<Longrightarrow> 
                         primerec (rec_accum rf) n"
   apply(auto simp: rec_accum.simps)
-   apply(simp add: nth_append, auto dest!:less_2_cases[unfolded numeral One_nat_def])
+   apply(simp add: nth_append, auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
     apply force
    apply force
   apply(auto simp: nth_append)
   done
 
 lemma primerec_all_iff: 
   "\<lbrakk>primerec rt n; primerec rf (Suc n); n > 0\<rbrakk> \<Longrightarrow> 
                                  primerec (rec_all rt rf) n"
   apply(simp add: rec_all.simps, auto)
     apply(auto, simp add: nth_append, auto)
   done
 
 lemma primerec_rec_not_1[intro]: "primerec rec_not (Suc 0)"
   apply(simp add: rec_not_def)
-  apply(rule prime_cn, auto dest!:less_2_cases[unfolded numeral One_nat_def])
+  apply(rule prime_cn, auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
   done
 
 lemma Min_false1[simp]: "\<lbrakk>\<not> Min {uu. uu \<le> w \<and> 0 < rec_exec rf (xs @ [uu])} \<le> w;
        x \<le> w; 0 < rec_exec rf (xs @ [x])\<rbrakk>
       \<Longrightarrow>  False"
   apply(subgoal_tac "finite {uu. uu \<le> w \<and> 0 < rec_exec rf (xs @ [uu])}")
    apply(subgoal_tac "{uu. uu \<le> w \<and> 0 < rec_exec rf (xs @ [uu])} \<noteq> {}")
     apply(simp add: Min_le_iff, simp)
    apply(rule_tac x = x in exI, simp)
   apply(simp)
   done
 
 lemma sigma_minr_lemma: 
   assumes prrf:  "primerec rf (Suc (length xs))"
   shows "UF.Sigma (rec_exec (rec_all (recf.id (Suc (length xs)) (length xs))
      (Cn (Suc (Suc (length xs))) rec_not
       [Cn (Suc (Suc (length xs))) rf (get_fstn_args (Suc (Suc (length xs))) 
        (length xs) @ [recf.id (Suc (Suc (length xs))) (Suc (length xs))])])))
       (xs @ [w]) =
        Minr (\<lambda>args. 0 < rec_exec rf args) xs w"
 proof(induct w)
   let ?rt = "(recf.id (Suc (length xs)) ((length xs)))"
   let ?rf = "(Cn (Suc (Suc (length xs))) 
     rec_not [Cn (Suc (Suc (length xs))) rf 
     (get_fstn_args (Suc (Suc (length xs))) (length xs) @ 
                 [recf.id (Suc (Suc (length xs))) 
     (Suc ((length xs)))])])"
   let ?rq = "(rec_all ?rt ?rf)"
   have prrf: "primerec ?rf (Suc (length (xs @ [0]))) \<and>
         primerec ?rt (length (xs @ [0]))"
     apply(auto simp: prrf nth_append)+
     done
   show "Sigma (rec_exec (rec_all ?rt ?rf)) (xs @ [0])
        = Minr (\<lambda>args. 0 < rec_exec rf args) xs 0"
     apply(simp add: Sigma.simps)
     apply(simp only: prrf all_lemma,  
         auto simp: rec_exec.simps get_fstn_args_take Minr.simps)
     apply(rule_tac Min_eqI, auto)
     done
 next
   fix w
   let ?rt = "(recf.id (Suc (length xs)) ((length xs)))"
   let ?rf = "(Cn (Suc (Suc (length xs))) 
     rec_not [Cn (Suc (Suc (length xs))) rf 
     (get_fstn_args (Suc (Suc (length xs))) (length xs) @ 
                 [recf.id (Suc (Suc (length xs))) 
     (Suc ((length xs)))])])"
   let ?rq = "(rec_all ?rt ?rf)"
   assume ind:
     "Sigma (rec_exec (rec_all ?rt ?rf)) (xs @ [w]) = Minr (\<lambda>args. 0 < rec_exec rf args) xs w"
   have prrf: "primerec ?rf (Suc (length (xs @ [Suc w]))) \<and>
         primerec ?rt (length (xs @ [Suc w]))"
     apply(auto simp: prrf nth_append)+
     done
   show "UF.Sigma (rec_exec (rec_all ?rt ?rf))
          (xs @ [Suc w]) =
         Minr (\<lambda>args. 0 < rec_exec rf args) xs (Suc w)"
     apply(auto simp: Sigma_Suc_simp_rewrite ind Minr_Suc_simp)
        apply(simp_all only: prrf all_lemma)
        apply(auto simp: rec_exec.simps get_fstn_args_take Let_def Minr.simps split: if_splits)
        apply(drule_tac Min_false1, simp, simp, simp)
       apply (metis le_SucE neq0_conv)
      apply(drule_tac Min_false1, simp, simp, simp)
     apply(drule_tac Min_false1, simp, simp, simp)
     done
 qed
 
 text \<open>
   The correctness of \<open>rec_Minr\<close>.
 \<close>
 lemma Minr_lemma: "
   \<lbrakk>primerec rf (Suc (length xs))\<rbrakk> 
      \<Longrightarrow> rec_exec (rec_Minr rf) (xs @ [w]) = 
             Minr (\<lambda> args. (0 < rec_exec rf args)) xs w"
 proof -
   let ?rt = "(recf.id (Suc (length xs)) ((length xs)))"
   let ?rf = "(Cn (Suc (Suc (length xs))) 
     rec_not [Cn (Suc (Suc (length xs))) rf 
     (get_fstn_args (Suc (Suc (length xs))) (length xs) @ 
                 [recf.id (Suc (Suc (length xs))) 
     (Suc ((length xs)))])])"
   let ?rq = "(rec_all ?rt ?rf)"
   assume h: "primerec rf (Suc (length xs))"
   have h1: "primerec ?rq (Suc (length xs))"
     apply(rule_tac primerec_all_iff)
       apply(auto simp: h nth_append)+
     done
   moreover have "arity rf = Suc (length xs)"
     using h by auto
   ultimately show "rec_exec (rec_Minr rf) (xs @ [w]) = 
     Minr (\<lambda> args. (0 < rec_exec rf args)) xs w"
     apply(simp add: arity.simps Let_def sigma_lemma all_lemma)
     apply(rule_tac  sigma_minr_lemma)
     apply(simp add: h)
     done
 qed
 
+subsection \<open>The Recursive Function rec\_le\<close>
+
 text \<open>
-  \<open>rec_le\<close> is the comparasion function 
+  \<open>rec_le\<close> is the comparison function 
   which compares its two arguments, testing whether the 
   first is less or equal to the second.
 \<close>
 definition rec_le :: "recf"
   where
     "rec_le = Cn (Suc (Suc 0)) rec_disj [rec_less, rec_eq]"
 
 text \<open>
   The correctness of \<open>rec_le\<close>.
 \<close>
 lemma le_lemma: 
   "\<And>x y. rec_exec rec_le [x, y] = (if (x \<le> y) then 1 else 0)"
   by(auto simp: rec_le_def rec_exec.simps)
 
+subsection \<open>The Recursive Function rec\_maxr\<close>
+
 text \<open>
-  Definition of \<open>Max[Rr]\<close> on page 77 of Boolos's book.
+  Definition of \<open>Max[Rr]\<close> on page 77 of Boolos's book~\cite{Boolos07}.
 \<close>
 
 fun Maxr :: "(nat list \<Rightarrow> bool) \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "Maxr Rr xs w = (let setx = {y. y \<le> w \<and> Rr (xs @[y])} in 
                   if setx = {} then 0
                   else Max setx)"
 
 text \<open>
-  \<open>rec_maxr\<close> is the recursive function 
-  used to implementation \<open>Maxr\<close>.
+  \<open>rec_maxr\<close> is the Recursive Function 
+  used to implement \<open>Maxr\<close>.
+
 \<close>
 fun rec_maxr :: "recf \<Rightarrow> recf"
   where
     "rec_maxr rr = (let vl = arity rr in 
                   let rt = id (Suc vl) (vl - 1) in
                   let rf1 = Cn (Suc (Suc vl)) rec_le 
                     [id (Suc (Suc vl)) 
                      ((Suc vl)), id (Suc (Suc vl)) (vl)] in
                   let rf2 = Cn (Suc (Suc vl)) rec_not 
                       [Cn (Suc (Suc vl)) 
                            rr (get_fstn_args (Suc (Suc vl)) 
                             (vl - 1) @ 
                              [id (Suc (Suc vl)) ((Suc vl))])] in
                   let rf = Cn (Suc (Suc vl)) rec_disj [rf1, rf2] in
                   let Qf = Cn (Suc vl) rec_not [rec_all rt rf]
                   in Cn vl (rec_sigma Qf) (get_fstn_args vl vl @
                                                          [id vl (vl - 1)]))"
 
 declare rec_maxr.simps[simp del] Maxr.simps[simp del] 
 declare le_lemma[simp]
 
 declare numeral_2_eq_2[simp]
 
 lemma primerec_rec_disj_2[intro]: "primerec rec_disj (Suc (Suc 0))"
   apply(simp add: rec_disj_def, auto)
-    apply(auto dest!:less_2_cases[unfolded numeral One_nat_def])
+    apply(auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
   done
 
 lemma primerec_rec_less_2[intro]: "primerec rec_less (Suc (Suc 0))"
   apply(simp add: rec_less_def, auto)
-    apply(auto dest!:less_2_cases[unfolded numeral One_nat_def])
+    apply(auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
   done
 
 lemma primerec_rec_eq_2[intro]: "primerec rec_eq (Suc (Suc 0))"
   apply(simp add: rec_eq_def)
-  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral One_nat_def])
+  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
        apply force+
   done
 
 lemma primerec_rec_le_2[intro]: "primerec rec_le (Suc (Suc 0))"
   apply(simp add: rec_le_def)
-  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral One_nat_def])
+  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
   done
 
 lemma Sigma_0: "\<forall> i \<le> n. (f (xs @ [i]) = 0) \<Longrightarrow> 
                               Sigma f (xs @ [n]) = 0"
   apply(induct n, simp add: Sigma.simps)
   apply(simp add: Sigma_Suc_simp_rewrite)
   done
 
 lemma Sigma_Suc[elim]: "\<forall>k<Suc w. f (xs @ [k]) = Suc 0
         \<Longrightarrow> Sigma f (xs @ [w]) = Suc w"
   apply(induct w)
    apply(simp add: Sigma.simps, simp)
   apply(simp add: Sigma.simps)
   done
 
 lemma Sigma_max_point: "\<lbrakk>\<forall> k < ma. f (xs @ [k]) = 1;
         \<forall> k \<ge> ma. f (xs @ [k]) = 0; ma \<le> w\<rbrakk>
     \<Longrightarrow> Sigma f (xs @ [w]) = ma"
   apply(induct w, auto)
    apply(rule_tac Sigma_0, simp)
   apply(simp add: Sigma_Suc_simp_rewrite)
   using Sigma_Suc by fastforce
 
 lemma Sigma_Max_lemma: 
   assumes prrf: "primerec rf (Suc (length xs))"
   shows "UF.Sigma (rec_exec (Cn (Suc (Suc (length xs))) rec_not
   [rec_all (recf.id (Suc (Suc (length xs))) (length xs))
   (Cn (Suc (Suc (Suc (length xs)))) rec_disj
   [Cn (Suc (Suc (Suc (length xs)))) rec_le
   [recf.id (Suc (Suc (Suc (length xs)))) (Suc (Suc (length xs))), 
   recf.id (Suc (Suc (Suc (length xs)))) (Suc (length xs))],
   Cn (Suc (Suc (Suc (length xs)))) rec_not
   [Cn (Suc (Suc (Suc (length xs)))) rf
   (get_fstn_args (Suc (Suc (Suc (length xs)))) (length xs) @ 
   [recf.id (Suc (Suc (Suc (length xs)))) (Suc (Suc (length xs)))])]])]))
   ((xs @ [w]) @ [w]) =
        Maxr (\<lambda>args. 0 < rec_exec rf args) xs w"
 proof -
   let ?rt = "(recf.id (Suc (Suc (length xs))) ((length xs)))"
   let ?rf1 = "Cn (Suc (Suc (Suc (length xs))))
     rec_le [recf.id (Suc (Suc (Suc (length xs)))) 
     ((Suc (Suc (length xs)))), recf.id 
     (Suc (Suc (Suc (length xs)))) ((Suc (length xs)))]"
   let ?rf2 = "Cn (Suc (Suc (Suc (length xs)))) rf 
                (get_fstn_args (Suc (Suc (Suc (length xs))))
     (length xs) @ 
     [recf.id (Suc (Suc (Suc (length xs))))    
     ((Suc (Suc (length xs))))])"
   let ?rf3 = "Cn (Suc (Suc (Suc (length xs)))) rec_not [?rf2]"
   let ?rf = "Cn (Suc (Suc (Suc (length xs)))) rec_disj [?rf1, ?rf3]"
   let ?rq = "rec_all ?rt ?rf"
   let ?notrq = "Cn (Suc (Suc (length xs))) rec_not [?rq]"
   show "?thesis"
   proof(auto simp: Maxr.simps)
     assume h: "\<forall>x\<le>w. rec_exec rf (xs @ [x]) = 0"
     have "primerec ?rf (Suc (length (xs @ [w, i]))) \<and> 
           primerec ?rt (length (xs @ [w, i]))"
       using prrf
-      apply(auto dest!:less_2_cases[unfolded numeral One_nat_def])
+      apply(auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
             apply force+
       apply(case_tac ia, auto simp: h nth_append primerec_getpren)
       done
     hence "Sigma (rec_exec ?notrq) ((xs@[w])@[w]) = 0"
       apply(rule_tac Sigma_0)
       apply(auto simp: rec_exec.simps all_lemma
           get_fstn_args_take nth_append h)
       done
     thus "UF.Sigma (rec_exec ?notrq)
       (xs @ [w, w]) = 0"
       by simp
   next
     fix x
     assume h: "x \<le> w" "0 < rec_exec rf (xs @ [x])"
     hence "\<exists> ma. Max {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])} = ma"
       by auto
     from this obtain ma where k1: 
       "Max {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])} = ma" ..
     hence k2: "ma \<le> w \<and> 0 < rec_exec rf (xs @ [ma])"
       using h
       apply(subgoal_tac
           "Max {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])} \<in>  {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])}")
        apply(erule_tac CollectE, simp)
       apply(rule_tac Max_in, auto)
       done
     hence k3: "\<forall> k < ma. (rec_exec ?notrq (xs @ [w, k]) = 1)"
       apply(auto simp: nth_append)
       apply(subgoal_tac "primerec ?rf (Suc (length (xs @ [w, k]))) \<and> 
         primerec ?rt (length (xs @ [w, k]))")
        apply(auto simp: rec_exec.simps all_lemma get_fstn_args_take nth_append
-          dest!:less_2_cases[unfolded numeral One_nat_def])
+          dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
       using prrf
             apply force+
       done    
     have k4: "\<forall> k \<ge> ma. (rec_exec ?notrq (xs @ [w, k]) = 0)"
       apply(auto)
       apply(subgoal_tac "primerec ?rf (Suc (length (xs @ [w, k]))) \<and> 
         primerec ?rt (length (xs @ [w, k]))")
        apply(auto simp: rec_exec.simps all_lemma get_fstn_args_take nth_append)
        apply(subgoal_tac "x \<le> Max {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])}",
           simp add: k1)
-       apply(rule_tac Max_ge, auto dest!:less_2_cases[unfolded numeral One_nat_def])
+       apply(rule_tac Max_ge, auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
       using prrf apply force+
       apply(auto simp: h nth_append)
       done 
     from k3 k4 k1 have "Sigma (rec_exec ?notrq) ((xs @ [w]) @ [w]) = ma"
       apply(rule_tac Sigma_max_point, simp, simp, simp add: k2)
       done
     from k1 and this show "Sigma (rec_exec ?notrq) (xs @ [w, w]) =
       Max {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])}"
       by simp
   qed  
 qed
 
 text \<open>
   The correctness of \<open>rec_maxr\<close>.
 \<close>
 lemma Maxr_lemma:
   assumes h: "primerec rf (Suc (length xs))"
   shows   "rec_exec (rec_maxr rf) (xs @ [w]) = 
             Maxr (\<lambda> args. 0 < rec_exec rf args) xs w"
 proof -
   from h have "arity rf = Suc (length xs)"
     by auto
   thus "?thesis"
   proof(simp add: rec_exec.simps rec_maxr.simps nth_append get_fstn_args_take)
     let ?rt = "(recf.id (Suc (Suc (length xs))) ((length xs)))"
     let ?rf1 = "Cn (Suc (Suc (Suc (length xs))))
                      rec_le [recf.id (Suc (Suc (Suc (length xs)))) 
               ((Suc (Suc (length xs)))), recf.id 
              (Suc (Suc (Suc (length xs)))) ((Suc (length xs)))]"
     let ?rf2 = "Cn (Suc (Suc (Suc (length xs)))) rf 
                (get_fstn_args (Suc (Suc (Suc (length xs))))
                 (length xs) @ 
                   [recf.id (Suc (Suc (Suc (length xs))))    
                            ((Suc (Suc (length xs))))])"
     let ?rf3 = "Cn (Suc (Suc (Suc (length xs)))) rec_not [?rf2]"
     let ?rf = "Cn (Suc (Suc (Suc (length xs)))) rec_disj [?rf1, ?rf3]"
     let ?rq = "rec_all ?rt ?rf"
     let ?notrq = "Cn (Suc (Suc (length xs))) rec_not [?rq]"
     have prt: "primerec ?rt (Suc (Suc (length xs)))"
       by(auto intro: prime_id)
     have prrf: "primerec ?rf (Suc (Suc (Suc (length xs))))"
-      apply(auto dest!:less_2_cases[unfolded numeral One_nat_def])
+      apply(auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
             apply force+
         apply(auto intro: prime_id)
        apply(simp add: h)
       apply(auto simp add: nth_append)
       done
     from prt and prrf have prrq: "primerec ?rq 
                                        (Suc (Suc (length xs)))"
       by(erule_tac primerec_all_iff, auto)
     hence prnotrp: "primerec ?notrq (Suc (length ((xs @ [w]))))"
       by(rule_tac prime_cn, auto)
     have g1: "rec_exec (rec_sigma ?notrq) ((xs @ [w]) @ [w]) 
       = Maxr (\<lambda>args. 0 < rec_exec rf args) xs w"
       using prnotrp
       using sigma_lemma
       apply(simp only: sigma_lemma)
       apply(rule_tac Sigma_Max_lemma)
       apply(simp add: h)
       done
     thus "rec_exec (rec_sigma ?notrq)
      (xs @ [w, w]) =
     Maxr (\<lambda>args. 0 < rec_exec rf args) xs w"
       apply(simp)
       done
   qed
 qed
 
+
+subsection \<open>The Recursive Function rec\_noteq\<close>
+
+text \<open>
+  \<open>rec_noteq\<close> is the recursive function testing whether its
+  two arguments are not equal.
+\<close>
+definition rec_noteq:: "recf"
+  where
+    "rec_noteq = Cn (Suc (Suc 0)) rec_not [Cn (Suc (Suc 0)) 
+              rec_eq [id (Suc (Suc 0)) (0), id (Suc (Suc 0)) 
+                                        ((Suc 0))]]"
+text \<open>
+  The correctness of \<open>rec_noteq\<close>.
+\<close>
+lemma noteq_lemma: 
+  "\<And> x y. rec_exec rec_noteq [x, y] = 
+               (if x \<noteq> y then 1 else 0)"
+  by(simp add: rec_exec.simps rec_noteq_def)
+
+declare noteq_lemma[simp]
+
+subsection \<open>The Recursive Function rec\_quo\<close>
+
 text \<open>
   \<open>quo\<close> is the formal specification of division.
 \<close>
 fun quo :: "nat list \<Rightarrow> nat"
   where
     "quo [x, y] = (let Rr = 
                          (\<lambda> zs. ((zs ! (Suc 0) * zs ! (Suc (Suc 0))
                                  \<le> zs ! 0) \<and> zs ! Suc 0 \<noteq> (0::nat)))
                  in Maxr Rr [x, y] x)"
 
 declare quo.simps[simp del]
 
 text \<open>
-  The following lemmas shows more directly the menaing of \<open>quo\<close>:
+  The following lemmas shows more directly the meaning of \<open>quo\<close>:
 \<close>
 lemma quo_is_div: "y > 0 \<Longrightarrow> quo [x, y] = x div y"
 proof -
   {
     fix xa ya
     assume h: "y * ya \<le> x"  "y > 0"
     hence "(y * ya) div y \<le> x div y"
       by(insert div_le_mono[of "y * ya" x y], simp)
     from this and h have "ya \<le> x div y" by simp}
   thus ?thesis by(simp add: quo.simps Maxr.simps, auto,
         rule_tac Max_eqI, simp, auto)
 qed
 
 lemma quo_zero[intro]: "quo [x, 0] = 0"
   by(simp add: quo.simps Maxr.simps)
 
 lemma quo_div: "quo [x, y] = x div y"  
   by(cases "y=0", auto elim!:quo_is_div)
 
 text \<open>
-  \<open>rec_noteq\<close> is the recursive function testing whether its
-  two arguments are not equal.
-\<close>
-definition rec_noteq:: "recf"
-  where
-    "rec_noteq = Cn (Suc (Suc 0)) rec_not [Cn (Suc (Suc 0)) 
-              rec_eq [id (Suc (Suc 0)) (0), id (Suc (Suc 0)) 
-                                        ((Suc 0))]]"
-
-text \<open>
-  The correctness of \<open>rec_noteq\<close>.
-\<close>
-lemma noteq_lemma: 
-  "\<And> x y. rec_exec rec_noteq [x, y] = 
-               (if x \<noteq> y then 1 else 0)"
-  by(simp add: rec_exec.simps rec_noteq_def)
-
-declare noteq_lemma[simp]
-
-text \<open>
   \<open>rec_quo\<close> is the recursive function used to implement \<open>quo\<close>
 \<close>
 definition rec_quo :: "recf"
   where
     "rec_quo = (let rR = Cn (Suc (Suc (Suc 0))) rec_conj
               [Cn (Suc (Suc (Suc 0))) rec_le 
                [Cn (Suc (Suc (Suc 0))) rec_mult 
                   [id (Suc (Suc (Suc 0))) (Suc 0), 
                      id (Suc (Suc (Suc 0))) ((Suc (Suc 0)))],
                 id (Suc (Suc (Suc 0))) (0)], 
                 Cn (Suc (Suc (Suc 0))) rec_noteq 
                          [id (Suc (Suc (Suc 0))) (Suc (0)),
                 Cn (Suc (Suc (Suc 0))) (constn 0) 
                               [id (Suc (Suc (Suc 0))) (0)]]] 
               in Cn (Suc (Suc 0)) (rec_maxr rR)) [id (Suc (Suc 0)) 
                            (0),id (Suc (Suc 0)) (Suc (0)), 
                                    id (Suc (Suc 0)) (0)]"
 
 lemma primerec_rec_conj_2[intro]: "primerec rec_conj (Suc (Suc 0))"
   apply(simp add: rec_conj_def)
-  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral One_nat_def])
+  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
   done
 
 lemma primerec_rec_noteq_2[intro]: "primerec rec_noteq (Suc (Suc 0))"
   apply(simp add: rec_noteq_def)
-  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral One_nat_def])
+  apply(rule_tac prime_cn, auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def])
   done
 
 
 lemma quo_lemma1: "rec_exec rec_quo [x, y] = quo [x, y]"
 proof(simp add: rec_exec.simps rec_quo_def)
   let ?rR = "(Cn (Suc (Suc (Suc 0))) rec_conj
                [Cn (Suc (Suc (Suc 0))) rec_le
                    [Cn (Suc (Suc (Suc 0))) rec_mult 
                [recf.id (Suc (Suc (Suc 0))) (Suc (0)), 
                 recf.id (Suc (Suc (Suc 0))) (Suc (Suc (0)))],
                  recf.id (Suc (Suc (Suc 0))) (0)],  
           Cn (Suc (Suc (Suc 0))) rec_noteq 
                               [recf.id (Suc (Suc (Suc 0))) 
              (Suc (0)), Cn (Suc (Suc (Suc 0))) (constn 0) 
                       [recf.id (Suc (Suc (Suc 0))) (0)]]])"
   have "rec_exec (rec_maxr ?rR) ([x, y]@ [ x]) = Maxr (\<lambda> args. 0 < rec_exec ?rR args) [x, y] x"
   proof(rule_tac Maxr_lemma, simp)
     show "primerec ?rR (Suc (Suc (Suc 0)))"
-      apply(auto dest!:less_2_cases[unfolded numeral One_nat_def]) 
+      apply(auto dest!:less_2_cases[unfolded numeral_eqs_upto_12 One_nat_def]) 
              apply force+
       done
   qed
   hence g1: "rec_exec (rec_maxr ?rR) ([x, y,  x]) =
              Maxr (\<lambda> args. if rec_exec ?rR args = 0 then False
                            else True) [x, y] x" 
     by simp
   have g2: "Maxr (\<lambda> args. if rec_exec ?rR args = 0 then False
                            else True) [x, y] x = quo [x, y]"
     apply(simp add: rec_exec.simps)
     apply(simp add: Maxr.simps quo.simps, auto)
     done
   from g1 and g2 show 
     "rec_exec (rec_maxr ?rR) ([x, y,  x]) = quo [x, y]"
     by simp
 qed
 
 text \<open>
   The correctness of \<open>quo\<close>.
 \<close>
 lemma quo_lemma2: "rec_exec rec_quo [x, y] = x div y"
   using quo_lemma1[of x y] quo_div[of x y]
   by simp
 
+subsection \<open>The Recursive Function rec\_mod\<close>
+
 text \<open>
   \<open>rec_mod\<close> is the recursive function used to implement 
   the reminder function.
 \<close>
 definition rec_mod :: "recf"
   where
     "rec_mod = Cn (Suc (Suc 0)) rec_minus [id (Suc (Suc 0)) (0), 
                Cn (Suc (Suc 0)) rec_mult [rec_quo, id (Suc (Suc 0))
                                                      (Suc (0))]]"
-
 text \<open>
   The correctness of \<open>rec_mod\<close>:
 \<close>
 lemma mod_lemma: "\<And> x y. rec_exec rec_mod [x, y] = (x mod y)"
   by(simp add: rec_exec.simps rec_mod_def quo_lemma2 minus_div_mult_eq_mod)
 
+subsection \<open>The Recursive Function rec\_embranch\<close>
+
 text\<open>lemmas for embranch function\<close>
+
 type_synonym ftype = "nat list \<Rightarrow> nat"
 type_synonym rtype = "nat list \<Rightarrow> bool"
 
 text \<open>
-  The specifation of the mutli-way branching statement on
-  page 79 of Boolos's book.
+  The specifcation of the multi-way branching statement (definition by cases).
+  See page 74 of Boolos's book~\cite{Boolos07}.
 \<close>
 fun Embranch :: "(ftype * rtype) list \<Rightarrow> nat list \<Rightarrow> nat"
   where
     "Embranch [] xs = 0" |
     "Embranch (gc # gcs) xs = (
                    let (g, c) = gc in 
                    if c xs then g xs else Embranch gcs xs)"
 
 fun rec_embranch' :: "(recf * recf) list \<Rightarrow> nat \<Rightarrow> recf"
   where
     "rec_embranch' [] vl = Cn vl z [id vl (vl - 1)]" |
     "rec_embranch' ((rg, rc) # rgcs) vl = Cn vl rec_add
                    [Cn vl rec_mult [rg, rc], rec_embranch' rgcs vl]"
 
 text \<open>
   \<open>rec_embrach\<close> is the recursive function used to implement
   \<open>Embranch\<close>.
 \<close>
 fun rec_embranch :: "(recf * recf) list \<Rightarrow> recf"
   where
     "rec_embranch ((rg, rc) # rgcs) = 
          (let vl = arity rg in 
           rec_embranch' ((rg, rc) # rgcs) vl)"
 
 declare Embranch.simps[simp del] rec_embranch.simps[simp del]
 
 lemma embranch_all0: 
   "\<lbrakk>\<forall> j < length rcs. rec_exec (rcs ! j) xs = 0;
     length rgs = length rcs;  
   rcs \<noteq> []; 
   list_all (\<lambda> rf. primerec rf (length xs)) (rgs @ rcs)\<rbrakk>  \<Longrightarrow> 
   rec_exec (rec_embranch (zip rgs rcs)) xs = 0"
 proof(induct rcs arbitrary: rgs)
   case (Cons a rcs)
   then show ?case proof(cases rgs, simp)  fix a rcs rgs aa list
     assume ind: 
       "\<And>rgs. \<lbrakk>\<forall>j<length rcs. rec_exec (rcs ! j) xs = 0; 
              length rgs = length rcs; rcs \<noteq> []; 
             list_all (\<lambda>rf. primerec rf (length xs)) (rgs @ rcs)\<rbrakk> \<Longrightarrow> 
                       rec_exec (rec_embranch (zip rgs rcs)) xs = 0"
       and h:  "\<forall>j<length (a # rcs). rec_exec ((a # rcs) ! j) xs = 0"
       "length rgs = length (a # rcs)" 
       "a # rcs \<noteq> []" 
       "list_all (\<lambda>rf. primerec rf (length xs)) (rgs @ a # rcs)"
       "rgs = aa # list"
     have g: "rcs \<noteq> [] \<Longrightarrow> rec_exec (rec_embranch (zip list rcs)) xs = 0"
       using h by(rule_tac ind, auto)
     show "rec_exec (rec_embranch (zip rgs (a # rcs))) xs = 0"
     proof(cases "rcs = []", simp)
       show "rec_exec (rec_embranch (zip rgs [a])) xs = 0"
         using h by (auto simp add: rec_embranch.simps rec_exec.simps)
     next
       assume "rcs \<noteq> []"
       hence "rec_exec (rec_embranch (zip list rcs)) xs = 0"
         using g by simp
       thus "rec_exec (rec_embranch (zip rgs (a # rcs))) xs = 0"
         using h
         by(cases rcs;cases list, auto simp add: rec_embranch.simps rec_exec.simps)
     qed
   qed
 qed simp
 
 
 lemma embranch_exec_0: "\<lbrakk>rec_exec aa xs = 0; zip rgs list \<noteq> []; 
        list_all (\<lambda> rf. primerec rf (length xs)) ([a, aa] @ rgs @ list)\<rbrakk>
        \<Longrightarrow> rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs
          = rec_exec (rec_embranch (zip rgs list)) xs"
   apply(auto simp add: rec_exec.simps rec_embranch.simps)
   apply(cases "zip rgs list", force)
   apply(cases "hd (zip rgs list)", simp add: rec_embranch.simps rec_exec.simps)
   apply(subgoal_tac "arity a = length xs")
    apply(cases rgs;cases list;force)
   by force
 
 lemma zip_null_iff: "\<lbrakk>length xs = k; length ys = k; zip xs ys = []\<rbrakk> \<Longrightarrow> xs = [] \<and> ys = []"
-by(cases xs, simp, simp)
+  apply(cases xs, simp, simp)
+  done
 
 lemma zip_null_gr: "\<lbrakk>length xs = k; length ys = k; zip xs ys \<noteq> []\<rbrakk> \<Longrightarrow> 0 < k"
-by(cases xs, simp, simp)
+  apply(cases xs, simp, simp)
+  done
 
 lemma Embranch_0:  
   "\<lbrakk>length rgs = k; length rcs = k; k > 0; 
   \<forall> j < k. rec_exec (rcs ! j) xs = 0\<rbrakk> \<Longrightarrow>
   Embranch (zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) rcs)) xs = 0"
 proof(induct rgs arbitrary: rcs k)
   case (Cons a rgs rcs k)
   then show ?case
     apply(cases rcs, simp, cases "rgs = []")
      apply(simp add: Embranch.simps)
      apply(erule_tac x = 0 in allE)
      apply (auto simp add: Embranch.simps intro!: Cons(1)).
 qed simp
 
 text \<open>
   The correctness of \<open>rec_embranch\<close>.
 \<close>
 lemma embranch_lemma:
   assumes branch_num:
     "length rgs = n" "length rcs = n" "n > 0"
     and partition: 
     "(\<exists> i < n. (rec_exec (rcs ! i) xs = 1 \<and> (\<forall> j < n. j \<noteq> i \<longrightarrow> 
                                       rec_exec (rcs ! j) xs = 0)))"
     and prime_all: "list_all (\<lambda> rf. primerec rf (length xs)) (rgs @ rcs)"
   shows "rec_exec (rec_embranch (zip rgs rcs)) xs =
                   Embranch (zip (map rec_exec rgs) 
                      (map (\<lambda> r args. 0 < rec_exec r args) rcs)) xs"
   using branch_num partition prime_all
 proof(induct rgs arbitrary: rcs n, simp)
   fix a rgs rcs n
   assume ind: 
     "\<And>rcs n. \<lbrakk>length rgs = n; length rcs = n; 0 < n;
     \<exists>i<n. rec_exec (rcs ! i) xs = 1 \<and> (\<forall>j<n. j \<noteq> i \<longrightarrow> rec_exec (rcs ! j) xs = 0);
     list_all (\<lambda>rf. primerec rf (length xs)) (rgs @ rcs)\<rbrakk>
     \<Longrightarrow> rec_exec (rec_embranch (zip rgs rcs)) xs =
     Embranch (zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) rcs)) xs"
     and h: "length (a # rgs) = n" "length (rcs::recf list) = n" "0 < n"
     " \<exists>i<n. rec_exec (rcs ! i) xs = 1 \<and> 
          (\<forall>j<n. j \<noteq> i \<longrightarrow> rec_exec (rcs ! j) xs = 0)" 
     "list_all (\<lambda>rf. primerec rf (length xs)) ((a # rgs) @ rcs)"
   from h show "rec_exec (rec_embranch (zip (a # rgs) rcs)) xs =
     Embranch (zip (map rec_exec (a # rgs)) (map (\<lambda>r args. 
                 0 < rec_exec r args) rcs)) xs"
     apply(cases rcs, simp, simp)
     apply(cases "rec_exec (hd rcs) xs = 0")
      apply(case_tac [!] "zip rgs (tl rcs) = []", simp)
        apply(subgoal_tac "rgs = [] \<and> (tl rcs) = []", simp add: Embranch.simps rec_exec.simps rec_embranch.simps)
        apply(rule_tac  zip_null_iff, simp, simp, simp)
   proof -
     fix aa list
     assume "rcs = aa # list"
     assume g:
       "Suc (length rgs) = n" "Suc (length list) = n" 
       "\<exists>i<n. rec_exec ((aa # list) ! i) xs = Suc 0 \<and> 
           (\<forall>j<n. j \<noteq> i \<longrightarrow> rec_exec ((aa # list) ! j) xs = 0)"
       "primerec a (length xs) \<and> 
       list_all (\<lambda>rf. primerec rf (length xs)) rgs \<and>
       primerec aa (length xs) \<and> 
       list_all (\<lambda>rf. primerec rf (length xs)) list"
       "rec_exec (hd rcs) xs = 0" "rcs = aa # list" "zip rgs (tl rcs) \<noteq> []"
     hence "rec_exec aa xs = 0" "zip rgs list \<noteq> []" by auto
     note g = g(1,2,3,4,6,7) this
     hence "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs
         = rec_exec (rec_embranch (zip rgs list)) xs"
       by(simp add: embranch_exec_0)
     from g and this show "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs =
          Embranch ((rec_exec a, \<lambda>args. 0 < rec_exec aa args) # 
            zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) list)) xs"
       apply(simp add: Embranch.simps)
       apply(rule_tac n = "n - Suc 0" in ind)
           apply(cases n;force)
          apply(cases n;force)
         apply(cases n;force simp add: zip_null_gr)
        apply(auto)
       apply(rename_tac i)
       apply(case_tac i, force, simp)
       apply(rule_tac x = "i - 1" in exI, simp)
       by auto
   next
     fix aa list
     assume g: "Suc (length rgs) = n" "Suc (length list) = n"
       "\<exists>i<n. rec_exec ((aa # list) ! i) xs = Suc 0 \<and> 
       (\<forall>j<n. j \<noteq> i \<longrightarrow> rec_exec ((aa # list) ! j) xs = 0)"
       "primerec a (length xs) \<and> list_all (\<lambda>rf. primerec rf (length xs)) rgs \<and>
       primerec aa (length xs) \<and> list_all (\<lambda>rf. primerec rf (length xs)) list"
       "rcs = aa # list" "rec_exec (hd rcs) xs \<noteq> 0" "zip rgs (tl rcs) = []"
     thus "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs = 
         Embranch ((rec_exec a, \<lambda>args. 0 < rec_exec aa args) # 
        zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) list)) xs"
       apply(subgoal_tac "rgs = [] \<and> list = []", simp)
        prefer 2
        apply(rule_tac zip_null_iff, simp, simp, simp)
       apply(simp add: rec_exec.simps rec_embranch.simps Embranch.simps, auto)
       done
   next
     fix aa list
     assume g: "Suc (length rgs) = n" "Suc (length list) = n"
       "\<exists>i<n. rec_exec ((aa # list) ! i) xs = Suc 0 \<and>  
            (\<forall>j<n. j \<noteq> i \<longrightarrow> rec_exec ((aa # list) ! j) xs = 0)"
       "primerec a (length xs) \<and> list_all (\<lambda>rf. primerec rf (length xs)) rgs
       \<and> primerec aa (length xs) \<and> list_all (\<lambda>rf. primerec rf (length xs)) list"
       "rcs = aa # list" "rec_exec (hd rcs) xs \<noteq> 0" "zip rgs (tl rcs) \<noteq> []"
     have "rec_exec aa xs =  Suc 0"
       using g
       apply(cases "rec_exec aa xs", simp, auto)
       done      
     moreover have "rec_exec (rec_embranch' (zip rgs list) (length xs)) xs = 0"
     proof -
       have "rec_embranch' (zip rgs list) (length xs) = rec_embranch (zip rgs list)"
         using g
         apply(cases "zip rgs list", force)
         apply(cases "hd (zip rgs list)")
         apply(simp add: rec_embranch.simps)
         apply(cases rgs, simp, simp, cases list, simp, auto)
         done
       moreover have "rec_exec (rec_embranch (zip rgs list)) xs = 0"
       proof(rule embranch_all0)
         show " \<forall>j<length list. rec_exec (list ! j) xs = 0"
           using g
           apply(auto)
           apply(rename_tac i j)
           apply(case_tac i, simp)
            apply(erule_tac x = "Suc j" in allE, simp)
           apply(simp)
           apply(erule_tac x = 0 in allE, simp)
           done
       next
         show "length rgs = length list"
           using g by(cases n;force)
       next
         show "list \<noteq> []"
           using g by(cases list; force)
       next
         show "list_all (\<lambda>rf. primerec rf (length xs)) (rgs @ list)"
           using g by auto
       qed
       ultimately show "rec_exec (rec_embranch' (zip rgs list) (length xs)) xs = 0"
         by simp
     qed
     moreover have 
       "Embranch (zip (map rec_exec rgs) 
           (map (\<lambda>r args. 0 < rec_exec r args) list)) xs = 0"
       using g
       apply(rule_tac k = "length rgs" in Embranch_0)
          apply(simp, cases n, simp, simp)
        apply(cases rgs, simp, simp)
       apply(auto)
       apply(rename_tac i j)
       apply(case_tac i, simp)
        apply(erule_tac x = "Suc j" in allE, simp)
       apply(simp)
       apply(rule_tac x = 0 in allE, auto)
       done
     moreover have "arity a = length xs"
       using g
       apply(auto)
       done
     ultimately show "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs = 
       Embranch ((rec_exec a, \<lambda>args. 0 < rec_exec aa args) #
            zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) list)) xs"
       apply(simp add: rec_exec.simps rec_embranch.simps Embranch.simps)
       done
   qed
 qed
 
+subsection \<open>The Recursive Function rec\_prime\<close>
+
 text\<open>
   \<open>prime n\<close> means \<open>n\<close> is a prime number.
 \<close>
 fun Prime :: "nat \<Rightarrow> bool"
   where
     "Prime x = (1 < x \<and> (\<forall> u < x. (\<forall> v < x. u * v \<noteq> x)))"
 
 declare Prime.simps [simp del]
 
 lemma primerec_all1: 
   "primerec (rec_all rt rf) n \<Longrightarrow> primerec rt n"
   by (simp add: primerec_all)
 
 lemma primerec_all2: "primerec (rec_all rt rf) n \<Longrightarrow> 
   primerec rf (Suc n)"
   by(insert primerec_all[of rt rf n], simp)
 
 text \<open>
   \<open>rec_prime\<close> is the recursive function used to implement
   \<open>Prime\<close>.
 \<close>
 definition rec_prime :: "recf"
   where
     "rec_prime = Cn (Suc 0) rec_conj 
   [Cn (Suc 0) rec_less [constn 1, id (Suc 0) (0)],
         rec_all (Cn 1 rec_minus [id 1 0, constn 1]) 
        (rec_all (Cn 2 rec_minus [id 2 0, Cn 2 (constn 1) 
   [id 2 0]]) (Cn 3 rec_noteq 
        [Cn 3 rec_mult [id 3 1, id 3 2], id 3 0]))]"
 
 declare numeral_2_eq_2[simp del] numeral_3_eq_3[simp del]
 
 lemma exec_tmp: 
   "rec_exec (rec_all (Cn 2 rec_minus [recf.id 2 0, Cn 2 (constn (Suc 0)) [recf.id 2 0]]) 
   (Cn 3 rec_noteq [Cn 3 rec_mult [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0]))  [x, k] = 
   ((if (\<forall>w\<le>rec_exec (Cn 2 rec_minus [recf.id 2 0, Cn 2 (constn (Suc 0)) [recf.id 2 0]]) ([x, k]). 
   0 < rec_exec (Cn 3 rec_noteq [Cn 3 rec_mult [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0])
   ([x, k] @ [w])) then 1 else 0))"
   apply(rule_tac all_lemma)
-   apply(auto simp:numeral)
+   apply(auto simp:numeral_eqs_upto_12)
    apply (metis (no_types, lifting) Suc_mono length_Cons less_2_cases list.size(3) nth_Cons_0
       nth_Cons_Suc numeral_2_eq_2 prime_cn prime_id primerec_rec_mult_2 zero_less_Suc)
   by (metis (no_types, lifting) One_nat_def length_Cons less_2_cases nth_Cons_0 nth_Cons_Suc 
       prime_cn_reverse primerec_rec_eq_2 rec_eq_def zero_less_Suc)
 
 text \<open>
   The correctness of \<open>Prime\<close>.
 \<close>
 lemma prime_lemma: "rec_exec rec_prime [x] = (if Prime x then 1 else 0)"
 proof(simp add: rec_exec.simps rec_prime_def)
   let ?rt1 = "(Cn 2 rec_minus [recf.id 2 0, 
     Cn 2 (constn (Suc 0)) [recf.id 2 0]])"
   let ?rf1 = "(Cn 3 rec_noteq [Cn 3 rec_mult 
     [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 (0)])"
   let ?rt2 = "(Cn (Suc 0) rec_minus 
     [recf.id (Suc 0) 0, constn (Suc 0)])"
   let ?rf2 = "rec_all ?rt1 ?rf1"
   have h1: "rec_exec (rec_all ?rt2 ?rf2) ([x]) = 
         (if (\<forall>k\<le>rec_exec ?rt2 ([x]). 0 < rec_exec ?rf2 ([x] @ [k])) then 1 else 0)"
   proof(rule_tac all_lemma, simp_all)
     show "primerec ?rf2 (Suc (Suc 0))"
       apply(rule_tac primerec_all_iff)
-        apply(auto simp: numeral)
+        apply(auto simp: numeral_eqs_upto_12)
        apply (metis (no_types, lifting) One_nat_def length_Cons less_2_cases nth_Cons_0 nth_Cons_Suc
           prime_cn_reverse primerec_rec_eq_2 rec_eq_def zero_less_Suc)
       by (metis (no_types, lifting) Suc_mono length_Cons less_2_cases list.size(3) nth_Cons_0 
           nth_Cons_Suc numeral_2_eq_2 prime_cn prime_id primerec_rec_mult_2 zero_less_Suc)
   next
     show "primerec (Cn (Suc 0) rec_minus
              [recf.id (Suc 0) 0, constn (Suc 0)]) (Suc 0)"
-      using less_2_cases numeral by fastforce
+      using less_2_cases numeral_eqs_upto_12 by fastforce
   qed
   from h1 show 
     "(Suc 0 < x \<longrightarrow>  (rec_exec (rec_all ?rt2 ?rf2) [x] = 0 \<longrightarrow> 
     \<not> Prime x) \<and>
      (0 < rec_exec (rec_all ?rt2 ?rf2) [x] \<longrightarrow> Prime x)) \<and>
     (\<not> Suc 0 < x \<longrightarrow> \<not> Prime x \<and> (rec_exec (rec_all ?rt2 ?rf2) [x] = 0
     \<longrightarrow> \<not> Prime x))"
     apply(auto simp:rec_exec.simps)
        apply(simp add: exec_tmp rec_exec.simps)
   proof -
     assume *:"\<forall>k\<le>x - Suc 0. (0::nat) < (if \<forall>w\<le>x - Suc 0. 
            0 < (if k * w \<noteq> x then 1 else (0 :: nat)) then 1 else 0)" "Suc 0 < x"
     thus "Prime x"
       apply(simp add: rec_exec.simps split: if_splits)
       apply(simp add: Prime.simps, auto)
       apply(rename_tac u v)
       apply(erule_tac x = u in allE, auto)
        apply(case_tac u, simp)
        apply(case_tac "u - 1", simp, simp)
       apply(case_tac v, simp)
       apply(case_tac "v - 1", simp, simp)
       done
   next
     assume "\<not> Suc 0 < x" "Prime x"
     thus "False"
       apply(simp add: Prime.simps)
       done
   next
     fix k
     assume "rec_exec (rec_all ?rt1 ?rf1)
       [x, k] = 0" "k \<le> x - Suc 0" "Prime x"
     thus "False"
       apply(simp add: exec_tmp rec_exec.simps Prime.simps split: if_splits)
       done
   next
     fix k
     assume "rec_exec (rec_all ?rt1 ?rf1)
       [x, k] = 0" "k \<le> x - Suc 0" "Prime x"
     thus "False"
       apply(simp add: exec_tmp rec_exec.simps Prime.simps split: if_splits)
       done
   qed
 qed
 
+subsection \<open>The Recursive Function rec\_fac for factorization\<close>
+
 definition rec_dummyfac :: "recf"
   where
     "rec_dummyfac = Pr 1 (constn 1) 
   (Cn 3 rec_mult [id 3 2, Cn 3 s [id 3 1]])"
 
 text \<open>
-  The recursive function used to implment factorization.
+  The recursive function used to implement factorization.
 \<close>
 definition rec_fac :: "recf"
   where
     "rec_fac = Cn 1 rec_dummyfac [id 1 0, id 1 0]"
 
 text \<open>
   Formal specification of factorization.
 \<close>
 fun fac :: "nat \<Rightarrow> nat"  ("_!" [100] 99)
   where
     "fac 0 = 1" |
     "fac (Suc x) = (Suc x) * fac x"
 
 lemma fac_dummy: "rec_exec rec_dummyfac [x, y] = y !"
   apply(induct y)
    apply(auto simp: rec_dummyfac_def rec_exec.simps)
   done
 
 text \<open>
   The correctness of \<open>rec_fac\<close>.
 \<close>
+
 lemma fac_lemma: "rec_exec rec_fac [x] =  x!"
   apply(simp add: rec_fac_def rec_exec.simps fac_dummy)
   done
 
+
 declare fac.simps[simp del]
 
+subsection \<open>The Recursive Function rec\_np for finding the next prime\<close>
+
 text \<open>
   \<open>Np x\<close> returns the first prime number after \<open>x\<close>.
 \<close>
 fun Np ::"nat \<Rightarrow> nat"
   where
     "Np x = Min {y. y \<le> Suc (x!) \<and> x < y \<and> Prime y}"
 
 declare Np.simps[simp del] rec_Minr.simps[simp del]
 
 text \<open>
   \<open>rec_np\<close> is the recursive function used to implement
   \<open>Np\<close>.
 \<close>
 definition rec_np :: "recf"
   where
     "rec_np = (let Rr = Cn 2 rec_conj [Cn 2 rec_less [id 2 0, id 2 1], 
   Cn 2 rec_prime [id 2 1]]
              in Cn 1 (rec_Minr Rr) [id 1 0, Cn 1 s [rec_fac]])"
 
 lemma n_le_fact[simp]: "n < Suc (n!)"
 proof(induct n)
   case (Suc n)
   then show ?case  apply(simp add: fac.simps)
     apply(cases n, auto simp: fac.simps)
     done
 qed simp
 
 lemma divsor_ex: 
   "\<lbrakk>\<not> Prime x; x > Suc 0\<rbrakk> \<Longrightarrow> (\<exists> u > Suc 0. (\<exists> v > Suc 0. u * v = x))"
   by(auto simp: Prime.simps)
 
 lemma divsor_prime_ex: "\<lbrakk>\<not> Prime x; x > Suc 0\<rbrakk> \<Longrightarrow> 
   \<exists> p. Prime p \<and> p dvd x"
   apply(induct x rule: wf_induct[where r = "measure (\<lambda> y. y)"], simp)
   apply(drule_tac divsor_ex, simp, auto)
   apply(rename_tac u v)
   apply(erule_tac x = u in allE, simp)
   apply(case_tac "Prime u", simp)
    apply(rule_tac x = u in exI, simp, auto)
   done
 
 lemma fact_pos[intro]: "0 < n!"
   apply(induct n)
    apply(auto simp: fac.simps)
   done
 
 lemma fac_Suc: "Suc n! =  (Suc n) * (n!)" by(simp add: fac.simps)
 
 lemma fac_dvd: "\<lbrakk>0 < q; q \<le> n\<rbrakk> \<Longrightarrow> q dvd n!"
 proof(induct n)
   case (Suc n)
   then show ?case 
     apply(cases "q \<le> n", simp add: fac_Suc)
     apply(subgoal_tac "q = Suc n", simp only: fac_Suc)
      apply(rule_tac dvd_mult2, simp, simp)
     done
 qed simp
 
 lemma fac_dvd2: "\<lbrakk>Suc 0 < q; q dvd n!; q \<le> n\<rbrakk> \<Longrightarrow> \<not> q dvd Suc (n!)"
 proof(auto simp: dvd_def)
   fix k ka
   assume h1: "Suc 0 < q" "q \<le> n"
     and h2: "Suc (q * k) = q * ka"
   have "k < ka"
   proof - 
     have "q * k < q * ka" 
       using h2 by arith
     thus "k < ka"
       using h1
       by(auto)
   qed
   hence "\<exists>d. d > 0 \<and>  ka = d + k"  
     by(rule_tac x = "ka - k" in exI, simp)
   from this obtain d where "d > 0 \<and> ka = d + k" ..
   from h2 and this and h1 show "False"
     by(simp add: add_mult_distrib2)
 qed
 
 lemma prime_ex: "\<exists> p. n < p \<and> p \<le> Suc (n!) \<and> Prime p"
 proof(cases "Prime (n! + 1)")
   case True thus "?thesis" 
     by(rule_tac x = "Suc (n!)" in exI, simp)
 next
   assume h: "\<not> Prime (n! + 1)"  
   hence "\<exists> p. Prime p \<and> p dvd (n! + 1)"
     by(erule_tac divsor_prime_ex, auto)
   from this obtain q where k: "Prime q \<and> q dvd (n! + 1)" ..
   thus "?thesis"
   proof(cases "q > n")
     case True thus "?thesis"
       using k by(auto intro:dvd_imp_le)
   next
     case False thus "?thesis"
     proof -
       assume g: "\<not> n < q"
       have j: "q > Suc 0"
         using k by(cases q, auto simp: Prime.simps)
       hence "q dvd n!"
         using g 
         apply(rule_tac fac_dvd, auto)
         done
       hence "\<not> q dvd Suc (n!)"
         using g j
         by(rule_tac fac_dvd2, auto)
       thus "?thesis"
         using k by simp
     qed
   qed
 qed
 
 lemma Suc_Suc_induct[elim!]: "\<lbrakk>i < Suc (Suc 0); 
   primerec (ys ! 0) n; primerec (ys ! 1) n\<rbrakk> \<Longrightarrow> primerec (ys ! i) n"
   by(cases i, auto)
 
 lemma primerec_rec_prime_1[intro]: "primerec rec_prime (Suc 0)"
   apply(auto simp: rec_prime_def, auto)
   apply(rule_tac primerec_all_iff, auto, auto)
   apply(rule_tac primerec_all_iff, auto, auto simp:  
       numeral_2_eq_2 numeral_3_eq_3)
   done
 
 text \<open>
   The correctness of \<open>rec_np\<close>.
 \<close>
 lemma np_lemma: "rec_exec rec_np [x] = Np x"
 proof(auto simp: rec_np_def rec_exec.simps Let_def fac_lemma)
   let ?rr = "(Cn 2 rec_conj [Cn 2 rec_less [recf.id 2 0,
     recf.id 2 (Suc 0)], Cn 2 rec_prime [recf.id 2 (Suc 0)]])"
   let ?R = "\<lambda> zs. zs ! 0 < zs ! 1 \<and> Prime (zs ! 1)"
   have g1: "rec_exec (rec_Minr ?rr) ([x] @ [Suc (x!)]) = 
     Minr (\<lambda> args. 0 < rec_exec ?rr args) [x] (Suc (x!))"
     by(rule_tac Minr_lemma, auto simp: rec_exec.simps
         prime_lemma, auto simp:  numeral_2_eq_2 numeral_3_eq_3)
   have g2: "Minr (\<lambda> args. 0 < rec_exec ?rr args) [x] (Suc (x!)) = Np x"
     using prime_ex[of x]
     apply(auto simp: Minr.simps Np.simps rec_exec.simps prime_lemma)
     apply(subgoal_tac
         "{uu. (Prime uu \<longrightarrow> (x < uu \<longrightarrow> uu \<le> Suc (x!)) \<and> x < uu) \<and> Prime uu}
     = {y. y \<le> Suc (x!) \<and> x < y \<and> Prime y}", auto)
     done
   from g1 and g2 show "rec_exec (rec_Minr ?rr) ([x, Suc (x!)]) = Np x"
     by simp
 qed
 
+subsection \<open>The Recursive Function rec\_power\<close>
+
 text \<open>
   \<open>rec_power\<close> is the recursive function used to implement
   power function.
 \<close>
 definition rec_power :: "recf"
   where
     "rec_power = Pr 1 (constn 1) (Cn 3 rec_mult [id 3 0, id 3 2])"
 
 text \<open>
   The correctness of \<open>rec_power\<close>.
 \<close>
 lemma power_lemma: "rec_exec rec_power [x, y] = x^y"
   by(induct y, auto simp: rec_exec.simps rec_power_def)
 
+subsection \<open>The Recursive Function rec\_pi\<close>
+
 text\<open>
   \<open>Pi k\<close> returns the \<open>k\<close>-th prime number.
 \<close>
 fun Pi :: "nat \<Rightarrow> nat"
   where
     "Pi 0 = 2" |
     "Pi (Suc x) = Np (Pi x)"
 
 definition rec_dummy_pi :: "recf"
   where
     "rec_dummy_pi = Pr 1 (constn 2) (Cn 3 rec_np [id 3 2])"
 
 text \<open>
   \<open>rec_pi\<close> is the recursive function used to implement
   \<open>Pi\<close>.
 \<close>
 definition rec_pi :: "recf"
   where
     "rec_pi = Cn 1 rec_dummy_pi [id 1 0, id 1 0]"
 
 lemma pi_dummy_lemma: "rec_exec rec_dummy_pi [x, y] = Pi y"
   apply(induct y)
   by(auto simp: rec_exec.simps rec_dummy_pi_def Pi.simps np_lemma)
 
 text \<open>
   The correctness of \<open>rec_pi\<close>.
 \<close>
 lemma pi_lemma: "rec_exec rec_pi [x] = Pi x"
   apply(simp add: rec_pi_def rec_exec.simps pi_dummy_lemma)
   done
 
+
+subsection \<open>The Recursive Function rec\_lo\<close>
+
 fun loR :: "nat list \<Rightarrow> bool"
   where
     "loR [x, y, u] = (x mod (y^u) = 0)"
 
 declare loR.simps[simp del]
 
 text \<open>
   \<open>Lo\<close> specifies the \<open>lo\<close> function given on page 79 of 
-  Boolos's book. It is one of the two notions of integeral logarithmetic
+  Boolos's book~\cite{Boolos07}. It is one of the two notions of integeral logarithmetic
   operation on that page. The other is \<open>lg\<close>.
 \<close>
 fun lo :: " nat \<Rightarrow> nat \<Rightarrow> nat"
   where 
     "lo x y  = (if x > 1 \<and> y > 1 \<and> {u. loR [x, y, u]} \<noteq> {} then Max {u. loR [x, y, u]}
                                                          else 0)"
 
 declare lo.simps[simp del]
 
 lemma primerec_sigma[intro!]:  
   "\<lbrakk>n > Suc 0; primerec rf n\<rbrakk> \<Longrightarrow> 
   primerec (rec_sigma rf) n"
   apply(simp add: rec_sigma.simps)
   apply(auto, auto simp: nth_append)
   done
 
 lemma primerec_rec_maxr[intro!]:  "\<lbrakk>primerec rf n; n > 0\<rbrakk> \<Longrightarrow> primerec (rec_maxr rf) n"
   apply(simp add: rec_maxr.simps)
   apply(rule_tac prime_cn, auto)
    apply(rule_tac primerec_all_iff, auto, auto simp: nth_append)
   done
 
 lemma Suc_Suc_Suc_induct[elim!]: 
   "\<lbrakk>i < Suc (Suc (Suc (0::nat))); primerec (ys ! 0) n;
   primerec (ys ! 1) n;  
   primerec (ys ! 2) n\<rbrakk> \<Longrightarrow> primerec (ys ! i) n"
   apply(cases i, auto)
   apply(cases "i-1", simp, simp add: numeral_2_eq_2)
   done
 
 lemma primerec_2[intro]:
   "primerec rec_quo (Suc (Suc 0))" "primerec rec_mod (Suc (Suc 0))"
   "primerec rec_power (Suc (Suc 0))"
-  by(force simp: prime_cn prime_id rec_mod_def rec_quo_def rec_power_def prime_pr numeral)+
+  by(force simp: prime_cn prime_id rec_mod_def rec_quo_def rec_power_def prime_pr numeral_eqs_upto_12)+
 
 text \<open>
   \<open>rec_lo\<close> is the recursive function used to implement \<open>Lo\<close>.
 \<close>
 definition rec_lo :: "recf"
   where
     "rec_lo = (let rR = Cn 3 rec_eq [Cn 3 rec_mod [id 3 0, 
                Cn 3 rec_power [id 3 1, id 3 2]], 
                      Cn 3 (constn 0) [id 3 1]] in
              let rb =  Cn 2 (rec_maxr rR) [id 2 0, id 2 1, id 2 0] in 
              let rcond = Cn 2 rec_conj [Cn 2 rec_less [Cn 2 (constn 1)
                                              [id 2 0], id 2 0], 
                                         Cn 2 rec_less [Cn 2 (constn 1)
                                                 [id 2 0], id 2 1]] in 
              let rcond2 = Cn 2 rec_minus 
                               [Cn 2 (constn 1) [id 2 0], rcond] 
              in Cn 2 rec_add [Cn 2 rec_mult [rb, rcond], 
                   Cn 2 rec_mult [Cn 2 (constn 0) [id 2 0], rcond2]])"
 
 lemma rec_lo_Maxr_lor:
   "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow>  
         rec_exec rec_lo [x, y] = Maxr loR [x, y] x"
 proof(auto simp: rec_exec.simps rec_lo_def Let_def 
     numeral_2_eq_2 numeral_3_eq_3)
   let ?rR = "(Cn (Suc (Suc (Suc 0))) rec_eq
      [Cn (Suc (Suc (Suc 0))) rec_mod [recf.id (Suc (Suc (Suc 0))) 0,
      Cn (Suc (Suc (Suc 0))) rec_power [recf.id (Suc (Suc (Suc 0)))
      (Suc 0), recf.id (Suc (Suc (Suc 0))) (Suc (Suc 0))]],
      Cn (Suc (Suc (Suc 0))) (constn 0) [recf.id (Suc (Suc (Suc 0))) (Suc 0)]])"
   have h: "rec_exec (rec_maxr ?rR) ([x, y] @ [x]) =
     Maxr (\<lambda> args. 0 < rec_exec ?rR args) [x, y] x"
     by(rule_tac Maxr_lemma, auto simp: rec_exec.simps
         mod_lemma power_lemma, auto simp: numeral_2_eq_2 numeral_3_eq_3)
   have "Maxr loR [x, y] x =  Maxr (\<lambda> args. 0 < rec_exec ?rR args) [x, y] x"
     apply(simp add: rec_exec.simps mod_lemma power_lemma)
     apply(simp add: Maxr.simps loR.simps)
     done
   from h and this show "rec_exec (rec_maxr ?rR) [x, y, x] = 
     Maxr loR [x, y] x"
     apply(simp)
     done
 qed
 
 lemma x_less_exp: "\<lbrakk>y > Suc 0\<rbrakk> \<Longrightarrow> x < y^x"
 proof(induct x)
   case (Suc x)
   then show ?case  
     apply(cases x, simp, auto)
     apply(rule_tac y = "y* y^(x-1)" in le_less_trans, auto)
     done
 qed simp
 
 
 lemma uplimit_loR:
   assumes "Suc 0 < x" "Suc 0 < y" "loR [x, y, xa]"
   shows "xa \<le> x"
 proof -
   have "Suc 0 < x \<Longrightarrow> Suc 0 < y \<Longrightarrow> y ^ xa dvd x \<Longrightarrow> xa \<le> x" 
     by (meson Suc_lessD le_less_trans nat_dvd_not_less nat_le_linear x_less_exp)
   thus ?thesis using assms by(auto simp: loR.simps)
 qed
 
 lemma loR_set_strengthen[simp]: "\<lbrakk>xa \<le> x; loR [x, y, xa]; Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow>
   {u. loR [x, y, u]} = {ya. ya \<le> x \<and> loR [x, y, ya]}"
   apply(rule_tac Collect_cong, auto)
   apply(erule_tac uplimit_loR, simp, simp)
   done
 
 lemma Maxr_lo: "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow>
   Maxr loR [x, y] x = lo x y" 
   apply(simp add: Maxr.simps lo.simps, auto simp: uplimit_loR)
   by (meson uplimit_loR)+
 
 lemma lo_lemma': "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow> 
   rec_exec rec_lo [x, y] = lo x y"
   by(simp add: Maxr_lo  rec_lo_Maxr_lor)
 
 lemma lo_lemma'': "\<lbrakk>\<not> Suc 0 < x\<rbrakk> \<Longrightarrow> rec_exec rec_lo [x, y] = lo x y"
   apply(cases x, auto simp: rec_exec.simps rec_lo_def 
       Let_def lo.simps)
   done
 
 lemma lo_lemma''': "\<lbrakk>\<not> Suc 0 < y\<rbrakk> \<Longrightarrow> rec_exec rec_lo [x, y] = lo x y"
   apply(cases y, auto simp: rec_exec.simps rec_lo_def 
       Let_def lo.simps)
   done
 
 text \<open>
   The correctness of \<open>rec_lo\<close>:
 \<close>
 lemma lo_lemma: "rec_exec rec_lo [x, y] = lo x y" 
   apply(cases "Suc 0 < x \<and> Suc 0 < y")
    apply(auto simp: lo_lemma' lo_lemma'' lo_lemma''')
   done
 
+subsection \<open>The Recursive Function rec\_lg\<close>
+
 fun lgR :: "nat list \<Rightarrow> bool"
   where
     "lgR [x, y, u] = (y^u \<le> x)"
 
 text \<open>
   \<open>lg\<close> specifies the \<open>lg\<close> function given on page 79 of 
-  Boolos's book. It is one of the two notions of integeral logarithmetic
+  Boolos's book~\cite{Boolos07}. It is one of the two notions of integral logarithmetic
   operation on that page. The other is \<open>lo\<close>.
 \<close>
 fun lg :: "nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "lg x y = (if x > 1 \<and> y > 1 \<and> {u. lgR [x, y, u]} \<noteq> {} then 
                  Max {u. lgR [x, y, u]}
               else 0)"
 
 declare lg.simps[simp del] lgR.simps[simp del]
 
 text \<open>
   \<open>rec_lg\<close> is the recursive function used to implement \<open>lg\<close>.
 \<close>
 definition rec_lg :: "recf"
   where
     "rec_lg = (let rec_lgR = Cn 3 rec_le
   [Cn 3 rec_power [id 3 1, id 3 2], id 3 0] in
   let conR1 = Cn 2 rec_conj [Cn 2 rec_less 
                      [Cn 2 (constn 1) [id 2 0], id 2 0], 
                             Cn 2 rec_less [Cn 2 (constn 1) 
                                  [id 2 0], id 2 1]] in 
   let conR2 = Cn 2 rec_not [conR1] in 
         Cn 2 rec_add [Cn 2 rec_mult 
               [conR1, Cn 2 (rec_maxr rec_lgR)
                        [id 2 0, id 2 1, id 2 0]], 
                        Cn 2 rec_mult [conR2, Cn 2 (constn 0) 
                                 [id 2 0]]])"
 
 lemma lg_maxr: "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow> 
                       rec_exec rec_lg [x, y] = Maxr lgR [x, y] x"
 proof(simp add: rec_exec.simps rec_lg_def Let_def)
   assume h: "Suc 0 < x" "Suc 0 < y"
   let ?rR = "(Cn 3 rec_le [Cn 3 rec_power
                [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0])"
   have "rec_exec (rec_maxr ?rR) ([x, y] @ [x])
               = Maxr ((\<lambda> args. 0 < rec_exec ?rR args)) [x, y] x" 
   proof(rule Maxr_lemma)
     show "primerec (Cn 3 rec_le [Cn 3 rec_power 
               [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0]) (Suc (length [x, y]))"
       apply(auto simp: numeral_3_eq_3)+
       done
   qed
   moreover have "Maxr lgR [x, y] x = Maxr ((\<lambda> args. 0 < rec_exec ?rR args)) [x, y] x"
     apply(simp add: rec_exec.simps power_lemma)
     apply(simp add: Maxr.simps lgR.simps)
     done 
   ultimately show "rec_exec (rec_maxr ?rR) [x, y, x] = Maxr lgR [x, y] x"
     by simp
 qed
 
 lemma lgR_ok: "\<lbrakk>Suc 0 < y; lgR [x, y, xa]\<rbrakk> \<Longrightarrow> xa \<le> x"
   apply(auto simp add: lgR.simps)
   apply(subgoal_tac "y^xa > xa", simp)
   apply(erule x_less_exp)
   done
 
 lemma lgR_set_strengthen[simp]: "\<lbrakk>Suc 0 < x; Suc 0 < y; lgR [x, y, xa]\<rbrakk> \<Longrightarrow>
            {u. lgR [x, y, u]} =  {ya. ya \<le> x \<and> lgR [x, y, ya]}"
   apply(rule_tac Collect_cong, auto simp:lgR_ok)
   done
 
 lemma maxr_lg: "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow> Maxr lgR [x, y] x = lg x y"
   apply(auto simp add: lg.simps Maxr.simps)
   using lgR_ok by blast
 
 lemma lg_lemma': "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow> rec_exec rec_lg [x, y] = lg x y"
   apply(simp add: maxr_lg lg_maxr)
   done
 
 lemma lg_lemma'': "\<not> Suc 0 < x \<Longrightarrow> rec_exec rec_lg [x, y] = lg x y"
   apply(simp add: rec_exec.simps rec_lg_def Let_def lg.simps)
   done
 
 lemma lg_lemma''': "\<not> Suc 0 < y \<Longrightarrow> rec_exec rec_lg [x, y] = lg x y"
   apply(simp add: rec_exec.simps rec_lg_def Let_def lg.simps)
   done
 
 text \<open>
   The correctness of \<open>rec_lg\<close>.
 \<close>
 lemma lg_lemma: "rec_exec rec_lg [x, y] = lg x y"
   apply(cases "Suc 0 < x \<and> Suc 0 < y", auto simp: 
       lg_lemma' lg_lemma'' lg_lemma''')
   done
 
+subsection \<open>The Recursive Function rec\_entry\<close>
+
 text \<open>
   \<open>Entry sr i\<close> returns the \<open>i\<close>-th entry of a list of natural 
   numbers encoded by number \<open>sr\<close> using Godel's coding.
+  This function is called {\em ent} on page 80 of Boolos's book~\cite{Boolos07}.
 \<close>
 fun Entry :: "nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "Entry sr i = lo sr (Pi (Suc i))"
 
 text \<open>
   \<open>rec_entry\<close> is the recursive function used to implement
   \<open>Entry\<close>.
 \<close>
 definition rec_entry:: "recf"
   where
     "rec_entry = Cn 2 rec_lo [id 2 0, Cn 2 rec_pi [Cn 2 s [id 2 1]]]"
 
 declare Pi.simps[simp del]
 
 text \<open>
   The correctness of \<open>rec_entry\<close>.
 \<close>
 lemma entry_lemma: "rec_exec rec_entry [str, i] = Entry str i"
   by(simp add: rec_entry_def  rec_exec.simps lo_lemma pi_lemma)
 
 
-subsection \<open>The construction of F\<close>
+section \<open>Main components of rec\_F\<close>
 
 text \<open>
-  Using the auxilliary functions obtained in last section, 
-  we are going to contruct the function \<open>F\<close>, 
-  which is an interpreter of Turing Machines.
+  Using the auxiliary functions obtained in last section, 
+  we are going to construct the function \<open>F\<close>, 
+  which is an interpreter for Turing Machines.
 \<close>
 
 fun listsum2 :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "listsum2 xs 0 = 0"
   | "listsum2 xs (Suc n) = listsum2 xs n + xs ! n"
 
 fun rec_listsum2 :: "nat \<Rightarrow> nat \<Rightarrow> recf"
   where
     "rec_listsum2 vl 0 = Cn vl z [id vl 0]"
   | "rec_listsum2 vl (Suc n) = Cn vl rec_add [rec_listsum2 vl n, id vl n]"
 
 declare listsum2.simps[simp del] rec_listsum2.simps[simp del]
 
 lemma listsum2_lemma: "\<lbrakk>length xs = vl; n \<le> vl\<rbrakk> \<Longrightarrow> 
       rec_exec (rec_listsum2 vl n) xs = listsum2 xs n"
   apply(induct n, simp_all)
    apply(simp_all add: rec_exec.simps rec_listsum2.simps listsum2.simps)
   done
 
+subsection \<open>The Recursive Function rec\_strt\<close>
+
 fun strt' :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "strt' xs 0 = 0"
   | "strt' xs (Suc n) = (let dbound = listsum2 xs n + n in 
                        strt' xs n + (2^(xs ! n + dbound) - 2^dbound))"
 
 fun rec_strt' :: "nat \<Rightarrow> nat \<Rightarrow> recf"
   where
     "rec_strt' vl 0 = Cn vl z [id vl 0]"
   | "rec_strt' vl (Suc n) = (let rec_dbound =
   Cn vl rec_add [rec_listsum2 vl n, Cn vl (constn n) [id vl 0]]
   in Cn vl rec_add [rec_strt' vl n, Cn vl rec_minus 
   [Cn vl rec_power [Cn vl (constn 2) [id vl 0], Cn vl rec_add
   [id vl (n), rec_dbound]], 
   Cn vl rec_power [Cn vl (constn 2) [id vl 0], rec_dbound]]])"
 
 declare strt'.simps[simp del] rec_strt'.simps[simp del]
 
 lemma strt'_lemma: "\<lbrakk>length xs = vl; n \<le> vl\<rbrakk> \<Longrightarrow> 
   rec_exec (rec_strt' vl n) xs = strt' xs n"
   apply(induct n)
    apply(simp_all add: rec_exec.simps rec_strt'.simps strt'.simps
       Let_def power_lemma listsum2_lemma)
   done
 
 text \<open>
   \<open>strt\<close> corresponds to the \<open>strt\<close> function on page 90 of B book, but 
   this definition generalises the original one to deal with multiple input arguments.
 \<close>
 fun strt :: "nat list \<Rightarrow> nat"
   where
     "strt xs = (let ys = map Suc xs in 
               strt' ys (length ys))"
 
 fun rec_map :: "recf \<Rightarrow> nat \<Rightarrow> recf list"
   where
     "rec_map rf vl = map (\<lambda> i. Cn vl rf [id vl i]) [0..<vl]"
 
 text \<open>
   \<open>rec_strt\<close> is the recursive function used to implement \<open>strt\<close>.
 \<close>
 fun rec_strt :: "nat \<Rightarrow> recf"
   where
     "rec_strt vl = Cn vl (rec_strt' vl vl) (rec_map s vl)"
 
 lemma map_s_lemma: "length xs = vl \<Longrightarrow> 
   map ((\<lambda>a. rec_exec a xs) \<circ> (\<lambda>i. Cn vl s [recf.id vl i]))
   [0..<vl]
         = map Suc xs"
   apply(induct vl arbitrary: xs, simp, auto simp: rec_exec.simps)
   apply(rename_tac vl xs)
   apply(subgoal_tac "\<exists> ys y. xs = ys @ [y]", auto)
 proof -
   fix ys y
   assume ind: "\<And>xs. length xs = length (ys::nat list) \<Longrightarrow>
       map ((\<lambda>a. rec_exec a xs) \<circ> (\<lambda>i. Cn (length ys) s 
         [recf.id (length ys) (i)])) [0..<length ys] = map Suc xs"
   show
     "map ((\<lambda>a. rec_exec a (ys @ [y])) \<circ> (\<lambda>i. Cn (Suc (length ys)) s 
   [recf.id (Suc (length ys)) (i)])) [0..<length ys] = map Suc ys"
   proof -
     have "map ((\<lambda>a. rec_exec a ys) \<circ> (\<lambda>i. Cn (length ys) s
         [recf.id (length ys) (i)])) [0..<length ys] = map Suc ys"
       apply(rule_tac ind, simp)
       done
     moreover have
       "map ((\<lambda>a. rec_exec a (ys @ [y])) \<circ> (\<lambda>i. Cn (Suc (length ys)) s
            [recf.id (Suc (length ys)) (i)])) [0..<length ys]
          = map ((\<lambda>a. rec_exec a ys) \<circ> (\<lambda>i. Cn (length ys) s 
                  [recf.id (length ys) (i)])) [0..<length ys]"
       apply(rule_tac map_ext, auto simp: rec_exec.simps nth_append)
       done
     ultimately show "?thesis"
       by simp
   qed
 next
   fix vl xs
   assume "length xs = Suc vl"
   thus "\<exists>ys y. xs = ys @ [y]"
     apply(rule_tac x = "butlast xs" in exI, rule_tac x = "last xs" in exI)
     apply(subgoal_tac "xs \<noteq> []", auto)
     done
 qed
 
 text \<open>
   The correctness of \<open>rec_strt\<close>.
 \<close>
 lemma strt_lemma: "length xs = vl \<Longrightarrow> 
   rec_exec (rec_strt vl) xs = strt xs"
   apply(simp add: strt.simps rec_exec.simps strt'_lemma)
   apply(subgoal_tac "(map ((\<lambda>a. rec_exec a xs) \<circ> (\<lambda>i. Cn vl s [recf.id vl (i)])) [0..<vl])
                   = map Suc xs", auto)
   apply(rule map_s_lemma, simp)
   done
 
+subsection \<open>The Recursive Function rec\_scan\<close>
+
 text \<open>
   The \<open>scan\<close> function on page 90 of B book.
 \<close>
 fun scan :: "nat \<Rightarrow> nat"
   where
     "scan r = r mod 2"
 
 text \<open>
   \<open>rec_scan\<close> is the implemention of \<open>scan\<close>.
 \<close>
 definition rec_scan :: "recf"
   where "rec_scan = Cn 1 rec_mod [id 1 0, constn 2]"
 
 text \<open>
   The correctness of \<open>scan\<close>.
 \<close>
 lemma scan_lemma: "rec_exec rec_scan [r] = r mod 2"
   by(simp add: rec_exec.simps rec_scan_def mod_lemma)
 
+subsection \<open>The Recursive Function rec\_newleft\<close>
+
 fun newleft0 :: "nat list \<Rightarrow> nat"
   where
     "newleft0 [p, r] = p"
 
 definition rec_newleft0 :: "recf"
   where
     "rec_newleft0 = id 2 0"
 
 fun newrgt0 :: "nat list \<Rightarrow> nat"
   where
     "newrgt0 [p, r] = r - scan r"
 
 definition rec_newrgt0 :: "recf"
   where
     "rec_newrgt0 = Cn 2 rec_minus [id 2 1, Cn 2 rec_scan [id 2 1]]"
 
 (*newleft1, newrgt1: left rgt number after execute on step*)
 fun newleft1 :: "nat list \<Rightarrow> nat"
   where
     "newleft1 [p, r] = p"
 
 definition rec_newleft1 :: "recf"
   where
     "rec_newleft1 = id 2 0"
 
 fun newrgt1 :: "nat list \<Rightarrow> nat"
   where
     "newrgt1 [p, r] = r + 1 - scan r"
 
 definition rec_newrgt1 :: "recf"
   where
     "rec_newrgt1 = 
   Cn 2 rec_minus [Cn 2 rec_add [id 2 1, Cn 2 (constn 1) [id 2 0]], 
                   Cn 2 rec_scan [id 2 1]]"
 
 fun newleft2 :: "nat list \<Rightarrow> nat"
   where
     "newleft2 [p, r] = p div 2"
 
 definition rec_newleft2 :: "recf" 
   where
     "rec_newleft2 = Cn 2 rec_quo [id 2 0, Cn 2 (constn 2) [id 2 0]]"
 
 fun newrgt2 :: "nat list \<Rightarrow> nat"
   where
     "newrgt2 [p, r] = 2 * r + p mod 2"
 
 definition rec_newrgt2 :: "recf"
   where
     "rec_newrgt2 =
     Cn 2 rec_add [Cn 2 rec_mult [Cn 2 (constn 2) [id 2 0], id 2 1],                     
                  Cn 2 rec_mod [id 2 0, Cn 2 (constn 2) [id 2 0]]]"
 
 fun newleft3 :: "nat list \<Rightarrow> nat"
   where
     "newleft3 [p, r] = 2 * p + r mod 2"
 
 definition rec_newleft3 :: "recf"
   where
     "rec_newleft3 = 
   Cn 2 rec_add [Cn 2 rec_mult [Cn 2 (constn 2) [id 2 0], id 2 0], 
                 Cn 2 rec_mod [id 2 1, Cn 2 (constn 2) [id 2 0]]]"
 
 fun newrgt3 :: "nat list \<Rightarrow> nat"
   where
     "newrgt3 [p, r] = r div 2"
 
 definition rec_newrgt3 :: "recf"
   where
     "rec_newrgt3 = Cn 2 rec_quo [id 2 1, Cn 2 (constn 2) [id 2 0]]"
 
 text \<open>
   The \<open>new_left\<close> function on page 91 of B book.
 \<close>
 fun newleft :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "newleft p r a = (if a = 0 \<or> a = 1 then newleft0 [p, r] 
                     else if a = 2 then newleft2 [p, r]
                     else if a = 3 then newleft3 [p, r]
                     else p)"
 
 text \<open>
   \<open>rec_newleft\<close> is the recursive function used to 
   implement \<open>newleft\<close>.
 \<close>
 definition rec_newleft :: "recf" 
   where
     "rec_newleft =
   (let g0 = 
       Cn 3 rec_newleft0 [id 3 0, id 3 1] in 
   let g1 = Cn 3 rec_newleft2 [id 3 0, id 3 1] in 
   let g2 = Cn 3 rec_newleft3 [id 3 0, id 3 1] in 
   let g3 = id 3 0 in
   let r0 = Cn 3 rec_disj
           [Cn 3 rec_eq [id 3 2, Cn 3 (constn 0) [id 3 0]],
            Cn 3 rec_eq [id 3 2, Cn 3 (constn 1) [id 3 0]]] in 
   let r1 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 2) [id 3 0]] in 
   let r2 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 3) [id 3 0]] in
   let r3 = Cn 3 rec_less [Cn 3 (constn 3) [id 3 0], id 3 2] in 
   let gs = [g0, g1, g2, g3] in 
   let rs = [r0, r1, r2, r3] in 
   rec_embranch (zip gs rs))"
 
 declare newleft.simps[simp del]
 
 
 lemma Suc_Suc_Suc_Suc_induct: 
   "\<lbrakk>i < Suc (Suc (Suc (Suc 0))); i = 0 \<Longrightarrow>  P i;
     i = 1 \<Longrightarrow> P i; i =2 \<Longrightarrow> P i; 
     i =3 \<Longrightarrow> P i\<rbrakk> \<Longrightarrow> P i"
   apply(cases i, force)
   apply(cases "i - 1", force)
   apply(cases "i - 1 - 1", force)
-  by(cases "i - 1 - 1 - 1", auto simp:numeral)
+  by(cases "i - 1 - 1 - 1", auto simp:numeral_eqs_upto_12)
 
 declare quo_lemma2[simp] mod_lemma[simp]
 
 text \<open>
   The correctness of \<open>rec_newleft\<close>.
 \<close>
 lemma newleft_lemma: 
   "rec_exec rec_newleft [p, r, a] = newleft p r a"
 proof(simp only: rec_newleft_def Let_def)
   let ?rgs = "[Cn 3 rec_newleft0 [recf.id 3 0, recf.id 3 1], Cn 3 rec_newleft2 
        [recf.id 3 0, recf.id 3 1], Cn 3 rec_newleft3 [recf.id 3 0, recf.id 3 1], recf.id 3 0]"
   let ?rrs = 
     "[Cn 3 rec_disj [Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 0) 
      [recf.id 3 0]], Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 1) [recf.id 3 0]]], 
      Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 2) [recf.id 3 0]],
      Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 3) [recf.id 3 0]],
      Cn 3 rec_less [Cn 3 (constn 3) [recf.id 3 0], recf.id 3 2]]"
   have k1: "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a]
                          = Embranch (zip (map rec_exec ?rgs) (map (\<lambda>r args. 0 < rec_exec r args) ?rrs)) [p, r, a]"
     apply(rule_tac embranch_lemma )
         apply(auto simp: numeral_3_eq_3 numeral_2_eq_2 rec_newleft0_def 
         rec_newleft1_def rec_newleft2_def rec_newleft3_def)+
     apply(cases "a = 0 \<or> a = 1", rule_tac x = 0 in exI)
      prefer 2
      apply(cases "a = 2", rule_tac x = "Suc 0" in exI)
       prefer 2
       apply(cases "a = 3", rule_tac x = "2" in exI)
        prefer 2
        apply(cases "a > 3", rule_tac x = "3" in exI, auto)
              apply(auto simp: rec_exec.simps)
         apply(erule_tac [!] Suc_Suc_Suc_Suc_induct, auto simp: rec_exec.simps)
     done
   have k2: "Embranch (zip (map rec_exec ?rgs) (map (\<lambda>r args. 0 < rec_exec r args) ?rrs)) [p, r, a] = newleft p r a"
     apply(simp add: Embranch.simps)
     apply(simp add: rec_exec.simps)
     apply(auto simp: newleft.simps rec_newleft0_def rec_exec.simps
         rec_newleft1_def rec_newleft2_def rec_newleft3_def)
     done
   from k1 and k2 show 
     "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a] = newleft p r a"
     by simp
 qed
 
+subsection \<open>The Recursive Function rec\_newrght\<close>
+
 text \<open>
   The \<open>newrght\<close> function is one similar to \<open>newleft\<close>, but used to 
   compute the right number.
 \<close>
 fun newrght :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "newrght p r a  = (if a = 0 then newrgt0 [p, r]
                     else if a = 1 then newrgt1 [p, r]
                     else if a = 2 then newrgt2 [p, r]
                     else if a = 3 then newrgt3 [p, r]
                     else r)"
 
 text \<open>
   \<open>rec_newrght\<close> is the recursive function used to implement 
   \<open>newrgth\<close>.
 \<close>
 definition rec_newrght :: "recf" 
   where
     "rec_newrght =
   (let g0 = Cn 3 rec_newrgt0 [id 3 0, id 3 1] in 
   let g1 = Cn 3 rec_newrgt1 [id 3 0, id 3 1] in 
   let g2 = Cn 3 rec_newrgt2 [id 3 0, id 3 1] in 
   let g3 = Cn 3 rec_newrgt3 [id 3 0, id 3 1] in
   let g4 = id 3 1 in 
   let r0 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 0) [id 3 0]] in 
   let r1 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 1) [id 3 0]] in 
   let r2 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 2) [id 3 0]] in
   let r3 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 3) [id 3 0]] in
   let r4 = Cn 3 rec_less [Cn 3 (constn 3) [id 3 0], id 3 2] in 
   let gs = [g0, g1, g2, g3, g4] in 
   let rs = [r0, r1, r2, r3, r4] in 
   rec_embranch (zip gs rs))"
 declare newrght.simps[simp del]
 
-lemma numeral_4_eq_4: "4 = Suc 3"
-  by auto
-
 lemma Suc_5_induct: 
   "\<lbrakk>i < Suc (Suc (Suc (Suc (Suc 0)))); i = 0 \<Longrightarrow> P 0;
   i = 1 \<Longrightarrow> P 1; i = 2 \<Longrightarrow> P 2; i = 3 \<Longrightarrow> P 3; i = 4 \<Longrightarrow> P 4\<rbrakk> \<Longrightarrow> P i"
   apply(cases i, force)
   apply(cases "i-1", force)
   apply(cases "i-1-1")
-  using less_2_cases numeral by auto
+  using less_2_cases numeral_eqs_upto_12 by auto
 
 
 lemma primerec_rec_scan_1[intro]: "primerec rec_scan (Suc 0)"
   apply(auto simp: rec_scan_def, auto)
   done
 
 text \<open>
   The correctness of \<open>rec_newrght\<close>.
 \<close>
 lemma newrght_lemma: "rec_exec rec_newrght [p, r, a] = newrght p r a"
 proof(simp only: rec_newrght_def Let_def)
   let ?gs' = "[newrgt0, newrgt1, newrgt2, newrgt3, \<lambda> zs. zs ! 1]"
   let ?r0 = "\<lambda> zs. zs ! 2 = 0"
   let ?r1 = "\<lambda> zs. zs ! 2 = 1"
   let ?r2 = "\<lambda> zs. zs ! 2 = 2"
   let ?r3 = "\<lambda> zs. zs ! 2 = 3"
   let ?r4 = "\<lambda> zs. zs ! 2 > 3"
   let ?gs = "map (\<lambda> g. (\<lambda> zs. g [zs ! 0, zs ! 1])) ?gs'"
   let ?rs = "[?r0, ?r1, ?r2, ?r3, ?r4]"
   let ?rgs = 
     "[Cn 3 rec_newrgt0 [recf.id 3 0, recf.id 3 1],
     Cn 3 rec_newrgt1 [recf.id 3 0, recf.id 3 1],
      Cn 3 rec_newrgt2 [recf.id 3 0, recf.id 3 1], 
       Cn 3 rec_newrgt3 [recf.id 3 0, recf.id 3 1], recf.id 3 1]"
   let ?rrs = 
     "[Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 0) [recf.id 3 0]], Cn 3 rec_eq [recf.id 3 2, 
     Cn 3 (constn 1) [recf.id 3 0]], Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 2) [recf.id 3 0]],
      Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 3) [recf.id 3 0]], 
        Cn 3 rec_less [Cn 3 (constn 3) [recf.id 3 0], recf.id 3 2]]"
 
   have k1: "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a]
     = Embranch (zip (map rec_exec ?rgs) (map (\<lambda>r args. 0 < rec_exec r args) ?rrs)) [p, r, a]"
     apply(rule_tac embranch_lemma)
         apply(auto simp: numeral_3_eq_3 numeral_2_eq_2 rec_newrgt0_def 
         rec_newrgt1_def rec_newrgt2_def rec_newrgt3_def)+
     apply(cases "a = 0", rule_tac x = 0 in exI)
      prefer 2
      apply(cases "a = 1", rule_tac x = "Suc 0" in exI)
       prefer 2
       apply(cases "a = 2", rule_tac x = "2" in exI)
        prefer 2
        apply(cases "a = 3", rule_tac x = "3" in exI)
         prefer 2
         apply(cases "a > 3", rule_tac x = "4" in exI, auto simp: rec_exec.simps)
         apply(erule_tac [!] Suc_5_induct, auto simp: rec_exec.simps)
     done
   have k2: "Embranch (zip (map rec_exec ?rgs)
     (map (\<lambda>r args. 0 < rec_exec r args) ?rrs)) [p, r, a] = newrght p r a"
     apply(auto simp:Embranch.simps rec_exec.simps)
         apply(auto simp: newrght.simps rec_newrgt3_def rec_newrgt2_def
         rec_newrgt1_def rec_newrgt0_def rec_exec.simps
         scan_lemma)
     done
   from k1 and k2 show 
     "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a] =      
                                     newrght p r a" by simp
 qed
 
 declare Entry.simps[simp del]
 
+subsection \<open>The Recursive Function rec\_actn\<close>
+
 text \<open>
   The \<open>actn\<close> function given on page 92 of B book, which is used to 
-  fetch Turing Machine intructions. 
-  In \<open>actn m q r\<close>, \<open>m\<close> is the Godel coding of a Turing Machine,
+  fetch Turing Machine instructions. 
+  In \<open>actn m q r\<close>, \<open>m\<close> is the Gödel coding of a Turing Machine,
   \<open>q\<close> is the current state of Turing Machine, \<open>r\<close> is the
   right number of Turing Machine tape.
 \<close>
 fun actn :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "actn m q r = (if q \<noteq> 0 then Entry m (4*(q - 1) + 2 * scan r)
                  else 4)"
 
 text \<open>
   \<open>rec_actn\<close> is the recursive function used to implement \<open>actn\<close>
 \<close>
 definition rec_actn :: "recf"
   where
     "rec_actn = 
   Cn 3 rec_add [Cn 3 rec_mult 
         [Cn 3 rec_entry [id 3 0, Cn 3 rec_add [Cn 3 rec_mult 
                                  [Cn 3 (constn 4) [id 3 0], 
                 Cn 3 rec_minus [id 3 1, Cn 3 (constn 1) [id 3 0]]], 
                    Cn 3 rec_mult [Cn 3 (constn 2) [id 3 0],
                       Cn 3 rec_scan [id 3 2]]]], 
             Cn 3 rec_noteq [id 3 1, Cn 3 (constn 0) [id 3 0]]], 
                              Cn 3 rec_mult [Cn 3 (constn 4) [id 3 0], 
              Cn 3 rec_eq [id 3 1, Cn 3 (constn 0) [id 3 0]]]] "
 
 text \<open>
   The correctness of \<open>actn\<close>.
 \<close>
 lemma actn_lemma: "rec_exec rec_actn [m, q, r] = actn m q r"
   by(auto simp: rec_actn_def rec_exec.simps entry_lemma scan_lemma)
 
+subsection \<open>The Recursive Function rec\_newstat\<close>
+
 fun newstat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "newstat m q r = (if q \<noteq> 0 then Entry m (4*(q - 1) + 2*scan r + 1)
                     else 0)"
 
 definition rec_newstat :: "recf"
   where
     "rec_newstat = Cn 3 rec_add 
     [Cn 3 rec_mult [Cn 3 rec_entry [id 3 0, 
            Cn 3 rec_add [Cn 3 rec_mult [Cn 3 (constn 4) [id 3 0], 
            Cn 3 rec_minus [id 3 1, Cn 3 (constn 1) [id 3 0]]], 
            Cn 3 rec_add [Cn 3 rec_mult [Cn 3 (constn 2) [id 3 0],
            Cn 3 rec_scan [id 3 2]], Cn 3 (constn 1) [id 3 0]]]], 
            Cn 3 rec_noteq [id 3 1, Cn 3 (constn 0) [id 3 0]]], 
            Cn 3 rec_mult [Cn 3 (constn 0) [id 3 0], 
            Cn 3 rec_eq [id 3 1, Cn 3 (constn 0) [id 3 0]]]] "
 
 lemma newstat_lemma: "rec_exec rec_newstat [m, q, r] = newstat m q r"
   by(auto simp:  rec_exec.simps entry_lemma scan_lemma rec_newstat_def)
 
 declare newstat.simps[simp del] actn.simps[simp del]
 
+subsection \<open>The Recursive Function rec\_trpl\<close>
+
 text\<open>code the configuration\<close>
 
 fun trpl :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "trpl p q r = (Pi 0)^p * (Pi 1)^q * (Pi 2)^r"
 
 definition rec_trpl :: "recf"
   where
     "rec_trpl = Cn 3 rec_mult [Cn 3 rec_mult 
        [Cn 3 rec_power [Cn 3 (constn (Pi 0)) [id 3 0], id 3 0], 
         Cn 3 rec_power [Cn 3 (constn (Pi 1)) [id 3 0], id 3 1]],
         Cn 3 rec_power [Cn 3 (constn (Pi 2)) [id 3 0], id 3 2]]"
 declare trpl.simps[simp del]
 lemma trpl_lemma: "rec_exec rec_trpl [p, q, r] = trpl p q r"
   by(auto simp: rec_trpl_def rec_exec.simps power_lemma trpl.simps)
 
+subsection \<open>The Recursive Functions rec\_left, rec\_right, rec\_stat, rec\_inpt\<close>
+
 text\<open>left, stat, rght: decode func\<close>
 fun left :: "nat \<Rightarrow> nat"
   where
     "left c = lo c (Pi 0)"
 
 fun stat :: "nat \<Rightarrow> nat"
   where
     "stat c = lo c (Pi 1)"
 
 fun rght :: "nat \<Rightarrow> nat"
   where
     "rght c = lo c (Pi 2)"
 
 fun inpt :: "nat \<Rightarrow> nat list \<Rightarrow> nat"
   where
     "inpt m xs = trpl 0 1 (strt xs)"
 
 fun newconf :: "nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "newconf m c = trpl (newleft (left c) (rght c) 
                         (actn m (stat c) (rght c)))
                         (newstat m (stat c) (rght c)) 
                         (newrght (left c) (rght c) 
                               (actn m (stat c) (rght c)))"
 
 declare left.simps[simp del] stat.simps[simp del] rght.simps[simp del]
   inpt.simps[simp del] newconf.simps[simp del]
 
 definition rec_left :: "recf"
   where
     "rec_left = Cn 1 rec_lo [id 1 0, constn (Pi 0)]"
 
 definition rec_right :: "recf"
   where
     "rec_right = Cn 1 rec_lo [id 1 0, constn (Pi 2)]"
 
 definition rec_stat :: "recf"
   where
     "rec_stat = Cn 1 rec_lo [id 1 0, constn (Pi 1)]"
 
 definition rec_inpt :: "nat \<Rightarrow> recf"
   where
     "rec_inpt vl = Cn vl rec_trpl 
                   [Cn vl (constn 0) [id vl 0], 
                    Cn vl (constn 1) [id vl 0], 
                    Cn vl (rec_strt (vl - 1)) 
                         (map (\<lambda> i. id vl (i)) [1..<vl])]"
 
 lemma left_lemma: "rec_exec rec_left [c] = left c"
   by(simp add: rec_exec.simps rec_left_def left.simps lo_lemma)
 
 lemma right_lemma: "rec_exec rec_right [c] = rght c"
   by(simp add: rec_exec.simps rec_right_def rght.simps lo_lemma)
 
 lemma stat_lemma: "rec_exec rec_stat [c] = stat c"
   by(simp add: rec_exec.simps rec_stat_def stat.simps lo_lemma)
 
 declare rec_strt.simps[simp del] strt.simps[simp del]
 
 lemma map_cons_eq: 
   "(map ((\<lambda>a. rec_exec a (m # xs)) \<circ> 
     (\<lambda>i. recf.id (Suc (length xs)) (i))) 
           [Suc 0..<Suc (length xs)])
         = map (\<lambda> i. xs ! (i - 1)) [Suc 0..<Suc (length xs)]"
   apply(rule map_ext, auto)
    apply(auto simp: rec_exec.simps nth_append nth_Cons split: nat.split)
   done
 
 lemma list_map_eq: 
   "vl = length (xs::nat list) \<Longrightarrow> map (\<lambda> i. xs ! (i - 1))
                                           [Suc 0..<Suc vl] = xs"
 proof(induct vl arbitrary: xs)
   case (Suc vl)
   then show ?case 
     apply(subgoal_tac "\<exists> ys y. xs = ys @ [y]", auto)
   proof -
     fix ys y
     assume ind: 
       "\<And>xs. length (ys::nat list) = length (xs::nat list) \<Longrightarrow>
             map (\<lambda>i. xs ! (i - Suc 0)) [Suc 0..<length xs] @
                                 [xs ! (length xs - Suc 0)] = xs"
       and h: "Suc 0 \<le> length (ys::nat list)"
     have "map (\<lambda>i. ys ! (i - Suc 0)) [Suc 0..<length ys] @ 
                                    [ys ! (length ys - Suc 0)] = ys"
       apply(rule_tac ind, simp)
       done
     moreover have 
       "map (\<lambda>i. (ys @ [y]) ! (i - Suc 0)) [Suc 0..<length ys]
       = map (\<lambda>i. ys ! (i - Suc 0)) [Suc 0..<length ys]"
       apply(rule map_ext)
       using h
       apply(auto simp: nth_append)
       done
     ultimately show "map (\<lambda>i. (ys @ [y]) ! (i - Suc 0)) 
         [Suc 0..<length ys] @ [(ys @ [y]) ! (length ys - Suc 0)] = ys"
       apply(simp del: map_eq_conv add: nth_append, auto)
       using h
       apply(simp)
       done
   next
     fix vl xs
     assume "Suc vl = length (xs::nat list)"
     thus "\<exists>ys y. xs = ys @ [y]"
       apply(rule_tac x = "butlast xs" in exI, 
           rule_tac x = "last xs" in exI)
       apply(cases "xs \<noteq> []", auto)
       done
   qed
 qed simp
 
 lemma nonempty_listE: 
   "Suc 0 \<le> length xs \<Longrightarrow> 
      (map ((\<lambda>a. rec_exec a (m # xs)) \<circ> 
          (\<lambda>i. recf.id (Suc (length xs)) (i))) 
              [Suc 0..<length xs] @ [(m # xs) ! length xs]) = xs"
   using map_cons_eq[of m xs]
   apply(simp del: map_eq_conv add: rec_exec.simps)
   using list_map_eq[of "length xs" xs]
   apply(simp)
   done
 
 lemma inpt_lemma:
   "\<lbrakk>Suc (length xs) = vl\<rbrakk> \<Longrightarrow> 
             rec_exec (rec_inpt vl) (m # xs) = inpt m xs"
   apply(auto simp: rec_exec.simps rec_inpt_def 
       trpl_lemma inpt.simps strt_lemma)
    apply(subgoal_tac
       "(map ((\<lambda>a. rec_exec a (m # xs)) \<circ> 
           (\<lambda>i. recf.id (Suc (length xs)) (i))) 
             [Suc 0..<length xs] @ [(m # xs) ! length xs]) = xs", simp)
    apply(auto elim:nonempty_listE, cases xs, auto)
   done
 
+subsection \<open>The Recursive Function rec\_newconf\<close>
+
 definition rec_newconf:: "recf"
   where
     "rec_newconf = 
     Cn 2 rec_trpl 
         [Cn 2 rec_newleft [Cn 2 rec_left [id 2 1], 
                            Cn 2 rec_right [id 2 1], 
                            Cn 2 rec_actn [id 2 0, 
                                           Cn 2 rec_stat [id 2 1], 
                            Cn 2 rec_right [id 2 1]]],
           Cn 2 rec_newstat [id 2 0, 
                             Cn 2 rec_stat [id 2 1], 
                             Cn 2 rec_right [id 2 1]],
            Cn 2 rec_newrght [Cn 2 rec_left [id 2 1], 
                              Cn 2 rec_right [id 2 1], 
                              Cn 2 rec_actn [id 2 0, 
                                    Cn 2 rec_stat [id 2 1], 
                              Cn 2 rec_right [id 2 1]]]]"
 
 lemma newconf_lemma: "rec_exec rec_newconf [m ,c] = newconf m c"
   by(auto simp: rec_newconf_def rec_exec.simps 
       trpl_lemma newleft_lemma left_lemma
       right_lemma stat_lemma newrght_lemma actn_lemma 
       newstat_lemma newconf.simps)
 
 declare newconf_lemma[simp]
 
+subsection \<open>The Recursive Function rec\_conf\<close>
+
 text \<open>
   \<open>conf m r k\<close> computes the TM configuration after \<open>k\<close> steps of execution
   of TM coded as \<open>m\<close> starting from the initial configuration where the left number equals \<open>0\<close>, 
   right number equals \<open>r\<close>. 
 \<close>
 fun conf :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
   where
     "conf m r 0 = trpl 0 (Suc 0) r"
   | "conf m r (Suc t) = newconf m (conf m r t)"
 
 declare conf.simps[simp del]
 
 text \<open>
   \<open>conf\<close> is implemented by the following recursive function \<open>rec_conf\<close>.
 \<close>
 definition rec_conf :: "recf"
   where
     "rec_conf = Pr 2 (Cn 2 rec_trpl [Cn 2 (constn 0) [id 2 0], Cn 2 (constn (Suc 0)) [id 2 0], id 2 1])
                   (Cn 4 rec_newconf [id 4 0, id 4 3])"
 
 lemma conf_step: 
   "rec_exec rec_conf [m, r, Suc t] =
          rec_exec rec_newconf [m, rec_exec rec_conf [m, r, t]]"
 proof -
   have "rec_exec rec_conf ([m, r] @ [Suc t]) = 
           rec_exec rec_newconf [m, rec_exec rec_conf [m, r, t]]"
     by(simp only: rec_conf_def rec_pr_Suc_simp_rewrite,
         simp add: rec_exec.simps)
   thus "rec_exec rec_conf [m, r, Suc t] =
                 rec_exec rec_newconf [m, rec_exec rec_conf [m, r, t]]"
     by simp
 qed
 
 text \<open>
   The correctness of \<open>rec_conf\<close>.
 \<close>
 lemma conf_lemma: 
   "rec_exec rec_conf [m, r, t] = conf m r t"
   by (induct t)
     (auto simp add: rec_conf_def rec_exec.simps conf.simps inpt_lemma trpl_lemma)
 
+subsection \<open>The Recursive Function rec\_NSTD\<close>
+
 text \<open>
-  \<open>NSTD c\<close> returns true if the configureation coded by \<open>c\<close> is no a stardard
+  \<open>NSTD c\<close> returns true if the configuration coded by \<open>c\<close> is no a stardard
   final configuration.
 \<close>
 fun NSTD :: "nat \<Rightarrow> bool"
   where
     "NSTD c = (stat c \<noteq> 0 \<or> left c \<noteq> 0 \<or> 
              rght c \<noteq> 2^(lg (rght c + 1) 2) - 1 \<or> rght c = 0)"
 
 text \<open>
   \<open>rec_NSTD\<close> is the recursive function implementing \<open>NSTD\<close>.
 \<close>
 definition rec_NSTD :: "recf"
   where
     "rec_NSTD =
      Cn 1 rec_disj [
           Cn 1 rec_disj [
              Cn 1 rec_disj 
                 [Cn 1 rec_noteq [rec_stat, constn 0], 
                  Cn 1 rec_noteq [rec_left, constn 0]] , 
               Cn 1 rec_noteq [rec_right,  
                               Cn 1 rec_minus [Cn 1 rec_power 
                                  [constn 2, Cn 1 rec_lg 
                                     [Cn 1 rec_add        
                                      [rec_right, constn 1], 
                                             constn 2]], constn 1]]],
                Cn 1 rec_eq [rec_right, constn 0]]"
 
 lemma NSTD_lemma1: "rec_exec rec_NSTD [c] = Suc 0 \<or>
                    rec_exec rec_NSTD [c] = 0"
   by(simp add: rec_exec.simps rec_NSTD_def)
 
 declare NSTD.simps[simp del]
 lemma NSTD_lemma2': "(rec_exec rec_NSTD [c] = Suc 0) \<Longrightarrow> NSTD c"
   apply(simp add: rec_exec.simps rec_NSTD_def stat_lemma left_lemma 
       lg_lemma right_lemma power_lemma NSTD.simps)
   apply(auto)
   apply(cases "0 < left c", simp, simp)
   done
 
 lemma NSTD_lemma2'': 
   "NSTD c \<Longrightarrow> (rec_exec rec_NSTD [c] = Suc 0)"
   apply(simp add: rec_exec.simps rec_NSTD_def stat_lemma 
       left_lemma lg_lemma right_lemma power_lemma NSTD.simps)
   apply(auto split: if_splits)
   done
 
 text \<open>
   The correctness of \<open>NSTD\<close>.
 \<close>
 lemma NSTD_lemma2: "(rec_exec rec_NSTD [c] = Suc 0) = NSTD c"
   using NSTD_lemma1
   apply(auto intro: NSTD_lemma2' NSTD_lemma2'')
   done
 
 fun nstd :: "nat \<Rightarrow> nat"
   where
     "nstd c = (if NSTD c then 1 else 0)"
 
 lemma nstd_lemma: "rec_exec rec_NSTD [c] = nstd c"
   using NSTD_lemma1
   apply(simp add: NSTD_lemma2, auto)
   done
 
+subsection \<open>The Recursive Function rec\_nonstop\<close>
+
 text\<open>
-  \<open>nonstep m r t\<close> means afer \<open>t\<close> steps of execution, the TM coded by \<open>m\<close>
+  \<open>nonstop m r t\<close> means afer \<open>t\<close> steps of execution, the TM coded by \<open>m\<close>
   is not at a stardard final configuration.
 \<close>
 fun nonstop :: "nat \<Rightarrow> nat  \<Rightarrow> nat \<Rightarrow> nat"
   where
     "nonstop m r t = nstd (conf m r t)"
 
 text \<open>
   \<open>rec_nonstop\<close> is the recursive function implementing \<open>nonstop\<close>.
 \<close>
 definition rec_nonstop :: "recf"
   where
     "rec_nonstop = Cn 3 rec_NSTD [rec_conf]"
 
 text \<open>
   The correctness of \<open>rec_nonstop\<close>.
 \<close>
 lemma nonstop_lemma: 
   "rec_exec rec_nonstop [m, r, t] = nonstop m r t"
   apply(simp add: rec_exec.simps rec_nonstop_def nstd_lemma conf_lemma)
   done
 
+subsection \<open>The Recursive Function rec\_halt\<close>
+
 text\<open>
   \<open>rec_halt\<close> is the recursive function calculating the steps a TM needs to execute before
-  to reach a stardard final configuration. This recursive function is the only one
-  using \<open>Mn\<close> combinator. So it is the only non-primitive recursive function 
+  to reach a standard final configuration. This recursive function is the only one
+  using the \<open>Mn\<close> combinator. So it is the only non-primitive recursive function that
   needs to be used in the construction of the universal function \<open>F\<close>.
 \<close>
 
 definition rec_halt :: "recf"
   where
     "rec_halt = Mn (Suc (Suc 0)) (rec_nonstop)"
 
 declare nonstop.simps[simp del]
 
 text \<open>
   The lemma relates the interpreter of primitive functions with
   the calculation relation of general recursive functions. 
 \<close>
 
+subsection \<open>Execution of  Primitive Recursive Functions always terminates\<close>
+
 declare numeral_2_eq_2[simp] numeral_3_eq_3[simp]
 
 lemma primerec_rec_right_1[intro]: "primerec rec_right (Suc 0)"
   by(auto simp: rec_right_def rec_lo_def Let_def;force)
 
 lemma primerec_rec_pi_helper:
   "\<forall>i<Suc (Suc 0). primerec ([recf.id (Suc 0) 0, recf.id (Suc 0) 0] ! i) (Suc 0)"
   by fastforce
 
 lemmas primerec_rec_pi_helpers =
   primerec_rec_pi_helper primerec_constn_1 primerec_rec_sg_1 primerec_rec_not_1 primerec_rec_conj_2
 
 lemma primrec_dummyfac:
   "\<forall>i<Suc (Suc 0).
        primerec
         ([recf.id (Suc 0) 0,
           Cn (Suc 0) s
            [Cn (Suc 0) rec_dummyfac
              [recf.id (Suc 0) 0, recf.id (Suc 0) 0]]] !
          i)
         (Suc 0)"
   by(auto simp: rec_dummyfac_def;force)
 
 lemma primerec_rec_pi_1[intro]:  "primerec rec_pi (Suc 0)"
   apply(simp add: rec_pi_def rec_dummy_pi_def 
       rec_np_def rec_fac_def rec_prime_def
       rec_Minr.simps Let_def get_fstn_args.simps
       arity.simps
       rec_all.simps rec_sigma.simps rec_accum.simps)
   apply(tactic \<open>resolve_tac @{context} [@{thm prime_cn},  @{thm prime_pr}] 1\<close>
       ;(simp add:primerec_rec_pi_helpers primrec_dummyfac)?)+
   by fastforce+
 
 lemma primerec_recs[intro]:
   "primerec rec_trpl (Suc (Suc (Suc 0)))"
   "primerec rec_newleft0 (Suc (Suc 0))"
   "primerec rec_newleft1 (Suc (Suc 0))"
   "primerec rec_newleft2 (Suc (Suc 0))"
   "primerec rec_newleft3 (Suc (Suc 0))"
   "primerec rec_newleft (Suc (Suc (Suc 0)))"
   "primerec rec_left (Suc 0)"
   "primerec rec_actn (Suc (Suc (Suc 0)))"
   "primerec rec_stat (Suc 0)"
   "primerec rec_newstat (Suc (Suc (Suc 0)))"
            apply(simp_all add: rec_newleft_def rec_embranch.simps rec_left_def rec_lo_def rec_entry_def
       rec_actn_def Let_def arity.simps rec_newleft0_def rec_stat_def rec_newstat_def
       rec_newleft1_def rec_newleft2_def rec_newleft3_def rec_trpl_def)
            apply(tactic \<open>resolve_tac @{context} [@{thm prime_cn}, 
     @{thm prime_id}, @{thm prime_pr}] 1\<close>;force)+
   done
 
 lemma primerec_rec_newrght[intro]: "primerec rec_newrght (Suc (Suc (Suc 0)))"
   apply(simp add: rec_newrght_def rec_embranch.simps
       Let_def arity.simps rec_newrgt0_def 
       rec_newrgt1_def rec_newrgt2_def rec_newrgt3_def)
   apply(tactic \<open>resolve_tac @{context} [@{thm prime_cn}, 
     @{thm prime_id}, @{thm prime_pr}] 1\<close>;force)+
   done
 
 lemma primerec_rec_newconf[intro]: "primerec rec_newconf (Suc (Suc 0))"
   apply(simp add: rec_newconf_def)
   by(tactic \<open>resolve_tac @{context} [@{thm prime_cn}, 
     @{thm prime_id}, @{thm prime_pr}] 1\<close>;force)
 
 lemma primerec_rec_conf[intro]: "primerec rec_conf (Suc (Suc (Suc 0)))"
   apply(simp add: rec_conf_def)
   by(tactic \<open>resolve_tac @{context} [@{thm prime_cn}, 
-    @{thm prime_id}, @{thm prime_pr}] 1\<close>;force simp: numeral)
+    @{thm prime_id}, @{thm prime_pr}] 1\<close>;force simp: numeral_eqs_upto_12)
 
 lemma primerec_recs2[intro]:
   "primerec rec_lg (Suc (Suc 0))"
   "primerec rec_nonstop (Suc (Suc (Suc 0)))"
    apply(simp_all add: rec_lg_def rec_nonstop_def rec_NSTD_def rec_stat_def
       rec_lo_def Let_def rec_left_def rec_right_def rec_newconf_def
       rec_newstat_def)
   by(tactic \<open>resolve_tac @{context} [@{thm prime_cn}, 
     @{thm prime_id}, @{thm prime_pr}] 1\<close>;fastforce)+
 
 lemma primerec_terminate: 
   "\<lbrakk>primerec f x; length xs = x\<rbrakk> \<Longrightarrow> terminate f xs"
 proof(induct arbitrary: xs rule: primerec.induct)
   fix xs
   assume "length (xs::nat list) = Suc 0"  thus "terminate z xs"
     by(cases xs, auto intro: termi_z)
 next
   fix xs
   assume "length (xs::nat list) = Suc 0" thus "terminate s xs"
     by(cases xs, auto intro: termi_s)
 next
   fix n m xs
   assume "n < m" "length (xs::nat list) = m"  thus "terminate (id m n) xs"
     by(erule_tac termi_id, simp)
 next
   fix f k gs m n xs
   assume ind: "\<forall>i<length gs. primerec (gs ! i) m \<and> (\<forall>x. length x = m \<longrightarrow> terminate (gs ! i) x)"
     and ind2: "\<And> xs. length xs = k \<Longrightarrow> terminate f xs"
     and h: "primerec f k"  "length gs = k" "m = n" "length (xs::nat list) = m"
   have "terminate f (map (\<lambda>g. rec_exec g xs) gs)"
     using ind2[of "(map (\<lambda>g. rec_exec g xs) gs)"] h
     by simp
   moreover have "\<forall>g\<in>set gs. terminate g xs"
     using ind h
     by(auto simp: set_conv_nth)
   ultimately show "terminate (Cn n f gs) xs"
     using h
     by(rule_tac termi_cn, auto)
 next
   fix f n g m xs
   assume ind1: "\<And>xs. length xs = n \<Longrightarrow> terminate f xs"
     and ind2: "\<And>xs. length xs = Suc (Suc n) \<Longrightarrow> terminate g xs"
     and h: "primerec f n" " primerec g (Suc (Suc n))" " m = Suc n" "length (xs::nat list) = m"
   have "\<forall>y<last xs. terminate g (butlast xs @ [y, rec_exec (Pr n f g) (butlast xs @ [y])])"
     using h ind2 by(auto)
   moreover have "terminate f (butlast xs)"
     using ind1[of "butlast xs"] h
     by simp
   moreover have "length (butlast xs) = n"
     using h by simp
   ultimately have "terminate (Pr n f g) (butlast xs @ [last xs])"
     by(rule_tac termi_pr, simp_all)
   thus "terminate (Pr n f g) xs"
     using h
     by(cases "xs = []", auto)
 qed
 
-text \<open>
-  The following lemma gives the correctness of \<open>rec_halt\<close>.
-  It says: if \<open>rec_halt\<close> calculates that the TM coded by \<open>m\<close>
-  will reach a standard final configuration after \<open>t\<close> steps of execution, then it is indeed so.
-\<close>
-
-text \<open>F: universal machine\<close>
+
+subsection \<open>The Recursive Function rec\_valu\<close>
 
 text \<open>
   \<open>valu r\<close> extracts computing result out of the right number \<open>r\<close>.
 \<close>
 fun valu :: "nat \<Rightarrow> nat"
   where
     "valu r = (lg (r + 1) 2) - 1"
 
 text \<open>
   \<open>rec_valu\<close> is the recursive function implementing \<open>valu\<close>.
 \<close>
 definition rec_valu :: "recf"
   where
     "rec_valu = Cn 1 rec_minus [Cn 1 rec_lg [s, constn 2], constn 1]"
 
 text \<open>
   The correctness of \<open>rec_valu\<close>.
 \<close>
 lemma value_lemma: "rec_exec rec_valu [r] = valu r"
   by(simp add: rec_exec.simps rec_valu_def lg_lemma)
 
 lemma primerec_rec_valu_1[intro]: "primerec rec_valu (Suc 0)"
   unfolding rec_valu_def
   apply(rule prime_cn[of _ "Suc (Suc 0)"])
   by auto auto
 
 declare valu.simps[simp del]
 
-text \<open>
-  The definition of the universal function \<open>rec_F\<close>.
-\<close>
+section \<open>Definition of the Universal Function rec\_F\<close>
+
 definition rec_F :: "recf"
   where
     "rec_F = Cn (Suc (Suc 0)) rec_valu [Cn (Suc (Suc 0)) rec_right [Cn (Suc (Suc 0))
  rec_conf ([id (Suc (Suc 0)) 0, id (Suc (Suc 0)) (Suc 0), rec_halt])]]"
 
 lemma terminate_halt_lemma: 
   "\<lbrakk>rec_exec rec_nonstop ([m, r] @ [t]) = 0; 
      \<forall>i<t. 0 < rec_exec rec_nonstop ([m, r] @ [i])\<rbrakk> \<Longrightarrow> terminate rec_halt [m, r]"
   apply(simp add: rec_halt_def)
   apply(rule termi_mn, auto)
   by(rule primerec_terminate; auto)+
 
+section \<open>Correctness of rec\_F with respect to rec\_halt\<close>
 
 text \<open>
-  The correctness of \<open>rec_F\<close>, halt case.
+  The following lemma gives the correctness of \<open>rec_halt\<close>.
+  It says: if \<open>rec_halt\<close> calculates that the TM coded by \<open>m\<close>
+  will reach a standard final configuration after \<open>t\<close> steps of execution, then it is indeed so.
 \<close>
 
 lemma F_lemma: "rec_exec rec_halt [m, r] = t \<Longrightarrow> rec_exec rec_F [m, r] = (valu (rght (conf m r t)))"
   by(simp add: rec_F_def rec_exec.simps value_lemma right_lemma conf_lemma halt_lemma)
 
 lemma terminate_F_lemma: "terminate rec_halt [m, r] \<Longrightarrow> terminate rec_F [m, r]"
   apply(simp add: rec_F_def)
   apply(rule termi_cn, auto)
    apply(rule primerec_terminate, auto)
   apply(rule termi_cn, auto)
    apply(rule primerec_terminate, auto)
   apply(rule termi_cn, auto)
     apply(rule primerec_terminate, auto)
    apply(rule termi_id;force)
   apply(rule termi_id;force)
   done
 
-text \<open>
-  The correctness of \<open>rec_F\<close>, nonhalt case.
-\<close>
-
-subsection \<open>Coding function of TMs\<close>
+section \<open>A Gödel-Encoding for TMs: the function code\<close>
 
 text \<open>
   The purpose of this section is to get the coding function of Turing Machine, which is 
   going to be named \<open>code\<close>.
 \<close>
 
 fun bl2nat :: "cell list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "bl2nat [] n = 0"
   | "bl2nat (Bk#bl) n = bl2nat bl (Suc n)"
   | "bl2nat (Oc#bl) n = 2^n + bl2nat bl (Suc n)"
 
 fun bl2wc :: "cell list \<Rightarrow> nat"
   where
     "bl2wc xs = bl2nat xs 0"
 
 fun trpl_code :: "config \<Rightarrow> nat"
   where
     "trpl_code (st, l, r) = trpl (bl2wc l) st (bl2wc r)"
 
 declare bl2nat.simps[simp del] bl2wc.simps[simp del]
   trpl_code.simps[simp del]
 
 fun action_map :: "action \<Rightarrow> nat"
   where
-    "action_map W0 = 0"
-  | "action_map W1 = 1"
+    "action_map WB = 0"
+  | "action_map WO = 1"
   | "action_map L = 2"
   | "action_map R = 3"
   | "action_map Nop = 4"
 
 fun action_map_iff :: "nat \<Rightarrow> action"
   where
-    "action_map_iff (0::nat) = W0"
-  | "action_map_iff (Suc 0) = W1"
+    "action_map_iff (0::nat) = WB"
+  | "action_map_iff (Suc 0) = WO"
   | "action_map_iff (Suc (Suc 0)) = L"
   | "action_map_iff (Suc (Suc (Suc 0))) = R"
   | "action_map_iff n = Nop"
 
 fun block_map :: "cell \<Rightarrow> nat"
   where
     "block_map Bk = 0"
   | "block_map Oc = 1"
 
 fun godel_code' :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
   where
     "godel_code' [] n = 1"
   | "godel_code' (x#xs) n = (Pi n)^x * godel_code' xs (Suc n) "
 
 fun godel_code :: "nat list \<Rightarrow> nat"
   where
     "godel_code xs = (let lh = length xs in 
                    2^lh * (godel_code' xs (Suc 0)))"
 
 fun modify_tprog :: "instr list \<Rightarrow> nat list"
   where
     "modify_tprog [] =  []"
   | "modify_tprog ((ac, ns)#nl) = action_map ac # ns # modify_tprog nl"
 
 text \<open>
   \<open>code tp\<close> gives the Godel coding of TM program \<open>tp\<close>.
 \<close>
 fun code :: "instr list \<Rightarrow> nat"
   where 
     "code tp = (let nl = modify_tprog tp in 
               godel_code nl)"
 
-subsection \<open>Relating interperter functions to the execution of TMs\<close>
+section \<open>Relating interpreter functions to the execution of TMs\<close>
 
 lemma bl2wc_0[simp]: "bl2wc [] = 0" by(simp add: bl2wc.simps bl2nat.simps)
 
 lemma fetch_action_map_4[simp]: "\<lbrakk>fetch tp 0 b = (nact, ns)\<rbrakk> \<Longrightarrow> action_map nact = 4"
   apply(simp add: fetch.simps)
   done
 
 lemma Pi_gr_1[simp]: "Pi n > Suc 0"
 proof(induct n, auto simp: Pi.simps Np.simps)
   fix n
   let ?setx = "{y. y \<le> Suc (Pi n!) \<and> Pi n < y \<and> Prime y}"
   have "finite ?setx" by auto
   moreover have "?setx \<noteq> {}"
     using prime_ex[of "Pi n"]
     apply(auto)
     done
   ultimately show "Suc 0 < Min ?setx"
     apply(simp add: Min_gr_iff)
     apply(auto simp: Prime.simps)
     done
 qed
 
 lemma Pi_not_0[simp]: "Pi n > 0"
   using Pi_gr_1[of n]
   by arith
 
 declare godel_code.simps[simp del]
 
 lemma godel_code'_nonzero[simp]: "0 < godel_code' nl n"
   apply(induct nl arbitrary: n)
    apply(auto simp: godel_code'.simps)
   done
 
 lemma godel_code_great: "godel_code nl > 0"
   apply(simp add: godel_code.simps)
   done
 
 lemma godel_code_eq_1: "(godel_code nl = 1) = (nl = [])"
   apply(auto simp: godel_code.simps)
   done
 
 lemma godel_code_1_iff[elim]: 
   "\<lbrakk>i < length nl; \<not> Suc 0 < godel_code nl\<rbrakk> \<Longrightarrow> nl ! i = 0"
   using godel_code_great[of nl] godel_code_eq_1[of nl]
   apply(simp)
   done
 
 lemma prime_coprime: "\<lbrakk>Prime x; Prime y; x\<noteq>y\<rbrakk> \<Longrightarrow> coprime x y"
 proof (simp only: Prime.simps coprime_def, auto simp: dvd_def,
     rule_tac classical, simp)
   fix d k ka
   assume case_ka: "\<forall>u<d * ka. \<forall>v<d * ka. u * v \<noteq> d * ka" 
     and case_k: "\<forall>u<d * k. \<forall>v<d * k. u * v \<noteq> d * k"
     and h: "(0::nat) < d" "d \<noteq> Suc 0" "Suc 0 < d * ka" 
     "ka \<noteq> k" "Suc 0 < d * k"
   from h have "k > Suc 0 \<or> ka >Suc 0"
     by (cases ka;cases k;force+)
   from this show "False"
   proof(erule_tac disjE)
     assume  "(Suc 0::nat) < k"
     hence "k < d*k \<and> d < d*k"
       using h
       by(auto)
     thus "?thesis"
       using case_k
       apply(erule_tac x = d in allE)
       apply(simp)
       apply(erule_tac x = k in allE)
       apply(simp)
       done
   next
     assume "(Suc 0::nat) < ka"
     hence "ka < d * ka \<and> d < d*ka"
       using h by auto
     thus "?thesis"
       using case_ka
       apply(erule_tac x = d in allE)
       apply(simp)
       apply(erule_tac x = ka in allE)
       apply(simp)
       done
   qed
 qed
 
 lemma Pi_inc: "Pi (Suc i) > Pi i"
 proof(simp add: Pi.simps Np.simps)
   let ?setx = "{y. y \<le> Suc (Pi i!) \<and> Pi i < y \<and> Prime y}"
   have "finite ?setx" by simp
   moreover have "?setx \<noteq> {}"
     using prime_ex[of "Pi i"]
     apply(auto)
     done
   ultimately show "Pi i < Min ?setx"
     apply(simp)
     done
 qed    
 
 lemma Pi_inc_gr: "i < j \<Longrightarrow> Pi i < Pi j"
 proof(induct j, simp)
   fix j
   assume ind: "i < j \<Longrightarrow> Pi i < Pi j"
     and h: "i < Suc j"
   from h show "Pi i < Pi (Suc j)"
   proof(cases "i < j")
     case True thus "?thesis"
     proof -
       assume "i < j"
       hence "Pi i < Pi j" by(erule_tac ind)
       moreover have "Pi j < Pi (Suc j)"
         apply(simp add: Pi_inc)
         done
       ultimately show "?thesis"
         by simp
     qed
   next
     assume "i < Suc j" "\<not> i < j"
     hence "i = j"
       by arith
     thus "Pi i < Pi (Suc j)"
       apply(simp add: Pi_inc)
       done
   qed
 qed      
 
 lemma Pi_notEq: "i \<noteq> j \<Longrightarrow> Pi i \<noteq> Pi j"
   apply(cases "i < j")
   using Pi_inc_gr[of i j]
    apply(simp)
   using Pi_inc_gr[of j i]
   apply(simp)
   done
 
 lemma prime_2[intro]: "Prime (Suc (Suc 0))"
   apply(auto simp: Prime.simps)
   using less_2_cases by fastforce
 
 lemma Prime_Pi[intro]: "Prime (Pi n)"
 proof(induct n, auto simp: Pi.simps Np.simps)
   fix n
   let ?setx = "{y. y \<le> Suc (Pi n!) \<and> Pi n < y \<and> Prime y}"
   show "Prime (Min ?setx)"
   proof -
     have "finite ?setx" by simp
     moreover have "?setx \<noteq> {}" 
       using prime_ex[of "Pi n"]
       apply(simp)
       done
     ultimately show "?thesis"
       apply(drule_tac Min_in, simp, simp)
       done
   qed
 qed
 
 lemma Pi_coprime: "i \<noteq> j \<Longrightarrow> coprime (Pi i) (Pi j)"
   using Prime_Pi[of i]
   using Prime_Pi[of j]
   apply(rule_tac prime_coprime, simp_all add: Pi_notEq)
   done
 
 lemma Pi_power_coprime: "i \<noteq> j \<Longrightarrow> coprime ((Pi i)^m) ((Pi j)^n)"
   unfolding coprime_power_right_iff coprime_power_left_iff using Pi_coprime by auto
 
 lemma coprime_dvd_mult_nat2: "\<lbrakk>coprime (k::nat) n; k dvd n * m\<rbrakk> \<Longrightarrow> k dvd m"
   unfolding coprime_dvd_mult_right_iff.
 
 declare godel_code'.simps[simp del]
 
 lemma godel_code'_butlast_last_id' :
   "godel_code' (ys @ [y]) (Suc j) = godel_code' ys (Suc j) * 
                                 Pi (Suc (length ys + j)) ^ y"
 proof(induct ys arbitrary: j, simp_all add: godel_code'.simps)
 qed  
 
 lemma godel_code'_butlast_last_id: 
   "xs \<noteq> [] \<Longrightarrow> godel_code' xs (Suc j) = 
   godel_code' (butlast xs) (Suc j) * Pi (length xs + j)^(last xs)"
   apply(subgoal_tac "\<exists> ys y. xs = ys @ [y]")
    apply(erule_tac exE, erule_tac exE, simp add: 
       godel_code'_butlast_last_id')
   apply(rule_tac x = "butlast xs" in exI)
   apply(rule_tac x = "last xs" in exI, auto)
   done
 
 lemma godel_code'_not0: "godel_code' xs n \<noteq> 0"
   apply(induct xs, auto simp: godel_code'.simps)
   done
 
 lemma godel_code_append_cons: 
   "length xs = i \<Longrightarrow> godel_code' (xs@y#ys) (Suc 0)
     = godel_code' xs (Suc 0) * Pi (Suc i)^y * godel_code' ys (i + 2)"
 proof(induct "length xs" arbitrary: i y ys xs, simp add: godel_code'.simps,simp)
   fix x xs i y ys
   assume ind: 
     "\<And>xs i y ys. \<lbrakk>x = i; length xs = i\<rbrakk> \<Longrightarrow> 
        godel_code' (xs @ y # ys) (Suc 0) 
      = godel_code' xs (Suc 0) * Pi (Suc i) ^ y * 
                              godel_code' ys (Suc (Suc i))"
     and h: "Suc x = i" 
     "length (xs::nat list) = i"
   have 
     "godel_code' (butlast xs @ last xs # ((y::nat)#ys)) (Suc 0) = 
         godel_code' (butlast xs) (Suc 0) * Pi (Suc (i - 1))^(last xs) 
               * godel_code' (y#ys) (Suc (Suc (i - 1)))"
     apply(rule_tac ind)
     using h
     by(auto)
   moreover have 
     "godel_code' xs (Suc 0)= godel_code' (butlast xs) (Suc 0) *
                                                   Pi (i)^(last xs)"
     using godel_code'_butlast_last_id[of xs] h
     apply(cases "xs = []", simp, simp)
     done 
   moreover have "butlast xs @ last xs # y # ys = xs @ y # ys"
     using h
     apply(cases xs, auto)
     done
   ultimately show 
     "godel_code' (xs @ y # ys) (Suc 0) =
                godel_code' xs (Suc 0) * Pi (Suc i) ^ y *
                     godel_code' ys (Suc (Suc i))"
     using h
     apply(simp add: godel_code'_not0 Pi_not_0)
     apply(simp add: godel_code'.simps)
     done
 qed
 
 lemma Pi_coprime_pre: 
   "length ps \<le> i \<Longrightarrow> coprime (Pi (Suc i)) (godel_code' ps (Suc 0))"
 proof(induct "length ps" arbitrary: ps)
   fix x ps
   assume ind: 
     "\<And>ps. \<lbrakk>x = length ps; length ps \<le> i\<rbrakk> \<Longrightarrow>
                   coprime (Pi (Suc i)) (godel_code' ps (Suc 0))"
     and h: "Suc x = length ps"
     "length (ps::nat list) \<le> i"
   have g: "coprime (Pi (Suc i)) (godel_code' (butlast ps) (Suc 0))"
     apply(rule_tac ind)
     using h by auto
   have k: "godel_code' ps (Suc 0) = 
          godel_code' (butlast ps) (Suc 0) * Pi (length ps)^(last ps)"
     using godel_code'_butlast_last_id[of ps 0] h 
     by(cases ps, simp, simp)
   from g have "coprime (Pi (Suc i)) (Pi (length ps) ^ last ps)"
     unfolding coprime_power_right_iff using Pi_coprime h(2) by auto
   with g have 
     "coprime (Pi (Suc i)) (godel_code' (butlast ps) (Suc 0) *
                                         Pi (length ps)^(last ps)) "
     unfolding coprime_mult_right_iff coprime_power_right_iff by auto
 
   from this and k show "coprime (Pi (Suc i)) (godel_code' ps (Suc 0))"
     by simp
 qed (auto simp add: godel_code'.simps)
 
 lemma Pi_coprime_suf: "i < j \<Longrightarrow> coprime (Pi i) (godel_code' ps j)"
 proof(induct "length ps" arbitrary: ps)
   fix x ps
   assume ind: 
     "\<And>ps. \<lbrakk>x = length ps; i < j\<rbrakk> \<Longrightarrow> 
                     coprime (Pi i) (godel_code' ps j)"
     and h: "Suc x = length (ps::nat list)" "i < j"
   have g: "coprime (Pi i) (godel_code' (butlast ps) j)"
     apply(rule ind) using h by auto
   have k: "(godel_code' ps j) = godel_code' (butlast ps) j *
                                  Pi (length ps + j - 1)^last ps"
     using h godel_code'_butlast_last_id[of ps "j - 1"]
     apply(cases "ps = []", simp, simp)
     done
   from g have
     "coprime (Pi i) (godel_code' (butlast ps) j * 
                           Pi (length ps + j - 1)^last ps)"
     using Pi_power_coprime[of i "length ps + j - 1" 1 "last ps"] h
     by(auto)
   from k and this show "coprime (Pi i) (godel_code' ps j)"
     by auto
 qed (simp add: godel_code'.simps)
 
 lemma godel_finite: 
   "finite {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
 proof(rule bounded_nat_set_is_finite[of _ "godel_code' nl (Suc 0)",rule_format],goal_cases)
   case (1 ia)
   then show ?case proof(cases "ia < godel_code' nl (Suc 0)")
     case False
     hence g1: "Pi (Suc i) ^ ia dvd godel_code' nl (Suc 0)"
       and g2: "\<not> ia < godel_code' nl (Suc 0)"
       and "Pi (Suc i)^ia \<le> godel_code' nl (Suc 0)"
       using godel_code'_not0[of nl "Suc 0"] using 1 by (auto elim:dvd_imp_le)
     moreover have "ia < Pi (Suc i)^ia"
       by(rule x_less_exp[OF Pi_gr_1])
     ultimately show ?thesis
       using g2 by(auto)
   qed auto
 qed
 
 lemma godel_code_in: 
   "i < length nl \<Longrightarrow>  nl ! i  \<in> {u. Pi (Suc i) ^ u dvd
                                      godel_code' nl (Suc 0)}"
 proof -
   assume h: "i<length nl"
   hence "godel_code' (take i nl@(nl!i)#drop (Suc i) nl) (Suc 0)
            = godel_code' (take i nl) (Suc 0) *  Pi (Suc i)^(nl!i) *
                                godel_code' (drop (Suc i) nl) (i + 2)"
     by(rule_tac godel_code_append_cons, simp)
   moreover from h have "take i nl @ (nl ! i) # drop (Suc i) nl = nl"
     using upd_conv_take_nth_drop[of i nl "nl ! i"]
     by simp
   ultimately  show 
     "nl ! i \<in> {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
     by(simp)
 qed
 
 lemma godel_code'_get_nth:
   "i < length nl \<Longrightarrow> Max {u. Pi (Suc i) ^ u dvd 
                           godel_code' nl (Suc 0)} = nl ! i"
 proof(rule_tac Max_eqI)
   let ?gc = "godel_code' nl (Suc 0)"
   assume h: "i < length nl" thus "finite {u. Pi (Suc i) ^ u dvd ?gc}"
     by (simp add: godel_finite)  
 next
   fix y
   let ?suf ="godel_code' (drop (Suc i) nl) (i + 2)"
   let ?pref = "godel_code' (take i nl) (Suc 0)"
   assume h: "i < length nl" 
     "y \<in> {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
   moreover hence
     "godel_code' (take i nl@(nl!i)#drop (Suc i) nl) (Suc 0)
     = ?pref * Pi (Suc i)^(nl!i) * ?suf"
     by(rule_tac godel_code_append_cons, simp)
   moreover from h have "take i nl @ (nl!i) # drop (Suc i) nl = nl"
     using upd_conv_take_nth_drop[of i nl "nl!i"]
     by simp
   ultimately show "y\<le>nl!i"
   proof(simp)
     let ?suf' = "godel_code' (drop (Suc i) nl) (Suc (Suc i))"
     assume mult_dvd: 
       "Pi (Suc i) ^ y dvd ?pref *  Pi (Suc i) ^ nl ! i * ?suf'"
     hence "Pi (Suc i) ^ y dvd ?pref * Pi (Suc i) ^ nl ! i"
     proof -
       have "coprime (Pi (Suc i)^y) ?suf'" by (simp add: Pi_coprime_suf)
       thus ?thesis using coprime_dvd_mult_left_iff mult_dvd by blast
     qed
     hence "Pi (Suc i) ^ y dvd Pi (Suc i) ^ nl ! i"
     proof(rule_tac coprime_dvd_mult_nat2)
       have "coprime (Pi (Suc i)^y) (?pref^Suc 0)" using Pi_coprime_pre by simp
       thus "coprime (Pi (Suc i) ^ y) ?pref" by simp
     qed
     hence "Pi (Suc i) ^ y \<le>  Pi (Suc i) ^ nl ! i "
       apply(rule_tac dvd_imp_le, auto)
       done
     thus "y \<le> nl ! i"
       apply(rule_tac power_le_imp_le_exp, auto)
       done
   qed
 next
   assume h: "i<length nl"
 
   thus "nl ! i \<in> {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
     by(rule_tac godel_code_in, simp)
 qed
 
 lemma godel_code'_set[simp]: 
   "{u. Pi (Suc i) ^ u dvd (Suc (Suc 0)) ^ length nl * 
                                      godel_code' nl (Suc 0)} = 
     {u. Pi (Suc i) ^ u dvd  godel_code' nl (Suc 0)}"
   apply(rule_tac Collect_cong, auto)
   apply(rule_tac n = " (Suc (Suc 0)) ^ length nl" in 
       coprime_dvd_mult_nat2)
 proof -
   have "Pi 0 = (2::nat)" by(simp add: Pi.simps)
   show "coprime (Pi (Suc i) ^ u) ((Suc (Suc 0)) ^ length nl)" for u
     using Pi_coprime Pi.simps(1) by force
 qed
 
 lemma godel_code_get_nth: 
   "i < length nl \<Longrightarrow> 
            Max {u. Pi (Suc i) ^ u dvd godel_code nl} = nl ! i"
   by(simp add: godel_code.simps godel_code'_get_nth)
 
 lemma mod_dvd_simp: "(x mod y = (0::nat)) = (y dvd x)"
   by(simp add: dvd_def, auto)
 
 lemma dvd_power_le: "\<lbrakk>a > Suc 0; a ^ y dvd a ^ l\<rbrakk> \<Longrightarrow> y \<le> l"
   apply(cases "y \<le> l", simp, simp)
   apply(subgoal_tac "\<exists> d. y = l + d", auto simp: power_add)
   apply(rule_tac x = "y - l" in exI, simp)
   done
 
 
 lemma Pi_nonzeroE[elim]: "Pi n = 0 \<Longrightarrow> RR"
   using Pi_not_0[of n] by simp
 
 lemma Pi_not_oneE[elim]: "Pi n = Suc 0 \<Longrightarrow> RR"
   using Pi_gr_1[of n] by simp
 
 lemma finite_power_dvd:
   "\<lbrakk>(a::nat) > Suc 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> finite {u. a^u dvd y}"
   apply(auto simp: dvd_def simp:gr0_conv_Suc intro!:bounded_nat_set_is_finite[of _ y])
   by (metis le_less_trans mod_less mod_mult_self1_is_0 not_le Suc_lessD less_trans_Suc
       mult.right_neutral n_less_n_mult_m x_less_exp
       zero_less_Suc zero_less_mult_pos)
 
 lemma conf_decode1: "\<lbrakk>m \<noteq> n; m \<noteq> k; k \<noteq> n\<rbrakk> \<Longrightarrow> 
   Max {u. Pi m ^ u dvd Pi m ^ l * Pi n ^ st * Pi k ^ r} = l"
 proof -
   let ?setx = "{u. Pi m ^ u dvd Pi m ^ l * Pi n ^ st * Pi k ^ r}"
   assume g: "m \<noteq> n" "m \<noteq> k" "k \<noteq> n"
   show "Max ?setx = l"
   proof(rule_tac Max_eqI)
     show "finite ?setx"
       apply(rule_tac finite_power_dvd, auto)
       done
   next
     fix y
     assume h: "y \<in> ?setx"
     have "Pi m ^ y dvd Pi m ^ l"
     proof -
       have "Pi m ^ y dvd Pi m ^ l * Pi n ^ st"
         using h g Pi_power_coprime
         by (simp add: coprime_dvd_mult_left_iff)
       thus "Pi m^y dvd Pi m^l" using g Pi_power_coprime coprime_dvd_mult_left_iff by blast
     qed
     thus "y \<le> (l::nat)"
       apply(rule_tac a = "Pi m" in power_le_imp_le_exp)
        apply(simp_all)
       apply(rule_tac dvd_power_le, auto)
       done
   next
     show "l \<in> ?setx" by simp
   qed
 qed
 
 lemma left_trpl_fst[simp]: "left (trpl l st r) = l"
   apply(simp add: left.simps trpl.simps lo.simps loR.simps mod_dvd_simp)
   apply(auto simp: conf_decode1)
    apply(cases "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r")
     apply(auto)
   apply(erule_tac x = l in allE, auto)
   done   
 
 lemma stat_trpl_snd[simp]: "stat (trpl l st r) = st"
   apply(simp add: stat.simps trpl.simps lo.simps 
       loR.simps mod_dvd_simp, auto)
     apply(subgoal_tac "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r
                = Pi (Suc 0)^st * Pi 0 ^ l *  Pi (Suc (Suc 0)) ^ r")
      apply(simp (no_asm_simp) add: conf_decode1, simp)
    apply(cases "Pi 0 ^ l * Pi (Suc 0) ^ st * 
                                   Pi (Suc (Suc 0)) ^ r", auto)
   apply(erule_tac x = st in allE, auto)
   done
 
 lemma rght_trpl_trd[simp]: "rght (trpl l st r) = r"
   apply(simp add: rght.simps trpl.simps lo.simps 
       loR.simps mod_dvd_simp, auto)
     apply(subgoal_tac "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r
                = Pi (Suc (Suc 0))^r * Pi 0 ^ l *  Pi (Suc 0) ^ st")
      apply(simp (no_asm_simp) add: conf_decode1, simp)
    apply(cases "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r",
       auto)
   apply(erule_tac x = r in allE, auto)
   done
 
 lemma max_lor:
   "i < length nl \<Longrightarrow> Max {u. loR [godel_code nl, Pi (Suc i), u]} 
                    = nl ! i"
   apply(simp add: loR.simps godel_code_get_nth mod_dvd_simp)
   done
 
 lemma godel_decode: 
   "i < length nl \<Longrightarrow> Entry (godel_code nl) i = nl ! i"
   apply(auto simp: Entry.simps lo.simps max_lor)
   apply(erule_tac x = "nl!i" in allE)
   using max_lor[of i nl] godel_finite[of i nl]
   apply(simp)
   apply(drule_tac Max_in, auto simp: loR.simps 
       godel_code.simps mod_dvd_simp)
   using godel_code_in[of i nl]
   apply(simp)
   done
 
 lemma Four_Suc: "4 = Suc (Suc (Suc (Suc 0)))"
   by auto
 
 declare numeral_2_eq_2[simp del]
 
 lemma modify_tprog_fetch_even: 
   "\<lbrakk>st \<le> length tp div 2; st > 0\<rbrakk> \<Longrightarrow>
   modify_tprog tp ! (4 * (st - Suc 0) ) = 
   action_map (fst (tp ! (2 * (st - Suc 0))))"
 proof(induct st arbitrary: tp, simp)
   fix tp st
   assume ind: 
     "\<And>tp. \<lbrakk>st \<le> length tp div 2; 0 < st\<rbrakk> \<Longrightarrow> 
      modify_tprog tp ! (4 * (st - Suc 0)) =
                action_map (fst ((tp::instr list) ! (2 * (st - Suc 0))))"
     and h: "Suc st \<le> length (tp::instr list) div 2" "0 < Suc st"
   thus "modify_tprog tp ! (4 * (Suc st - Suc 0)) = 
           action_map (fst (tp ! (2 * (Suc st - Suc 0))))"
   proof(cases "st = 0")
     case True thus "?thesis"
       using h by(cases tp, auto)
   next
     case False
     assume g: "st \<noteq> 0"
     hence "\<exists> aa ab ba bb tp'. tp = (aa, ab) # (ba, bb) # tp'"
       using h by(cases tp; cases "tl tp", auto)
     from this obtain aa ab ba bb tp' where g1: 
       "tp = (aa, ab) # (ba, bb) # tp'" by blast
     hence g2: 
       "modify_tprog tp' ! (4 * (st - Suc 0)) = 
       action_map (fst ((tp'::instr list) ! (2 * (st - Suc 0))))"
       using h g by (auto intro:ind)
     thus "?thesis"
       using g1 g
       by(cases st, auto simp add: Four_Suc)
   qed
 qed
 
 lemma modify_tprog_fetch_odd: 
   "\<lbrakk>st \<le> length tp div 2; st > 0\<rbrakk> \<Longrightarrow> 
        modify_tprog tp ! (Suc (Suc (4 * (st - Suc 0)))) = 
        action_map (fst (tp ! (Suc (2 * (st - Suc 0)))))"
 proof(induct st arbitrary: tp, simp)
   fix tp st
   assume ind: 
     "\<And>tp. \<lbrakk>st \<le> length tp div 2; 0 < st\<rbrakk> \<Longrightarrow>  
        modify_tprog tp ! Suc (Suc (4 * (st - Suc 0))) = 
           action_map (fst (tp ! Suc (2 * (st - Suc 0))))"
     and h: "Suc st \<le> length (tp::instr list) div 2" "0 < Suc st"
   thus "modify_tprog tp ! Suc (Suc (4 * (Suc st - Suc 0))) 
      = action_map (fst (tp ! Suc (2 * (Suc st - Suc 0))))"
   proof(cases "st = 0")
     case True thus "?thesis"
       using h
       apply(cases tp, force)
       by(cases "tl tp", auto)
   next
     case False
     assume g: "st \<noteq> 0"
     hence "\<exists> aa ab ba bb tp'. tp = (aa, ab) # (ba, bb) # tp'"
       using h
       apply(cases tp, simp, cases "tl tp", simp, simp)
       done
     from this obtain aa ab ba bb tp' where g1: 
       "tp = (aa, ab) # (ba, bb) # tp'" by blast
     hence g2: "modify_tprog tp' ! Suc (Suc (4 * (st  - Suc 0))) = 
           action_map (fst (tp' ! Suc (2 * (st - Suc 0))))"
       apply(rule_tac ind)
       using h g by auto
     thus "?thesis"
       using g1 g
       apply(cases st, simp, simp add: Four_Suc)
       done
   qed
 qed    
 
 lemma modify_tprog_fetch_action:
   "\<lbrakk>st \<le> length tp div 2; st > 0; b = 1 \<or> b = 0\<rbrakk> \<Longrightarrow> 
       modify_tprog tp ! (4 * (st - Suc 0) + 2* b) =
       action_map (fst (tp ! ((2 * (st - Suc 0)) + b)))"
   apply(erule_tac disjE, auto elim: modify_tprog_fetch_odd
       modify_tprog_fetch_even)
   done 
 
 lemma length_modify: "length (modify_tprog tp) = 2 * length tp"
   apply(induct tp, auto)
   done
 
 declare fetch.simps[simp del]
 
 lemma fetch_action_eq: 
   "\<lbrakk>block_map b = scan r; fetch tp st b = (nact, ns);
    st \<le> length tp div 2\<rbrakk> \<Longrightarrow> actn (code tp) st r = action_map nact"
 proof(simp add: actn.simps, auto)
   let ?i = "4 * (st - Suc 0) + 2 * (r mod 2)"
   assume h: "block_map b = r mod 2" "fetch tp st b = (nact, ns)" 
     "st \<le> length tp div 2" "0 < st"
   have "?i < length (modify_tprog tp)"
   proof -
     have "length (modify_tprog tp) = 2 * length tp"
       by(simp add: length_modify)
     thus "?thesis"
       using h
       by(auto)
   qed
   hence 
     "Entry (godel_code (modify_tprog tp))?i = 
                                    (modify_tprog tp) ! ?i"
     by(erule_tac godel_decode)
   moreover have 
     "modify_tprog tp ! ?i = 
             action_map (fst (tp ! (2 * (st - Suc 0) + r mod 2)))"
     apply(rule_tac  modify_tprog_fetch_action)
     using h
     by(auto)    
   moreover have "(fst (tp ! (2 * (st - Suc 0) + r mod 2))) = nact"
     using h
     apply(cases st, simp_all add: fetch.simps nth_of.simps)
     apply(cases b, auto simp: block_map.simps nth_of.simps fetch.simps 
         split: if_splits)
     apply(cases "r mod 2", simp, simp)
     done
   ultimately show 
     "Entry (godel_code (modify_tprog tp))
                       (4 * (st - Suc 0) + 2 * (r mod 2))
            = action_map nact" 
     by simp
 qed
 
 lemma fetch_zero_zero[simp]: "fetch tp 0 b = (nact, ns) \<Longrightarrow> ns = 0"
   by(simp add: fetch.simps)
 
 lemma modify_tprog_fetch_state:
   "\<lbrakk>st \<le> length tp div 2; st > 0; b = 1 \<or> b = 0\<rbrakk> \<Longrightarrow> 
      modify_tprog tp ! Suc (4 * (st - Suc 0) + 2 * b) =
   (snd (tp ! (2 * (st - Suc 0) + b)))"
 proof(induct st arbitrary: tp, simp)
   fix st tp
   assume ind: 
     "\<And>tp. \<lbrakk>st \<le> length tp div 2; 0 < st; b = 1 \<or> b = 0\<rbrakk> \<Longrightarrow> 
     modify_tprog tp ! Suc (4 * (st - Suc 0) + 2 * b) =
                              snd (tp ! (2 * (st - Suc 0) + b))"
     and h:
     "Suc st \<le> length (tp::instr list) div 2" 
     "0 < Suc st" 
     "b = 1 \<or> b = 0"
   show "modify_tprog tp ! Suc (4 * (Suc st - Suc 0) + 2 * b) =
                              snd (tp ! (2 * (Suc st - Suc 0) + b))"
   proof(cases "st = 0")
     case True
     thus "?thesis"
       using h
       apply(cases tp, force)
       apply(cases "tl tp", auto)
       done
   next
     case False
     assume g: "st \<noteq> 0"
     hence "\<exists> aa ab ba bb tp'. tp = (aa, ab) # (ba, bb) # tp'"
       using h
       by(cases tp, force, cases "tl tp", auto)
     from this obtain aa ab ba bb tp' where g1:
       "tp = (aa, ab) # (ba, bb) # tp'" by blast
     hence g2: 
       "modify_tprog tp' ! Suc (4 * (st - Suc 0) + 2 * b) =
                               snd (tp' ! (2 * (st - Suc 0) + b))"
       apply(intro ind)
       using h g by auto
     thus "?thesis"
       using g1 g
       by(cases st;force)
   qed
 qed
 
 lemma fetch_state_eq:
   "\<lbrakk>block_map b = scan r; 
   fetch tp st b = (nact, ns);
   st \<le> length tp div 2\<rbrakk> \<Longrightarrow> newstat (code tp) st r = ns"
 proof(simp add: newstat.simps, auto)
   let ?i = "Suc (4 * (st - Suc 0) + 2 * (r mod 2))"
   assume h: "block_map b = r mod 2" "fetch tp st b =
              (nact, ns)" "st \<le> length tp div 2" "0 < st"
   have "?i < length (modify_tprog tp)"
   proof -
     have "length (modify_tprog tp) = 2 * length tp"
       by(simp add: length_modify)
     thus "?thesis"
       using h
       by(auto)
   qed
   hence "Entry (godel_code (modify_tprog tp)) (?i) = 
                                   (modify_tprog tp) ! ?i"
     by(erule_tac godel_decode)
   moreover have 
     "modify_tprog tp ! ?i =  
                (snd (tp ! (2 * (st - Suc 0) + r mod 2)))"
     apply(rule_tac  modify_tprog_fetch_state)
     using h
     by(auto)
   moreover have "(snd (tp ! (2 * (st - Suc 0) + r mod 2))) = ns"
     using h
     apply(cases st, simp)
     apply(cases b, auto simp: fetch.simps split: if_splits)
     apply(cases "(2 * (st - r mod 2) + r mod 2) = 
                        (2 * (st - 1) + r mod 2)";auto)
     by (metis diff_Suc_Suc diff_zero prod.sel(2))
   ultimately show "Entry (godel_code (modify_tprog tp)) (?i)
            = ns" 
     by simp
 qed
 
 
 lemma tpl_eqI[intro!]: 
   "\<lbrakk>a = a'; b = b'; c = c'\<rbrakk> \<Longrightarrow> trpl a b c = trpl a' b' c'"
   by simp
 
 lemma bl2nat_double: "bl2nat xs (Suc n) = 2 * bl2nat xs n"
 proof(induct xs arbitrary: n)
   case Nil thus "?case"
     by(simp add: bl2nat.simps)
 next
   case (Cons x xs) thus "?case"
   proof -
     assume ind: "\<And>n. bl2nat xs (Suc n) = 2 * bl2nat xs n "
     show "bl2nat (x # xs) (Suc n) = 2 * bl2nat (x # xs) n"
     proof(cases x)
       case Bk thus "?thesis"
         apply(simp add: bl2nat.simps)
         using ind[of "Suc n"] by simp
     next
       case Oc thus "?thesis"
         apply(simp add: bl2nat.simps)
         using ind[of "Suc n"] by simp
     qed
   qed
 qed
 
 
 lemma bl2wc_simps[simp]:
   "bl2wc (Oc # tl c) = Suc (bl2wc c) - bl2wc c mod 2 "
   "bl2wc (Bk # c) = 2*bl2wc (c)"
   "2 * bl2wc (tl c) = bl2wc c - bl2wc c mod 2 "
   "bl2wc [Oc] = Suc 0"
   "c \<noteq> [] \<Longrightarrow> bl2wc (tl c) = bl2wc c div 2"
   "c \<noteq> [] \<Longrightarrow> bl2wc [hd c] = bl2wc c mod 2"
   "c \<noteq> [] \<Longrightarrow> bl2wc (hd c # d) = 2 * bl2wc d + bl2wc c mod 2"
   "2 * (bl2wc c div 2) = bl2wc c - bl2wc c mod 2"
   "bl2wc (Oc # list) mod 2 = Suc 0" 
   by(cases c;cases "hd c";force simp: bl2wc.simps bl2nat.simps bl2nat_double)+
 
 declare code.simps[simp del]
 declare nth_of.simps[simp del]
 
 text \<open>
   The lemma relates the one step execution of TMs with the interpreter function \<open>rec_newconf\<close>.
 \<close>
 lemma rec_t_eq_step: 
   "(\<lambda> (s, l, r). s \<le> length tp div 2) c \<Longrightarrow>
   trpl_code (step0 c tp) = 
   rec_exec rec_newconf [code tp, trpl_code c]"
 proof(cases c)
   case (fields s l r) assume "case c of (s, l, r) \<Rightarrow> s \<le> length tp div 2"
   with fields have "s \<le> length tp div 2" by auto
   thus ?thesis unfolding fields 
   proof(cases "fetch tp s (read r)",
       simp add: newconf.simps trpl_code.simps step.simps)
     fix a b ca aa ba
     assume h: "(a::nat) \<le> length tp div 2" 
       "fetch tp a (read ca) = (aa, ba)"
     moreover hence "actn (code tp) a (bl2wc ca) = action_map aa"
       apply(rule_tac b = "read ca" 
           in fetch_action_eq, auto)
       apply(cases "hd ca";cases ca;force)
       done
     moreover from h have "(newstat (code tp) a (bl2wc ca)) = ba"
       apply(rule_tac b = "read ca" 
           in fetch_state_eq, auto split: list.splits)
       apply(cases "hd ca";cases ca;force)
       done
     ultimately show 
       "trpl_code (ba, update aa (b, ca)) =
           trpl (newleft (bl2wc b) (bl2wc ca) (actn (code tp) a (bl2wc ca))) 
     (newstat (code tp) a (bl2wc ca)) (newrght (bl2wc b) (bl2wc ca) (actn (code tp) a (bl2wc ca)))"
       apply(cases aa)
           apply(auto simp: trpl_code.simps 
           newleft.simps newrght.simps split: action.splits)
       done
   qed
 qed
 
 lemma bl2nat_simps[simp]: "bl2nat (Oc # Oc\<up>x) 0 = (2 * 2 ^ x - Suc 0)"
   "bl2nat (Bk\<up>x) n = 0"
   by(induct x;force simp: bl2nat.simps bl2nat_double exp_ind)+
 
 lemma bl2nat_exp_zero[simp]: "bl2nat (Oc\<up>y) 0 = 2^y - Suc 0"
 proof(induct y)
   case (Suc y)
   then show ?case by(cases "(2::nat)^y", auto)
 qed (auto simp: bl2nat.simps bl2nat_double)
 
 lemma bl2nat_cons_bk: "bl2nat (ks @ [Bk]) 0 = bl2nat ks 0"
 proof(induct ks)
   case (Cons a ks)
   then show ?case by (cases a, auto simp: bl2nat.simps bl2nat_double)
 qed (auto simp: bl2nat.simps)
 
 lemma bl2nat_cons_oc:
   "bl2nat (ks @ [Oc]) 0 =  bl2nat ks 0 + 2 ^ length ks"
 proof(induct ks)
   case (Cons a ks)
   then show ?case 
     by(cases a, auto simp: bl2nat.simps bl2nat_double)
 qed (auto simp: bl2nat.simps)
 
 lemma bl2nat_append: 
   "bl2nat (xs @ ys) 0 = bl2nat xs 0 + bl2nat ys (length xs) "
 proof(induct "length xs" arbitrary: xs ys, simp add: bl2nat.simps)
   fix x xs ys
   assume ind: 
     "\<And>xs ys. x = length xs \<Longrightarrow> 
              bl2nat (xs @ ys) 0 = bl2nat xs 0 + bl2nat ys (length xs)"
     and h: "Suc x = length (xs::cell list)"
   have "\<exists> ks k. xs = ks @ [k]" 
     apply(rule_tac x = "butlast xs" in exI,
         rule_tac x = "last xs" in exI)
     using h
     apply(cases xs, auto)
     done
   from this obtain ks k where "xs = ks @ [k]" by blast
   moreover hence 
     "bl2nat (ks @ (k # ys)) 0 = bl2nat ks 0 +
                                bl2nat (k # ys) (length ks)"
     apply(rule_tac ind) using h by simp
   ultimately show "bl2nat (xs @ ys) 0 = 
                   bl2nat xs 0 + bl2nat ys (length xs)"
     apply(cases k, simp_all add: bl2nat.simps)
      apply(simp_all only: bl2nat_cons_bk bl2nat_cons_oc)
     done
 qed
 
 lemma trpl_code_simp[simp]:
   "trpl_code (steps0 (Suc 0, Bk\<up>l, <lm>) tp 0) = 
     rec_exec rec_conf [code tp, bl2wc (<lm>), 0]"
   apply(simp add: steps.simps rec_exec.simps conf_lemma  conf.simps 
       inpt.simps trpl_code.simps bl2wc.simps)
   done
 
 text \<open>
   The following lemma relates the multi-step interpreter function \<open>rec_conf\<close>
   with the multi-step execution of TMs.
 \<close>
 lemma state_in_range_step
-  : "\<lbrakk>a \<le> length A div 2; step0 (a, b, c) A = (st, l, r); tm_wf (A,0)\<rbrakk>
+  : "\<lbrakk>a \<le> length A div 2; step0 (a, b, c) A = (st, l, r); composable_tm (A,0)\<rbrakk>
   \<Longrightarrow> st \<le> length A div 2"
-  apply(simp add: step.simps fetch.simps tm_wf.simps 
+  apply(simp add: step.simps fetch.simps composable_tm.simps 
       split: if_splits list.splits)
    apply(case_tac [!] a, auto simp: list_all_length 
       fetch.simps nth_of.simps)
    apply(erule_tac x = "A ! (2*nat) " in ballE, auto)
   apply(cases "hd c", auto simp: fetch.simps nth_of.simps)
    apply(erule_tac x = "A !(2 * nat)" in ballE, auto)
   apply(erule_tac x = "A !Suc (2 * nat)" in ballE, auto)
   done
 
-lemma state_in_range: "\<lbrakk>steps0 (Suc 0, tp) A stp = (st, l, r); tm_wf (A, 0)\<rbrakk>
+lemma state_in_range: "\<lbrakk>steps0 (Suc 0, tp) A stp = (st, l, r); composable_tm (A, 0)\<rbrakk>
   \<Longrightarrow> st \<le> length A div 2"
 proof(induct stp arbitrary: st l r)
   case (Suc stp st l r)
   from Suc.prems show ?case
   proof(simp add: step_red, cases "(steps0 (Suc 0, tp) A stp)", simp)
     fix a b c 
     assume h3: "step0 (a, b, c) A = (st, l, r)"
       and h4: "steps0 (Suc 0, tp) A stp = (a, b, c)"
     have "a \<le> length A div 2" using Suc.prems h4 by (auto intro: Suc.hyps)
     thus "?thesis" using h3 Suc.prems by (auto elim: state_in_range_step)
   qed
-qed(auto simp: tm_wf.simps steps.simps)
+qed(auto simp: composable_tm.simps steps.simps)
 
 lemma rec_t_eq_steps:
-  "tm_wf (tp,0) \<Longrightarrow>
+  "composable_tm (tp,0) \<Longrightarrow>
   trpl_code (steps0 (Suc 0, Bk\<up>l, <lm>) tp stp) = 
   rec_exec rec_conf [code tp, bl2wc (<lm>), stp]"
 proof(induct stp)
   case 0 thus "?case" by(simp)
 next
   case (Suc n) thus "?case"
   proof -
     assume ind: 
-      "tm_wf (tp,0) \<Longrightarrow> trpl_code (steps0 (Suc 0, Bk\<up> l, <lm>) tp n) 
+      "composable_tm (tp,0) \<Longrightarrow> trpl_code (steps0 (Suc 0, Bk\<up> l, <lm>) tp n) 
       = rec_exec rec_conf [code tp, bl2wc (<lm>), n]"
-      and h: "tm_wf (tp, 0)"
+      and h: "composable_tm (tp, 0)"
     show 
       "trpl_code (steps0 (Suc 0, Bk\<up> l, <lm>) tp (Suc n)) =
       rec_exec rec_conf [code tp, bl2wc (<lm>), Suc n]"
     proof(cases "steps0 (Suc 0, Bk\<up> l, <lm>) tp  n", 
         simp only: step_red conf_lemma conf.simps)
       fix a b c
       assume g: "steps0 (Suc 0, Bk\<up> l, <lm>) tp n = (a, b, c) "
       hence "conf (code tp) (bl2wc (<lm>)) n= trpl_code (a, b, c)"
         using ind h
         apply(simp add: conf_lemma)
         done
       moreover hence 
         "trpl_code (step0 (a, b, c) tp) = 
         rec_exec rec_newconf [code tp, trpl_code (a, b, c)]"
         apply(rule_tac rec_t_eq_step)
         using h g
         apply(simp add: state_in_range)
         done
       ultimately show 
         "trpl_code (step0 (a, b, c) tp) =
             newconf (code tp) (conf (code tp) (bl2wc (<lm>)) n)"
         by(simp)
     qed
   qed
 qed
 
 lemma bl2wc_Bk_0[simp]: "bl2wc (Bk\<up> m) = 0"
   apply(induct m)
    apply(simp, simp)
   done
 
 lemma bl2wc_Oc_then_Bk[simp]: "bl2wc (Oc\<up> rs@Bk\<up> n) = bl2wc (Oc\<up> rs)"
   apply(induct rs, simp, 
       simp add: bl2wc.simps bl2nat.simps bl2nat_double)
   done
 
 lemma lg_power: "x > Suc 0 \<Longrightarrow> lg (x ^ rs) x = rs"
 proof(simp add: lg.simps, auto)
   fix xa
   assume h: "Suc 0 < x"
   show "Max {ya. ya \<le> x ^ rs \<and> lgR [x ^ rs, x, ya]} = rs"
     apply(rule_tac Max_eqI, simp_all add: lgR.simps)
      apply(simp add: h)
     using x_less_exp[of x rs] h
     apply(simp)
     done
 next
   assume "\<not> Suc 0 < x ^ rs" "Suc 0 < x" 
   thus "rs = 0"
     apply(cases "x ^ rs", simp, simp)
     done
 next
   assume "Suc 0 < x" "\<forall>xa. \<not> lgR [x ^ rs, x, xa]"
   thus "rs = 0"
     apply(simp only:lgR.simps)
     apply(erule_tac x = rs in allE, simp)
     done
 qed    
 
 text \<open>
   The following lemma relates execution of TMs with 
   the multi-step interpreter function \<open>rec_nonstop\<close>. Note,
   \<open>rec_nonstop\<close> is constructed using \<open>rec_conf\<close>.
 \<close>
 
-declare tm_wf.simps[simp del]
+declare composable_tm.simps[simp del]
 
 lemma nonstop_t_eq: 
   "\<lbrakk>steps0 (Suc 0, Bk\<up>l, <lm>) tp stp = (0, Bk\<up> m, Oc\<up> rs @ Bk\<up> n); 
-   tm_wf (tp, 0); 
+   composable_tm (tp, 0); 
   rs > 0\<rbrakk> 
   \<Longrightarrow> rec_exec rec_nonstop [code tp, bl2wc (<lm>), stp] = 0"
 proof(simp add: nonstop_lemma nonstop.simps )
   assume h: "steps0 (Suc 0, Bk\<up>l, <lm>) tp stp = (0, Bk\<up> m, Oc\<up> rs @ Bk\<up> n)"
-    and tc_t: "tm_wf (tp, 0)" "rs > 0"
+    and tc_t: "composable_tm (tp, 0)" "rs > 0"
   have g: "rec_exec rec_conf [code tp,  bl2wc (<lm>), stp] =
                                         trpl_code (0, Bk\<up> m, Oc\<up> rs@Bk\<up> n)"
     using rec_t_eq_steps[of tp l lm stp] tc_t h
     by(simp)
   thus "\<not> NSTD (conf (code tp) (bl2wc (<lm>)) stp)" 
   proof(auto simp: NSTD.simps)
     show "stat (conf (code tp) (bl2wc (<lm>)) stp) = 0"
       using g
       by(auto simp: conf_lemma trpl_code.simps)
   next
     show "left (conf (code tp) (bl2wc (<lm>)) stp) = 0"
       using g
       by(simp add: conf_lemma trpl_code.simps)
   next
     show "rght (conf (code tp) (bl2wc (<lm>)) stp) = 
            2 ^ lg (Suc (rght (conf (code tp) (bl2wc (<lm>)) stp))) 2 - Suc 0"
       using g h
     proof(simp add: conf_lemma trpl_code.simps)
       have "2 ^ lg (Suc (bl2wc (Oc\<up> rs))) 2 = Suc (bl2wc (Oc\<up> rs))"
         apply(simp add: bl2wc.simps lg_power)
         done
       thus "bl2wc (Oc\<up> rs) = 2 ^ lg (Suc (bl2wc (Oc\<up> rs))) 2 - Suc 0"
         apply(simp)
         done
     qed
   next
     show "0 < rght (conf (code tp) (bl2wc (<lm>)) stp)"
       using g h tc_t
       apply(simp add: conf_lemma trpl_code.simps bl2wc.simps
           bl2nat.simps)
       apply(cases rs, simp, simp add: bl2nat.simps)
       done
   qed
 qed
 
 lemma actn_0_is_4[simp]: "actn m 0 r = 4"
   by(simp add: actn.simps)
 
 lemma newstat_0_0[simp]: "newstat m 0 r = 0"
   by(simp add: newstat.simps)
 
 declare step_red[simp del]
 
 lemma halt_least_step: 
   "\<lbrakk>steps0 (Suc 0, Bk\<up>l, <lm>) tp stp = 
        (0, Bk\<up> m, Oc\<up>rs @ Bk\<up>n); 
-    tm_wf (tp, 0); 
+    composable_tm (tp, 0); 
     0<rs\<rbrakk> \<Longrightarrow>
     \<exists> stp. (nonstop (code tp) (bl2wc (<lm>)) stp = 0 \<and>
        (\<forall> stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stp \<le> stp'))"
 proof(induct stp)
   case 0
   then show ?case by (simp add: steps.simps(1))
 next
   case (Suc stp)
   hence ind: 
     "steps0 (Suc 0, Bk\<up> l, <lm>) tp stp = (0, Bk\<up> m, Oc\<up> rs @ Bk\<up> n) \<Longrightarrow> 
     \<exists>stp. nonstop (code tp) (bl2wc (<lm>)) stp = 0 \<and> 
           (\<forall>stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stp \<le> stp')"
     and h: 
     "steps0 (Suc 0, Bk\<up> l, <lm>) tp (Suc stp) = (0, Bk\<up> m, Oc\<up> rs @ Bk\<up> n)"
-    "tm_wf (tp, 0::nat)" 
+    "composable_tm (tp, 0::nat)" 
     "0 < rs" by simp+
   {
     fix a b c nat
     assume "steps0 (Suc 0, Bk\<up> l, <lm>) tp stp = (a, b, c)"
       "a = Suc nat"
     hence "\<exists>stp. nonstop (code tp) (bl2wc (<lm>)) stp = 0 \<and> 
       (\<forall>stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stp \<le> stp')"
       using h
       apply(rule_tac x = "Suc stp" in exI, auto)
        apply(drule_tac  nonstop_t_eq, simp_all add: nonstop_lemma)
     proof -
       fix stp'
       assume g:"steps0 (Suc 0, Bk\<up> l, <lm>) tp stp = (Suc nat, b, c)" 
         "nonstop (code tp) (bl2wc (<lm>)) stp' = 0"
       thus  "Suc stp \<le> stp'"
       proof(cases "Suc stp \<le> stp'", simp, simp)
         assume "\<not> Suc stp \<le> stp'"
         hence "stp' \<le> stp" by simp
         hence "\<not> is_final (steps0 (Suc 0, Bk\<up> l, <lm>) tp stp')"
           using g
           apply(cases "steps0 (Suc 0, Bk\<up> l, <lm>) tp stp'",auto, simp)
           apply(subgoal_tac "\<exists> n. stp = stp' + n", auto)
            apply(cases "fst (steps0 (Suc 0, Bk \<up> l, <lm>) tp stp')", simp_all add: steps.simps)
           apply(rule_tac x = "stp - stp'"  in exI, simp)
           done         
         hence "nonstop (code tp) (bl2wc (<lm>)) stp' = 1"
         proof(cases "steps0 (Suc 0, Bk\<up> l, <lm>) tp stp'",
             simp add: nonstop.simps)
           fix a b c
           assume k: 
             "0 < a" "steps0 (Suc 0, Bk\<up> l, <lm>) tp stp' = (a, b, c)"
           thus " NSTD (conf (code tp) (bl2wc (<lm>)) stp')"
             using rec_t_eq_steps[of tp l lm stp'] h
           proof(simp add: conf_lemma) 
             assume "trpl_code (a, b, c) = conf (code tp) (bl2wc (<lm>)) stp'"
             moreover have "NSTD (trpl_code (a, b, c))"
               using k
               apply(auto simp: trpl_code.simps NSTD.simps)
               done
             ultimately show "NSTD (conf (code tp) (bl2wc (<lm>)) stp')" by simp
           qed
         qed
         thus "False" using g by simp
       qed qed
     }
     note [intro] = this
     from h show 
       "\<exists>stp. nonstop (code tp) (bl2wc (<lm>)) stp = 0 
     \<and> (\<forall>stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stp \<le> stp')"
       by(simp add: step_red, 
           cases "steps0 (Suc 0, Bk\<up> l, <lm>) tp stp", simp, 
           cases "fst (steps0 (Suc 0, Bk\<up> l, <lm>) tp stp)",
           auto simp add: nonstop_t_eq intro:ind dest:nonstop_t_eq)
   qed    
 
 lemma conf_trpl_ex: "\<exists> p q r. conf m (bl2wc (<lm>)) stp = trpl p q r"
   apply(induct stp, auto simp: conf.simps inpt.simps trpl.simps 
       newconf.simps)
   apply(rule_tac x = 0 in exI, rule_tac x = 1 in exI, 
       rule_tac x = "bl2wc (<lm>)" in exI)
   apply(simp)
   done
 
 lemma nonstop_rgt_ex: 
   "nonstop m (bl2wc (<lm>)) stpa = 0 \<Longrightarrow> \<exists> r. conf m (bl2wc (<lm>)) stpa = trpl 0 0 r"
   apply(auto simp: nonstop.simps NSTD.simps split: if_splits)
   using conf_trpl_ex[of m lm stpa]
   apply(auto)
   done
 
 lemma max_divisors: "x > Suc 0 \<Longrightarrow> Max {u. x ^ u dvd x ^ r} = r"
 proof(rule_tac Max_eqI)
   assume "x > Suc 0"
   thus "finite {u. x ^ u dvd x ^ r}"
     apply(rule_tac finite_power_dvd, auto)
     done
 next
   fix y 
   assume "Suc 0 < x" "y \<in> {u. x ^ u dvd x ^ r}"
   thus "y \<le> r"
     apply(cases "y\<le> r", simp)
     apply(subgoal_tac "\<exists> d. y = r + d")
      apply(auto simp: power_add)
     apply(rule_tac x = "y - r" in exI, simp)
     done
 next
   show "r \<in> {u. x ^ u dvd x ^ r}" by simp
 qed  
 
 lemma lo_power:
   assumes "x > Suc 0" shows "lo (x ^ r) x = r"
 proof -
   have "\<not> Suc 0 < x ^ r \<Longrightarrow> r = 0" using assms
     by (metis Suc_lessD Suc_lessI nat_power_eq_Suc_0_iff zero_less_power)
   moreover have "\<forall>xa. \<not> x ^ xa dvd x ^ r \<Longrightarrow> r = 0"
     using dvd_refl assms by(cases "x^r";blast)
   ultimately show ?thesis using assms
     by(auto simp: lo.simps loR.simps mod_dvd_simp elim:max_divisors)
 qed
 
 lemma lo_rgt: "lo (trpl 0 0 r) (Pi 2) = r"
   apply(simp add: trpl.simps lo_power)
   done
 
 lemma conf_keep: 
   "conf m lm stp = trpl 0 0 r  \<Longrightarrow>
   conf m lm (stp + n) = trpl 0 0 r"
   apply(induct n)
    apply(auto simp: conf.simps  newconf.simps newleft.simps 
       newrght.simps rght.simps lo_rgt)
   done
 
 lemma halt_state_keep_steps_add:
   "\<lbrakk>nonstop m (bl2wc (<lm>)) stpa = 0\<rbrakk> \<Longrightarrow> 
   conf m (bl2wc (<lm>)) stpa = conf m (bl2wc (<lm>)) (stpa + n)"
   apply(drule_tac nonstop_rgt_ex, auto simp: conf_keep)
   done
 
 lemma halt_state_keep: 
   "\<lbrakk>nonstop m (bl2wc (<lm>)) stpa = 0; nonstop m (bl2wc (<lm>)) stpb = 0\<rbrakk> \<Longrightarrow>
   conf m (bl2wc (<lm>)) stpa = conf m (bl2wc (<lm>)) stpb"
   apply(cases "stpa > stpb")
   using halt_state_keep_steps_add[of m lm stpb "stpa - stpb"] 
    apply simp
   using halt_state_keep_steps_add[of m lm stpa "stpb - stpa"]
   apply(simp)
   done
 
+section \<open>Correctness of rec\_F with respect to execution of TMs compiled as Recursive Functions\<close>
+
 text \<open>
-  The correntess of \<open>rec_F\<close> which relates the interpreter function \<open>rec_F\<close> with the
-  execution of of TMs.
+  The correctness of \<open>rec_F\<close>, which relates the interpreter function \<open>rec_F\<close> with the
+  execution of TMs.
 \<close>
 
 lemma terminate_halt: 
   "\<lbrakk>steps0 (Suc 0, Bk\<up>l, <lm>) tp stp = (0, Bk\<up>m, Oc\<up>rs@Bk\<up>n); 
-    tm_wf (tp,0); 0<rs\<rbrakk> \<Longrightarrow> terminate rec_halt [code tp, (bl2wc (<lm>))]"
+    composable_tm (tp,0); 0<rs\<rbrakk> \<Longrightarrow> terminate rec_halt [code tp, (bl2wc (<lm>))]"
   by(frule_tac halt_least_step;force simp:nonstop_lemma intro:terminate_halt_lemma)
 
 lemma terminate_F: 
   "\<lbrakk>steps0 (Suc 0, Bk\<up>l, <lm>) tp stp = (0, Bk\<up>m, Oc\<up>rs@Bk\<up>n); 
-    tm_wf (tp,0); 0<rs\<rbrakk> \<Longrightarrow> terminate rec_F [code tp, (bl2wc (<lm>))]"
+    composable_tm (tp,0); 0<rs\<rbrakk> \<Longrightarrow> terminate rec_F [code tp, (bl2wc (<lm>))]"
   apply(drule_tac terminate_halt, simp_all)
   apply(erule_tac terminate_F_lemma)
   done
 
 lemma F_correct: 
   "\<lbrakk>steps0 (Suc 0, Bk\<up>l, <lm>) tp stp = (0, Bk\<up>m, Oc\<up>rs@Bk\<up>n); 
-    tm_wf (tp,0); 0<rs\<rbrakk>
+    composable_tm (tp,0); 0<rs\<rbrakk>
    \<Longrightarrow> rec_exec rec_F [code tp, (bl2wc (<lm>))] = (rs - Suc 0)"
   apply(frule_tac halt_least_step, auto)
   apply(frule_tac  nonstop_t_eq, auto simp: nonstop_lemma)
   using rec_t_eq_steps[of tp l lm stp]
   apply(simp add: conf_lemma)
 proof -
   fix stpa
   assume h: 
     "nonstop (code tp) (bl2wc (<lm>)) stpa = 0" 
     "\<forall>stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stpa \<le> stp'" 
     "nonstop (code tp) (bl2wc (<lm>)) stp = 0" 
     "trpl_code (0, Bk\<up> m, Oc\<up> rs @ Bk\<up> n) = conf (code tp) (bl2wc (<lm>)) stp"
     "steps0 (Suc 0, Bk\<up> l, <lm>) tp stp = (0, Bk\<up> m, Oc\<up> rs @ Bk\<up> n)"
   hence g1: "conf (code tp) (bl2wc (<lm>)) stpa = trpl_code (0, Bk\<up> m, Oc\<up> rs @ Bk\<up>n)"
     using halt_state_keep[of "code tp" lm stpa stp]
     by(simp)
   moreover have g2:
     "rec_exec rec_halt [code tp, (bl2wc (<lm>))] = stpa"
     using h
     by(auto simp: rec_exec.simps rec_halt_def nonstop_lemma intro!: Least_equality)
   show  
     "rec_exec rec_F [code tp, (bl2wc (<lm>))] = (rs - Suc 0)"
   proof -
     have 
       "valu (rght (conf (code tp) (bl2wc (<lm>)) stpa)) = rs - Suc 0" 
       using g1 
       apply(simp add: valu.simps trpl_code.simps 
           bl2wc.simps  bl2nat_append lg_power)
       done
     thus "?thesis" 
       by(simp add: rec_exec.simps F_lemma g2)
   qed
 qed
 
-end
\ No newline at end of file
+end
diff --git a/thys/Universal_Turing_Machine/UTM.thy b/thys/Universal_Turing_Machine/UTM.thy
--- a/thys/Universal_Turing_Machine/UTM.thy
+++ b/thys/Universal_Turing_Machine/UTM.thy
@@ -1,4706 +1,4749 @@
 (* Title: thys/UTM.thy
    Author: Jian Xu, Xingyuan Zhang, and Christian Urban
    Modifications: Sebastiaan Joosten
-*)
+   Modifications: Franz Regensburger (FABR) 08/2022
+     - added some auxiliary lemmas
+     - added subsections
+ *)
 
 chapter \<open>Construction of a Universal Turing Machine\<close>
 
 theory UTM
   imports Recursive Abacus UF HOL.GCD Turing_Hoare
 begin
 
+(* Initialize simpset: the following proofs depend on a cleaned up simpset *)
+(*
+declare adjust.simps[simp del]
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+declare fetch.simps[simp del]
+*)
+
 section \<open>Wang coding of input arguments\<close>
 
 text \<open>
   The direct compilation of the universal function \<open>rec_F\<close> can
-  not give us UTM, because \<open>rec_F\<close> is of arity 2, where the
-  first argument represents the Godel coding of the TM being simulated
+  not give us the \<open>utm\<close>, because \<open>rec_F\<close> is of arity 2, where the
+  first argument represents the Gödel coding of the TM being simulated
   and the second argument represents the right number (in Wang's
-  coding) of the TM tape.  (Notice, left number is always \<open>0\<close>
-  at the very beginning). However, UTM needs to simulate the execution
-  of any TM which may very well take many input arguments. Therefore,
-  a initialization TM needs to run before the TM compiled from \<open>rec_F\<close>, and the sequential composition of these two TMs will give
-  rise to the UTM we are seeking. The purpose of this initialization
+  coding) of the TM tape.  (Notice, the left number is always \<open>0\<close>
+  at the very beginning). However, the \<open>utm\<close> needs to simulate the execution
+  of any TM which may take many input arguments.
+
+  Therefore, an initialization TM needs to run before the TM compiled from \<open>rec_F\<close>,
+  and the sequential composition of these two TMs will give
+  rise to the \<open>utm\<close> we are seeking. The purpose of this initialization
   TM is to transform the multiple input arguments of the TM being
   simulated into Wang's coding, so that it can be consumed by the TM
   compiled from \<open>rec_F\<close> as the second argument.
 
-  However, this initialization TM (named \<open>t_wcode\<close>) can not be
+  However, this initialization TM (named \<open>wcode_tm\<close>) can not be
   constructed by compiling from any recursive function, because every
   recursive function takes a fixed number of input arguments, while
-  \<open>t_wcode\<close> needs to take varying number of arguments and
-  tranform them into Wang's coding. Therefore, this section give a
-  direct construction of \<open>t_wcode\<close> with just some parts being
+  \<open>wcode_tm\<close> needs to take varying number of arguments and
+  tranform them into Wang's coding. Therefore, this section gives a
+  direct construction of \<open>wcode_tm\<close> with just some parts being
   obtained from recursive functions.
 
 \newlength{\basewidth}
 \settowidth{\basewidth}{xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx}
 \newlength{\baseheight}
 \settoheight{\baseheight}{$B:R$}
 \newcommand{\vsep}{5\baseheight}
 
 The TM used to generate the Wang's code of input arguments is divided into three TMs
  executed sequentially, namely $prepare$, $mainwork$ and $adjust$.
- According to the
- convention, the start state of ever TM is fixed to state $1$ while the final state is
- fixed to $0$.
+ According to the convention, the start state of ever TM is fixed to state $1$ while
+ the final state is fixed to $0$.
 
 The input and output of $prepare$ are illustrated respectively by Figure
 \ref{prepare_input} and \ref{prepare_output}.
 
 
 \begin{figure}[h!]
 \centering
 \scalebox{1.2}{
 \begin{tikzpicture}
   [tbox/.style = {draw, thick, inner sep = 5pt}]
   \node (0) {};
   \node (1) [tbox, text height = 3.5pt, right = -0.9pt of 0] {$m$};
   \node (2) [tbox, right = -0.9pt of 1] {$0$};
   \node (3) [tbox, right = -0.9pt of 2] {$a_1$};
   \node (4) [tbox, right = -0.9pt of 3] {$0$};
   \node (5) [tbox, right = -0.9pt of 4] {$a_2$};
   \node (6) [right = -0.9pt of 5] {\ldots \ldots};
   \node (7) [tbox, right = -0.9pt of 6] {$a_n$};
   \draw [->, >=latex, thick] (1)+(0, -4\baseheight) -- (1);
 \end{tikzpicture}}
 \caption{The input of TM $prepare$} \label{prepare_input}
 \end{figure}
 
 \begin{figure}[h!]
 \centering
 \scalebox{1.2}{
 \begin{tikzpicture}
   \node (0) {};
   \node (1) [draw, text height = 3.5pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
   \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
   \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
   \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$a_1$};
   \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
   \node (6) [draw, right = -0.9pt of 5, thick, inner sep = 5pt] {$a_2$};
   \node (7) [right = -0.9pt of 6] {\ldots \ldots};
   \node (8) [draw, right = -0.9pt of 7, thick, inner sep = 5pt] {$a_n$};
   \node (9) [draw, right = -0.9pt of 8, thick, inner sep = 5pt] {$0$};
   \node (10) [draw, right = -0.9pt of 9, thick, inner sep = 5pt] {$0$};
   \node (11) [draw, right = -0.9pt of 10, thick, inner sep = 5pt] {$1$};
   \draw [->, >=latex, thick] (10)+(0, -4\baseheight) -- (10);
 \end{tikzpicture}}
 \caption{The output of TM $prepare$} \label{prepare_output}
 \end{figure}
 
 As shown in Figure \ref{prepare_input}, the input of $prepare$ is the
-same as the the input of UTM, where $m$ is the Godel coding of the TM
+same as the the input of \<open>utm\<close>, where $m$ is the Gödel coding of the TM
 being interpreted and $a_1$ through $a_n$ are the $n$ input arguments
 of the TM under interpretation. The purpose of $purpose$ is to
 transform this initial tape layout to the one shown in Figure
 \ref{prepare_output}, which is convenient for the generation of Wang's
-codding of $a_1, \ldots, a_n$. The coding procedure starts from $a_n$
+coding of $a_1, \ldots, a_n$. The coding procedure starts from $a_n$
 and ends after $a_1$ is encoded. The coding result is stored in an
 accumulator at the end of the tape (initially represented by the $1$
 two blanks right to $a_n$ in Figure \ref{prepare_output}). In Figure
 \ref{prepare_output}, arguments $a_1, \ldots, a_n$ are separated by
 two blanks on both ends with the rest so that movement conditions can
 be implemented conveniently in subsequent TMs, because, by convention,
 two consecutive blanks are usually used to signal the end or start of
 a large chunk of data. The diagram of $prepare$ is given in Figure
 \ref{prepare_diag}.
 
 
 \begin{figure}[h!]
 \centering
 \scalebox{0.9}{
 \begin{tikzpicture}
      \node[circle,draw] (1) {$1$};
      \node[circle,draw] (2) at ($(1)+(0.3\basewidth, 0)$) {$2$};
      \node[circle,draw] (3) at ($(2)+(0.3\basewidth, 0)$) {$3$};
      \node[circle,draw] (4) at ($(3)+(0.3\basewidth, 0)$) {$4$};
      \node[circle,draw] (5) at ($(4)+(0.3\basewidth, 0)$) {$5$};
      \node[circle,draw] (6) at ($(5)+(0.3\basewidth, 0)$) {$6$};
      \node[circle,draw] (7) at ($(6)+(0.3\basewidth, 0)$) {$7$};
      \node[circle,draw] (8) at ($(7)+(0.3\basewidth, 0)$) {$0$};
 
 
      \draw [->, >=latex] (1) edge [loop above] node[above] {$S_1:L$} (1)
      ;
      \draw [->, >=latex] (1) -- node[above] {$S_0:S_1$} (2)
      ;
      \draw [->, >=latex] (2) edge [loop above] node[above] {$S_1:R$} (2)
      ;
      \draw [->, >=latex] (2) -- node[above] {$S_0:L$} (3)
      ;
      \draw [->, >=latex] (3) edge[loop above] node[above] {$S_1:S_0$} (3)
      ;
      \draw [->, >=latex] (3) -- node[above] {$S_0:R$} (4)
      ;
      \draw [->, >=latex] (4) edge[loop above] node[above] {$S_0:R$} (4)
      ;
      \draw [->, >=latex] (4) -- node[above] {$S_0:R$} (5)
      ;
      \draw [->, >=latex] (5) edge[loop above] node[above] {$S_1:R$} (5)
      ;
      \draw [->, >=latex] (5) -- node[above] {$S_0:R$} (6)
      ;
      \draw [->, >=latex] (6) edge[bend left = 50] node[below] {$S_1:R$} (5)
      ;
      \draw [->, >=latex] (6) -- node[above] {$S_0:R$} (7)
      ;
      \draw [->, >=latex] (7) edge[loop above] node[above] {$S_0:S_1$} (7)
      ;
      \draw [->, >=latex] (7) -- node[above] {$S_1:L$} (8)
      ;
  \end{tikzpicture}}
 \caption{The diagram of TM $prepare$} \label{prepare_diag}
 \end{figure}
 
-The purpose of TM $mainwork$ is to compute the Wang's encoding of $a_1, \ldots, a_n$. Every bit of $a_1, \ldots, a_n$, including the separating bits, is processed from left to right.
+The purpose of TM $mainwork$ is to compute Wang's encoding of $a_1,
+\ldots, a_n$. Every bit of $a_1, \ldots, a_n$, including the separating bits,
+is processed from left to right.
 In order to detect the termination condition when the left most bit of $a_1$ is reached,
 TM $mainwork$ needs to look ahead and consider three different situations at the start of
 every iteration:
 \begin{enumerate}
-    \item The TM configuration for the first situation is shown in Figure \ref{mainwork_case_one_input},
+    \item The TM configuration for the first situation is shown in Figure
+          \ref{mainwork_case_one_input},
         where the accumulator is stored in $r$, both of the next two bits
         to be encoded are $1$. The configuration at the end of the iteration
         is shown in Figure \ref{mainwork_case_one_output}, where the first 1-bit has been
         encoded and cleared. Notice that the accumulator has been changed to
         $(r+1) \times 2$ to reflect the encoded bit.
     \item The TM configuration for the second situation is shown in Figure
         \ref{mainwork_case_two_input},
         where the accumulator is stored in $r$, the next two bits
         to be encoded are $1$ and $0$. After the first
         $1$-bit was encoded and cleared, the second $0$-bit is difficult to detect
         and process. To solve this problem, these two consecutive bits are
         encoded in one iteration.  In this situation, only the first $1$-bit needs
         to be cleared since the second one is cleared by definition.
         The configuration at the end of the iteration
         is shown in Figure \ref{mainwork_case_two_output}.
         Notice that the accumulator has been changed to
         $(r+1) \times 4$ to reflect the two encoded bits.
     \item The third situation corresponds to the case when the last bit of $a_1$ is reached.
         The TM configurations at the start and end of the iteration are shown in
         Figure \ref{mainwork_case_three_input} and \ref{mainwork_case_three_output}
         respectively. For this situation, only the read write head needs to be moved to
         the left to prepare a initial configuration for TM $adjust$ to start with.
 \end{enumerate}
 The diagram of $mainwork$ is given in Figure \ref{mainwork_diag}. The two rectangular nodes
 labeled with $2 \times x$ and $4 \times x$ are two TMs compiling from recursive functions
 so that we do not have to design and verify two quite complicated TMs.
 
 
 \begin{figure}[h!]
 \centering
 \scalebox{1.2}{
 \begin{tikzpicture}
   \node (0) {};
   \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
   \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
   \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
   \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$a_1$};
   \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
   \node (6) [draw, right = -0.9pt of 5, thick, inner sep = 5pt] {$a_2$};
   \node (7) [right = -0.9pt of 6] {\ldots \ldots};
   \node (8) [draw, right = -0.9pt of 7, thick, inner sep = 5pt] {$a_i$};
   \node (9) [draw, right = -0.9pt of 8, thick, inner sep = 5pt] {$1$};
   \node (10) [draw, right = -0.9pt of 9, thick, inner sep = 5pt] {$1$};
   \node (11) [draw, right = -0.9pt of 10, thick, inner sep = 5pt] {$0$};
   \node (12) [right = -0.9pt of 11] {\ldots \ldots};
   \node (13) [draw, right = -0.9pt of 12, thick, inner sep = 5pt] {$0$};
   \node (14) [draw, text height = 3.9pt, right = -0.9pt of 13, thick, inner sep = 5pt] {$r$};
   \draw [->, >=latex, thick] (13)+(0, -4\baseheight) -- (13);
 \end{tikzpicture}}
 \caption{The first situation for TM $mainwork$ to consider} \label{mainwork_case_one_input}
 \end{figure}
 
 
 \begin{figure}[h!]
 \centering
 \scalebox{1.2}{
 \begin{tikzpicture}
   \node (0) {};
   \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
   \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
   \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
   \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$a_1$};
   \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
   \node (6) [draw, right = -0.9pt of 5, thick, inner sep = 5pt] {$a_2$};
   \node (7) [right = -0.9pt of 6] {\ldots \ldots};
   \node (8) [draw, right = -0.9pt of 7, thick, inner sep = 5pt] {$a_i$};
   \node (9) [draw, right = -0.9pt of 8, thick, inner sep = 5pt] {$1$};
   \node (10) [draw, right = -0.9pt of 9, thick, inner sep = 5pt] {$0$};
   \node (11) [draw, right = -0.9pt of 10, thick, inner sep = 5pt] {$0$};
   \node (12) [right = -0.9pt of 11] {\ldots \ldots};
   \node (13) [draw, right = -0.9pt of 12, thick, inner sep = 5pt] {$0$};
   \node (14) [draw, text height = 2.7pt, right = -0.9pt of 13, thick, inner sep = 5pt] {$(r+1) \times 2$};
   \draw [->, >=latex, thick] (13)+(0, -4\baseheight) -- (13);
 \end{tikzpicture}}
 \caption{The output for the first case of TM $mainwork$'s processing}
 \label{mainwork_case_one_output}
 \end{figure}
 
 \begin{figure}[h!]
 \centering
 \scalebox{1.2}{
 \begin{tikzpicture}
   \node (0) {};
   \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
   \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
   \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
   \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$a_1$};
   \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
   \node (6) [draw, right = -0.9pt of 5, thick, inner sep = 5pt] {$a_2$};
   \node (7) [right = -0.9pt of 6] {\ldots \ldots};
   \node (8) [draw, right = -0.9pt of 7, thick, inner sep = 5pt] {$a_i$};
   \node (9) [draw, right = -0.9pt of 8, thick, inner sep = 5pt] {$1$};
   \node (10) [draw, right = -0.9pt of 9, thick, inner sep = 5pt] {$0$};
   \node (11) [draw, right = -0.9pt of 10, thick, inner sep = 5pt] {$1$};
   \node (12) [draw, right = -0.9pt of 11, thick, inner sep = 5pt] {$0$};
   \node (13) [right = -0.9pt of 12] {\ldots \ldots};
   \node (14) [draw, right = -0.9pt of 13, thick, inner sep = 5pt] {$0$};
   \node (15) [draw, text height = 3.9pt, right = -0.9pt of 14, thick, inner sep = 5pt] {$r$};
   \draw [->, >=latex, thick] (14)+(0, -4\baseheight) -- (14);
 \end{tikzpicture}}
 \caption{The second situation for TM $mainwork$ to consider} \label{mainwork_case_two_input}
 \end{figure}
 
 \begin{figure}[h!]
 \centering
 \scalebox{1.2}{
 \begin{tikzpicture}
   \node (0) {};
   \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
   \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
   \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
   \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$a_1$};
   \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
   \node (6) [draw, right = -0.9pt of 5, thick, inner sep = 5pt] {$a_2$};
   \node (7) [right = -0.9pt of 6] {\ldots \ldots};
   \node (8) [draw, right = -0.9pt of 7, thick, inner sep = 5pt] {$a_i$};
   \node (9) [draw, right = -0.9pt of 8, thick, inner sep = 5pt] {$1$};
   \node (10) [draw, right = -0.9pt of 9, thick, inner sep = 5pt] {$0$};
   \node (11) [draw, right = -0.9pt of 10, thick, inner sep = 5pt] {$0$};
   \node (12) [draw, right = -0.9pt of 11, thick, inner sep = 5pt] {$0$};
   \node (13) [right = -0.9pt of 12] {\ldots \ldots};
   \node (14) [draw, right = -0.9pt of 13, thick, inner sep = 5pt] {$0$};
   \node (15) [draw, text height = 2.7pt, right = -0.9pt of 14, thick, inner sep = 5pt] {$(r+1) \times 4$};
   \draw [->, >=latex, thick] (14)+(0, -4\baseheight) -- (14);
 \end{tikzpicture}}
 \caption{The output for the second case of TM $mainwork$'s processing}
 \label{mainwork_case_two_output}
 \end{figure}
 
 \begin{figure}[h!]
 \centering
 \scalebox{1.2}{
 \begin{tikzpicture}
   \node (0) {};
   \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
   \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
   \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
   \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$1$};
   \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
   \node (6) [right = -0.9pt of 5] {\ldots \ldots};
   \node (7) [draw, right = -0.9pt of 6, thick, inner sep = 5pt] {$0$};
   \node (8) [draw, text height = 3.9pt, right = -0.9pt of 7, thick, inner sep = 5pt] {$r$};
   \draw [->, >=latex, thick] (7)+(0, -4\baseheight) -- (7);
 \end{tikzpicture}}
 \caption{The third situation for TM $mainwork$ to consider} \label{mainwork_case_three_input}
 \end{figure}
 
 \begin{figure}[h!]
 \centering
 \scalebox{1.2}{
 \begin{tikzpicture}
   \node (0) {};
   \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
   \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
   \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
   \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$1$};
   \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
   \node (6) [right = -0.9pt of 5] {\ldots \ldots};
   \node (7) [draw, right = -0.9pt of 6, thick, inner sep = 5pt] {$0$};
   \node (8) [draw, text height = 3.9pt, right = -0.9pt of 7, thick, inner sep = 5pt] {$r$};
   \draw [->, >=latex, thick] (3)+(0, -4\baseheight) -- (3);
 \end{tikzpicture}}
 \caption{The output for the third case of TM $mainwork$'s processing}
 \label{mainwork_case_three_output}
 \end{figure}
 
 \begin{figure}[h!]
 \centering
 \scalebox{0.9}{
 \begin{tikzpicture}
      \node[circle,draw] (1) {$1$};
      \node[circle,draw] (2) at ($(1)+(0.3\basewidth, 0)$) {$2$};
      \node[circle,draw] (3) at ($(2)+(0.3\basewidth, 0)$) {$3$};
      \node[circle,draw] (4) at ($(3)+(0.3\basewidth, 0)$) {$4$};
      \node[circle,draw] (5) at ($(4)+(0.3\basewidth, 0)$) {$5$};
      \node[circle,draw] (6) at ($(5)+(0.3\basewidth, 0)$) {$6$};
      \node[circle,draw] (7) at ($(2)+(0, -7\baseheight)$) {$7$};
      \node[circle,draw] (8) at ($(7)+(0, -7\baseheight)$) {$8$};
      \node[circle,draw] (9) at ($(8)+(0.3\basewidth, 0)$) {$9$};
      \node[circle,draw] (10) at ($(9)+(0.3\basewidth, 0)$) {$10$};
      \node[circle,draw] (11) at ($(10)+(0.3\basewidth, 0)$) {$11$};
      \node[circle,draw] (12) at ($(11)+(0.3\basewidth, 0)$) {$12$};
      \node[draw] (13) at ($(6)+(0.3\basewidth, 0)$) {$2 \times x$};
      \node[circle,draw] (14) at ($(13)+(0.3\basewidth, 0)$) {$j_1$};
      \node[draw] (15) at ($(12)+(0.3\basewidth, 0)$) {$4 \times x$};
      \node[draw] (16) at ($(15)+(0.3\basewidth, 0)$) {$j_2$};
      \node[draw] (17) at ($(7)+(0.3\basewidth, 0)$) {$0$};
 
      \draw [->, >=latex] (1) edge[loop left] node[above] {$S_0:L$} (1)
      ;
      \draw [->, >=latex] (1) -- node[above] {$S_1:L$} (2)
      ;
      \draw [->, >=latex] (2) -- node[above] {$S_1:R$} (3)
      ;
      \draw [->, >=latex] (2) -- node[left] {$S_1:L$} (7)
      ;
      \draw [->, >=latex] (3) edge[loop above] node[above] {$S_1:S_0$} (3)
      ;
      \draw [->, >=latex] (3) -- node[above] {$S_0:R$} (4)
      ;
      \draw [->, >=latex] (4) edge[loop above] node[above] {$S_0:R$} (4)
      ;
      \draw [->, >=latex] (4) -- node[above] {$S_1:R$} (5)
      ;
      \draw [->, >=latex] (5) edge[loop above] node[above] {$S_1:R$} (5)
      ;
      \draw [->, >=latex] (5) -- node[above] {$S_0:S_1$} (6)
      ;
      \draw [->, >=latex] (6) edge[loop above] node[above] {$S_1:L$} (6)
      ;
      \draw [->, >=latex] (6) -- node[above] {$S_0:R$} (13)
      ;
      \draw [->, >=latex] (13) -- (14)
      ;
      \draw (14) -- ($(14)+(0, 6\baseheight)$) -- ($(1) + (0, 6\baseheight)$) node [above,midway] {$S_1:L$}
      ;
      \draw [->, >=latex] ($(1) + (0, 6\baseheight)$) -- (1)
      ;
      \draw [->, >=latex] (7) -- node[above] {$S_0:R$} (17)
      ;
      \draw [->, >=latex] (7) -- node[left] {$S_1:R$} (8)
      ;
      \draw [->, >=latex] (8) -- node[above] {$S_0:R$} (9)
      ;
      \draw [->, >=latex] (9) -- node[above] {$S_0:R$} (10)
      ;
      \draw [->, >=latex] (10) -- node[above] {$S_1:R$} (11)
      ;
      \draw [->, >=latex] (10) edge[loop above] node[above] {$S_0:R$} (10)
      ;
      \draw [->, >=latex] (11) edge[loop above] node[above] {$S_1:R$} (11)
      ;
      \draw [->, >=latex] (11) -- node[above] {$S_0:S_1$} (12)
      ;
      \draw [->, >=latex] (12) -- node[above] {$S_0:R$} (15)
      ;
      \draw [->, >=latex] (12) edge[loop above] node[above] {$S_1:L$} (12)
      ;
      \draw [->, >=latex] (15) -- (16)
      ;
      \draw (16) -- ($(16)+(0, -4\baseheight)$) -- ($(1) + (0, -18\baseheight)$) node [below,midway] {$S_1:L$}
      ;
      \draw [->, >=latex] ($(1) + (0, -18\baseheight)$) -- (1)
      ;
  \end{tikzpicture}}
 \caption{The diagram of TM $mainwork$} \label{mainwork_diag}
 \end{figure}
 
 The purpose of TM $adjust$ is to encode the last bit of $a_1$. The initial and final configuration
 of this TM are shown in Figure \ref{adjust_initial} and \ref{adjust_final} respectively.
 The diagram of TM $adjust$ is shown in Figure \ref{adjust_diag}.
 
 
 \begin{figure}[h!]
 \centering
 \scalebox{1.2}{
 \begin{tikzpicture}
   \node (0) {};
   \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
   \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
   \node (3) [draw, right = -0.9pt of 2, thick, inner sep = 5pt] {$0$};
   \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$1$};
   \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
   \node (6) [right = -0.9pt of 5] {\ldots \ldots};
   \node (7) [draw, right = -0.9pt of 6, thick, inner sep = 5pt] {$0$};
   \node (8) [draw, text height = 3.9pt, right = -0.9pt of 7, thick, inner sep = 5pt] {$r$};
   \draw [->, >=latex, thick] (3)+(0, -4\baseheight) -- (3);
 \end{tikzpicture}}
 \caption{Initial configuration of TM $adjust$} \label{adjust_initial}
 \end{figure}
 
 \begin{figure}[h!]
 \centering
 \scalebox{1.2}{
 \begin{tikzpicture}
   \node (0) {};
   \node (1) [draw, text height = 3.9pt, right = -0.9pt of 0, thick, inner sep = 5pt] {$m$};
   \node (2) [draw, right = -0.9pt of 1, thick, inner sep = 5pt] {$0$};
   \node (3) [draw, text height = 2.9pt, right = -0.9pt of 2, thick, inner sep = 5pt] {$r+1$};
   \node (4) [draw, right = -0.9pt of 3, thick, inner sep = 5pt] {$0$};
   \node (5) [draw, right = -0.9pt of 4, thick, inner sep = 5pt] {$0$};
   \node (6) [right = -0.9pt of 5] {\ldots \ldots};
   \draw [->, >=latex, thick] (1)+(0, -4\baseheight) -- (1);
 \end{tikzpicture}}
 \caption{Final configuration of TM $adjust$} \label{adjust_final}
 \end{figure}
 
 
 \begin{figure}[h!]
 \centering
 \scalebox{0.9}{
 \begin{tikzpicture}
      \node[circle,draw] (1) {$1$};
      \node[circle,draw] (2) at ($(1)+(0.3\basewidth, 0)$) {$2$};
      \node[circle,draw] (3) at ($(2)+(0.3\basewidth, 0)$) {$3$};
      \node[circle,draw] (4) at ($(3)+(0.3\basewidth, 0)$) {$4$};
      \node[circle,draw] (5) at ($(4)+(0.3\basewidth, 0)$) {$5$};
      \node[circle,draw] (6) at ($(5)+(0.3\basewidth, 0)$) {$6$};
      \node[circle,draw] (7) at ($(6)+(0.3\basewidth, 0)$) {$7$};
      \node[circle,draw] (8) at ($(4)+(0, -7\baseheight)$) {$8$};
      \node[circle,draw] (9) at ($(8)+(0.3\basewidth, 0)$) {$9$};
      \node[circle,draw] (10) at ($(9)+(0.3\basewidth, 0)$) {$10$};
      \node[circle,draw] (11) at ($(10)+(0.3\basewidth, 0)$) {$11$};
      \node[circle,draw] (12) at ($(11)+(0.3\basewidth, 0)$) {$0$};
 
 
      \draw [->, >=latex] (1) -- node[above] {$S_1:R$} (2)
      ;
      \draw [->, >=latex] (1) edge[loop above] node[above] {$S_0:S_1$} (1)
      ;
      \draw [->, >=latex] (2) -- node[above] {$S_1:R$} (3)
      ;
      \draw [->, >=latex] (3) edge[loop above] node[above] {$S_0:R$} (3)
      ;
      \draw [->, >=latex] (3) -- node[above] {$S_1:R$} (4)
      ;
      \draw [->, >=latex] (4) -- node[above] {$S_1:L$} (5)
      ;
      \draw [->, >=latex] (4) -- node[right] {$S_0:L$} (8)
      ;
      \draw [->, >=latex] (5) -- node[above] {$S_0:L$} (6)
      ;
      \draw [->, >=latex] (5) edge[loop above] node[above] {$S_1:S_0$} (5)
      ;
      \draw [->, >=latex] (6) -- node[above] {$S_1:R$} (7)
      ;
      \draw [->, >=latex] (6) edge[loop above] node[above] {$S_0:L$} (6)
      ;
      \draw (7) -- ($(7)+(0, 6\baseheight)$) -- ($(2) + (0, 6\baseheight)$) node [above,midway] {$S_0:S_1$}
      ;
      \draw [->, >=latex] ($(2) + (0, 6\baseheight)$) -- (2)
      ;
      \draw [->, >=latex] (8) edge[loop left] node[left] {$S_1:S_0$} (8)
      ;
      \draw [->, >=latex] (8) -- node[above] {$S_0:L$} (9)
      ;
      \draw [->, >=latex] (9) edge[loop above] node[above] {$S_0:L$} (9)
      ;
      \draw [->, >=latex] (9) -- node[above] {$S_1:L$} (10)
      ;
      \draw [->, >=latex] (10) edge[loop above] node[above] {$S_0:L$} (10)
      ;
      \draw [->, >=latex] (10) -- node[above] {$S_0:L$} (11)
      ;
      \draw [->, >=latex] (11) edge[loop above] node[above] {$S_1:L$} (11)
      ;
      \draw [->, >=latex] (11) -- node[above] {$S_0:R$} (12)
      ;
  \end{tikzpicture}}
 \caption{Diagram of TM $adjust$} \label{adjust_diag}
 \end{figure}
 \<close>
 
 
 definition rec_twice :: "recf"
   where
     "rec_twice = Cn 1 rec_mult [id 1 0, constn 2]"
 
 definition rec_fourtimes  :: "recf"
   where
     "rec_fourtimes = Cn 1 rec_mult [id 1 0, constn 4]"
 
 definition abc_twice :: "abc_prog"
   where
     "abc_twice = (let (aprog, ary, fp) = rec_ci rec_twice in 
                        aprog [+] dummy_abc ((Suc 0)))"
 
 definition abc_fourtimes :: "abc_prog"
   where
     "abc_fourtimes = (let (aprog, ary, fp) = rec_ci rec_fourtimes in 
                        aprog [+] dummy_abc ((Suc 0)))"
 
 definition twice_ly :: "nat list"
   where
     "twice_ly = layout_of abc_twice"
 
 definition fourtimes_ly :: "nat list"
   where
     "fourtimes_ly = layout_of abc_fourtimes"
 
-definition t_twice_compile :: "instr list"
-  where
-    "t_twice_compile= (tm_of abc_twice @ (shift (mopup 1) (length (tm_of abc_twice) div 2)))"
-
-definition t_twice :: "instr list"
-  where
-    "t_twice = adjust0 t_twice_compile"
-
-definition t_fourtimes_compile :: "instr list"
-  where
-    "t_fourtimes_compile= (tm_of abc_fourtimes @ (shift (mopup 1) (length (tm_of abc_fourtimes) div 2)))"
-
-definition t_fourtimes :: "instr list"
+definition twice_compile_tm :: "instr list"
   where
-    "t_fourtimes = adjust0 t_fourtimes_compile"
-
-definition t_twice_len :: "nat"
+    "twice_compile_tm= (tm_of abc_twice @ (shift (mopup_n_tm 1) (length (tm_of abc_twice) div 2)))"
+
+definition twice_tm :: "instr list"
   where
-    "t_twice_len = length t_twice div 2"
-
-definition t_wcode_main_first_part:: "instr list"
+    "twice_tm = adjust0 twice_compile_tm"
+
+definition fourtimes_compile_tm :: "instr list"
   where
-    "t_wcode_main_first_part \<equiv> 
+    "fourtimes_compile_tm= (tm_of abc_fourtimes @ (shift (mopup_n_tm 1) (length (tm_of abc_fourtimes) div 2)))"
+
+definition fourtimes_tm :: "instr list"
+  where
+    "fourtimes_tm = adjust0 fourtimes_compile_tm"
+
+definition twice_tm_len :: "nat"
+  where
+    "twice_tm_len = length twice_tm div 2"
+
+definition wcode_main_first_part_tm:: "instr list"
+  where
+    "wcode_main_first_part_tm \<equiv> 
                    [(L, 1), (L, 2), (L, 7), (R, 3),
-                    (R, 4), (W0, 3), (R, 4), (R, 5),
-                    (W1, 6), (R, 5), (R, 13), (L, 6),
+                    (R, 4), (WB, 3), (R, 4), (R, 5),
+                    (WO, 6), (R, 5), (R, 13), (L, 6),
                     (R, 0), (R, 8), (R, 9), (Nop, 8),
-                    (R, 10), (W0, 9), (R, 10), (R, 11), 
-                    (W1, 12), (R, 11), (R, t_twice_len + 14), (L, 12)]"
-
-definition t_wcode_main :: "instr list"
+                    (R, 10), (WB, 9), (R, 10), (R, 11), 
+                    (WO, 12), (R, 11), (R, twice_tm_len + 14), (L, 12)]"
+
+definition wcode_main_tm :: "instr list"
   where
-    "t_wcode_main = (t_wcode_main_first_part @ shift t_twice 12 @ [(L, 1), (L, 1)]
-                    @ shift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)])"
+    "wcode_main_tm = (wcode_main_first_part_tm @ shift twice_tm 12 @ [(L, 1), (L, 1)]
+                    @ shift fourtimes_tm (twice_tm_len + 13) @ [(L, 1), (L, 1)])"
 
 fun bl_bin :: "cell list \<Rightarrow> nat"
   where
     "bl_bin [] = 0" 
   | "bl_bin (Bk # xs) = 2 * bl_bin xs"
   | "bl_bin (Oc # xs) = Suc (2 * bl_bin xs)"
 
 declare bl_bin.simps[simp del]
 
 type_synonym bin_inv_t = "cell list \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
 
 fun wcode_before_double :: "bin_inv_t"
   where
     "wcode_before_double ires rs (l, r) =
      (\<exists> ln rn. l = Bk # Bk # Bk\<up>(ln) @ Oc # ires \<and> 
                r = Oc\<up>((Suc (Suc rs))) @ Bk\<up>(rn ))"
 
 declare wcode_before_double.simps[simp del]
 
 fun wcode_after_double :: "bin_inv_t"
   where
     "wcode_after_double ires rs (l, r) = 
      (\<exists> ln rn. l = Bk # Bk # Bk\<up>(ln) @ Oc # ires \<and>
          r = Oc\<up>(Suc (Suc (Suc 2*rs))) @ Bk\<up>(rn))"
 
 declare wcode_after_double.simps[simp del]
 
 fun wcode_on_left_moving_1_B :: "bin_inv_t"
   where
     "wcode_on_left_moving_1_B ires rs (l, r) = 
      (\<exists> ml mr rn. l = Bk\<up>(ml) @ Oc # Oc # ires \<and> 
                r = Bk\<up>(mr) @ Oc\<up>(Suc rs) @ Bk\<up>(rn) \<and>
                ml + mr > Suc 0 \<and> mr > 0)"
 
 declare wcode_on_left_moving_1_B.simps[simp del]
 
 fun wcode_on_left_moving_1_O :: "bin_inv_t"
   where
     "wcode_on_left_moving_1_O ires rs (l, r) = 
      (\<exists> ln rn.
                l = Oc # ires \<and> 
                r = Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 declare wcode_on_left_moving_1_O.simps[simp del]
 
 fun wcode_on_left_moving_1 :: "bin_inv_t"
   where
     "wcode_on_left_moving_1 ires rs (l, r) = 
           (wcode_on_left_moving_1_B ires rs (l, r) \<or> wcode_on_left_moving_1_O ires rs (l, r))"
 
 declare wcode_on_left_moving_1.simps[simp del]
 
 fun wcode_on_checking_1 :: "bin_inv_t"
   where
     "wcode_on_checking_1 ires rs (l, r) = 
     (\<exists> ln rn. l = ires \<and>
               r = Oc # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wcode_erase1 :: "bin_inv_t"
   where
     "wcode_erase1 ires rs (l, r) = 
        (\<exists> ln rn. l = Oc # ires \<and> 
                  tl r = Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 declare wcode_erase1.simps [simp del]
 
 fun wcode_on_right_moving_1 :: "bin_inv_t"
   where
     "wcode_on_right_moving_1 ires rs (l, r) = 
        (\<exists> ml mr rn.        
              l = Bk\<up>(ml) @ Oc # ires \<and> 
              r = Bk\<up>(mr) @ Oc\<up>(Suc rs) @ Bk\<up>(rn) \<and>
              ml + mr > Suc 0)"
 
 declare wcode_on_right_moving_1.simps [simp del] 
-
+(*
 declare wcode_on_right_moving_1.simps[simp del]
-
+*)
 fun wcode_goon_right_moving_1 :: "bin_inv_t"
   where
     "wcode_goon_right_moving_1 ires rs (l, r) = 
       (\<exists> ml mr ln rn. 
             l = Oc\<up>(ml) @ Bk # Bk # Bk\<up>(ln) @ Oc # ires \<and> 
             r = Oc\<up>(mr) @ Bk\<up>(rn) \<and>
             ml + mr = Suc rs)"
 
 declare wcode_goon_right_moving_1.simps[simp del]
 
 fun wcode_backto_standard_pos_B :: "bin_inv_t"
   where
     "wcode_backto_standard_pos_B ires rs (l, r) = 
           (\<exists> ln rn. l =  Bk # Bk\<up>(ln) @ Oc # ires \<and> 
                r =  Bk # Oc\<up>((Suc (Suc rs))) @ Bk\<up>(rn ))"
 
 declare wcode_backto_standard_pos_B.simps[simp del]
 
 fun wcode_backto_standard_pos_O :: "bin_inv_t"
   where
     "wcode_backto_standard_pos_O ires rs (l, r) = 
         (\<exists> ml mr ln rn. 
             l = Oc\<up>(ml) @ Bk # Bk # Bk\<up>(ln) @ Oc # ires \<and>
             r = Oc\<up>(mr) @ Bk\<up>(rn) \<and>
             ml + mr = Suc (Suc rs) \<and> mr > 0)"
 
 declare wcode_backto_standard_pos_O.simps[simp del]
 
 fun wcode_backto_standard_pos :: "bin_inv_t"
   where
     "wcode_backto_standard_pos ires rs (l, r) = (wcode_backto_standard_pos_B ires rs (l, r) \<or>
                                             wcode_backto_standard_pos_O ires rs (l, r))"
 
 declare wcode_backto_standard_pos.simps[simp del]
 
 lemma bin_wc_eq: "bl_bin xs = bl2wc xs"
 proof(induct xs)
   show " bl_bin [] = bl2wc []" 
     apply(simp add: bl_bin.simps)
     done
 next
   fix a xs
   assume "bl_bin xs = bl2wc xs"
   thus " bl_bin (a # xs) = bl2wc (a # xs)"
     apply(case_tac a, simp_all add: bl_bin.simps bl2wc.simps)
      apply(simp_all add: bl2nat.simps bl2nat_double)
     done
 qed
 
 lemma tape_of_nl_append_one: "lm \<noteq> [] \<Longrightarrow>  <lm @ [a]> = <lm> @ Bk # Oc\<up>Suc a"
   apply(induct lm, auto simp: tape_of_nl_cons split:if_splits)
   done
 
 lemma tape_of_nl_rev: "rev (<lm::nat list>) = (<rev lm>)"
   apply(induct lm, simp, auto)
   apply(auto simp: tape_of_nl_cons tape_of_nl_append_one split: if_splits)
   apply(simp add: exp_ind[THEN sym])
   done
 
 lemma exp_1[simp]: "a\<up>(Suc 0) = [a]" 
   by(simp)
 
 lemma tape_of_nl_cons_app1: "(<a # xs @ [b]>) = (Oc\<up>(Suc a) @ Bk # (<xs@ [b]>))"
-  apply(case_tac xs; simp add: tape_of_list_def tape_of_nat_list.simps tape_of_nat_def)
+  apply(case_tac xs; simp add: tape_of_list_def  tape_of_nat_def)
   done
 
 lemma bl_bin_bk_oc[simp]:
   "bl_bin (xs @ [Bk, Oc]) = 
   bl_bin xs + 2*2^(length xs)"
   apply(simp add: bin_wc_eq)
   using bl2nat_cons_oc[of "xs @ [Bk]"]
   apply(simp add: bl2nat_cons_bk bl2wc.simps)
   done
 
 lemma tape_of_nat[simp]: "(<a::nat>) = Oc\<up>(Suc a)"
   apply(simp add: tape_of_nat_def)
   done
 
 lemma tape_of_nl_cons_app2: "(<c # xs @ [b]>) = (<c # xs> @ Bk # Oc\<up>(Suc b))"
 proof(induct "length xs" arbitrary: xs c, simp add: tape_of_list_def)
   fix x xs c
   assume ind: "\<And>xs c. x = length xs \<Longrightarrow> <c # xs @ [b]> = 
     <c # xs> @ Bk # Oc\<up>(Suc b)"
     and h: "Suc x = length (xs::nat list)" 
   show "<c # xs @ [b]> = <c # xs> @ Bk # Oc\<up>(Suc b)"
   proof(cases xs, simp add: tape_of_list_def)
     fix a list
     assume g: "xs = a # list"
     hence k: "<a # list @ [b]> =  <a # list> @ Bk # Oc\<up>(Suc b)"
       apply(rule_tac ind)
       using h
       apply(simp)
       done
     from g and k show "<c # xs @ [b]> = <c # xs> @ Bk # Oc\<up>(Suc b)"
       apply(simp add: tape_of_list_def)
       done
   qed
 qed
 
 lemma length_2_elems[simp]: "length (<aa # a # list>) = Suc (Suc aa) + length (<a # list>)"
   apply(simp add: tape_of_list_def)
   done
 
 lemma bl_bin_addition[simp]: "bl_bin (Oc\<up>(Suc aa) @ Bk # tape_of_nat_list (a # lista) @ [Bk, Oc]) =
               bl_bin (Oc\<up>(Suc aa) @ Bk # tape_of_nat_list (a # lista)) + 
               2* 2^(length (Oc\<up>(Suc aa) @ Bk # tape_of_nat_list (a # lista)))"
   using bl_bin_bk_oc[of "Oc\<up>(Suc aa) @ Bk # tape_of_nat_list (a # lista)"]
   apply(simp)
   done
 
 declare replicate_Suc[simp del]
 
 lemma bl_bin_2[simp]: 
   "bl_bin (<aa # list>) + (4 * rs + 4) * 2 ^ (length (<aa # list>) - Suc 0)
   = bl_bin (Oc\<up>(Suc aa) @ Bk # <list @ [0]>) + rs * (2 * 2 ^ (aa + length (<list @ [0]>)))"
   apply(case_tac "list", simp add: add_mult_distrib)
   apply(simp add: tape_of_nl_cons_app2 add_mult_distrib)
   apply(simp add: tape_of_list_def)
   done
 
 lemma tape_of_nl_app_Suc: "((<list @ [Suc ab]>)) = (<list @ [ab]>) @ [Oc]"
 proof(induct list)
   case (Cons a list)
   then show ?case by(cases list;simp_all add:tape_of_list_def exp_ind)
 qed (simp add: tape_of_list_def exp_ind)
 
 lemma bl_bin_3[simp]: "bl_bin (Oc # Oc\<up>(aa) @ Bk # <list @ [ab]> @ [Oc])
               = bl_bin (Oc # Oc\<up>(aa) @ Bk # <list @ [ab]>) +
               2^(length (Oc # Oc\<up>(aa) @ Bk # <list @ [ab]>))"
   apply(simp add: bin_wc_eq)
   apply(simp add: bl2nat_cons_oc bl2wc.simps)
   using bl2nat_cons_oc[of "Oc # Oc\<up>(aa) @ Bk # <list @ [ab]>"]
   apply(simp)
   done
 lemma bl_bin_4[simp]: "bl_bin (Oc # Oc\<up>(aa) @ Bk # <list @ [ab]>) + (4 * 2 ^ (aa + length (<list @ [ab]>)) +
          4 * (rs * 2 ^ (aa + length (<list @ [ab]>)))) =
        bl_bin (Oc # Oc\<up>(aa) @ Bk # <list @ [Suc ab]>) +
          rs * (2 * 2 ^ (aa + length (<list @ [Suc ab]>)))"
   apply(simp add: tape_of_nl_app_Suc)
   done
 
 declare tape_of_nat[simp del]
 
 fun wcode_double_case_inv :: "nat \<Rightarrow> bin_inv_t"
   where
     "wcode_double_case_inv st ires rs (l, r) = 
           (if st = Suc 0 then wcode_on_left_moving_1 ires rs (l, r)
           else if st = Suc (Suc 0) then wcode_on_checking_1 ires rs (l, r)
           else if st = 3 then wcode_erase1 ires rs (l, r)
           else if st = 4 then wcode_on_right_moving_1 ires rs (l, r)
           else if st = 5 then wcode_goon_right_moving_1 ires rs (l, r)
           else if st = 6 then wcode_backto_standard_pos ires rs (l, r)
           else if st = 13 then wcode_before_double ires rs (l, r)
           else False)"
 
 declare wcode_double_case_inv.simps[simp del]
 
 fun wcode_double_case_state :: "config \<Rightarrow> nat"
   where
     "wcode_double_case_state (st, l, r) = 
    13 - st"
 
 fun wcode_double_case_step :: "config \<Rightarrow> nat"
   where
     "wcode_double_case_step (st, l, r) = 
       (if st = Suc 0 then (length l)
       else if st = Suc (Suc 0) then (length r)
       else if st = 3 then 
                  if hd r = Oc then 1 else 0
       else if st = 4 then (length r)
       else if st = 5 then (length r)
       else if st = 6 then (length l)
       else 0)"
 
 fun wcode_double_case_measure :: "config \<Rightarrow> nat \<times> nat"
   where
     "wcode_double_case_measure (st, l, r) = 
      (wcode_double_case_state (st, l, r), 
       wcode_double_case_step (st, l, r))"
 
 definition wcode_double_case_le :: "(config \<times> config) set"
   where "wcode_double_case_le \<equiv> (inv_image lex_pair wcode_double_case_measure)"
 
 lemma wf_lex_pair[intro]: "wf lex_pair"
-  by(auto intro:wf_lex_prod simp:lex_pair_def)
+  by(auto  simp:lex_pair_def)
 
 lemma wf_wcode_double_case_le[intro]: "wf wcode_double_case_le"
-  by(auto intro:wf_inv_image simp: wcode_double_case_le_def )
-
-lemma fetch_t_wcode_main[simp]:
-  "fetch t_wcode_main (Suc 0) Bk = (L, Suc 0)"
-  "fetch t_wcode_main (Suc 0) Oc = (L, Suc (Suc 0))"
-  "fetch t_wcode_main (Suc (Suc 0)) Oc = (R, 3)"
-  "fetch t_wcode_main (Suc (Suc 0)) Bk = (L, 7)"
-  "fetch t_wcode_main (Suc (Suc (Suc 0))) Bk = (R, 4)"
-  "fetch t_wcode_main (Suc (Suc (Suc 0))) Oc = (W0, 3)"
-  "fetch t_wcode_main 4 Bk = (R, 4)"
-  "fetch t_wcode_main 4 Oc = (R, 5)"
-  "fetch t_wcode_main 5 Oc = (R, 5)"
-  "fetch t_wcode_main 5 Bk = (W1, 6)"
-  "fetch t_wcode_main 6 Bk = (R, 13)"
-  "fetch t_wcode_main 6 Oc = (L, 6)"
-  "fetch t_wcode_main 7 Oc = (R, 8)"
-  "fetch t_wcode_main 7 Bk = (R, 0)"
-  "fetch t_wcode_main 8 Bk = (R, 9)"
-  "fetch t_wcode_main 9 Bk = (R, 10)"
-  "fetch t_wcode_main 9 Oc = (W0, 9)"
-  "fetch t_wcode_main 10 Bk = (R, 10)"
-  "fetch t_wcode_main 10 Oc = (R, 11)"
-  "fetch t_wcode_main 11 Bk = (W1, 12)"
-  "fetch t_wcode_main 11 Oc = (R, 11)"
-  "fetch t_wcode_main 12 Oc = (L, 12)"
-  "fetch t_wcode_main 12 Bk = (R, t_twice_len + 14)"
-  by(auto simp: t_wcode_main_def t_wcode_main_first_part_def fetch.simps numeral)
+  by(auto  simp: wcode_double_case_le_def )
+
+lemma fetch_wcode_main_tm[simp]:
+  "fetch wcode_main_tm (Suc 0) Bk = (L, Suc 0)"
+  "fetch wcode_main_tm (Suc 0) Oc = (L, Suc (Suc 0))"
+  "fetch wcode_main_tm (Suc (Suc 0)) Oc = (R, 3)"
+  "fetch wcode_main_tm (Suc (Suc 0)) Bk = (L, 7)"
+  "fetch wcode_main_tm (Suc (Suc (Suc 0))) Bk = (R, 4)"
+  "fetch wcode_main_tm (Suc (Suc (Suc 0))) Oc = (WB, 3)"
+  "fetch wcode_main_tm 4 Bk = (R, 4)"
+  "fetch wcode_main_tm 4 Oc = (R, 5)"
+  "fetch wcode_main_tm 5 Oc = (R, 5)"
+  "fetch wcode_main_tm 5 Bk = (WO, 6)"
+  "fetch wcode_main_tm 6 Bk = (R, 13)"
+  "fetch wcode_main_tm 6 Oc = (L, 6)"
+  "fetch wcode_main_tm 7 Oc = (R, 8)"
+  "fetch wcode_main_tm 7 Bk = (R, 0)"
+  "fetch wcode_main_tm 8 Bk = (R, 9)"
+  "fetch wcode_main_tm 9 Bk = (R, 10)"
+  "fetch wcode_main_tm 9 Oc = (WB, 9)"
+  "fetch wcode_main_tm 10 Bk = (R, 10)"
+  "fetch wcode_main_tm 10 Oc = (R, 11)"
+  "fetch wcode_main_tm 11 Bk = (WO, 12)"
+  "fetch wcode_main_tm 11 Oc = (R, 11)"
+  "fetch wcode_main_tm 12 Oc = (L, 12)"
+  "fetch wcode_main_tm 12 Bk = (R, twice_tm_len + 14)"
+  by(auto simp: wcode_main_tm_def wcode_main_first_part_tm_def fetch.simps numeral_eqs_upto_12)
 
 declare wcode_on_checking_1.simps[simp del]
 
 lemmas wcode_double_case_inv_simps = 
   wcode_on_left_moving_1.simps wcode_on_left_moving_1_O.simps
   wcode_on_left_moving_1_B.simps wcode_on_checking_1.simps
   wcode_erase1.simps wcode_on_right_moving_1.simps
   wcode_goon_right_moving_1.simps wcode_backto_standard_pos.simps
 
 
 lemma wcode_on_left_moving_1[simp]:
   "wcode_on_left_moving_1 ires rs (b, []) = False"
   "wcode_on_left_moving_1 ires rs (b, r) \<Longrightarrow> b \<noteq> []"
   by(auto simp: wcode_on_left_moving_1.simps wcode_on_left_moving_1_B.simps
       wcode_on_left_moving_1_O.simps)
 
 lemma wcode_on_left_moving_1E[elim]: "\<lbrakk>wcode_on_left_moving_1 ires rs (b, Bk # list);
                 tl b = aa \<and> hd b # Bk # list = ba\<rbrakk> \<Longrightarrow> 
                wcode_on_left_moving_1 ires rs (aa, ba)"
   apply(simp only: wcode_on_left_moving_1.simps wcode_on_left_moving_1_O.simps
       wcode_on_left_moving_1_B.simps)
   apply(erule_tac disjE)
    apply(erule_tac exE)+
    apply(rename_tac ml mr rn)
    apply(case_tac ml, simp)
     apply(rule_tac x = "mr - Suc (Suc 0)" in exI, rule_tac x = rn in exI)
-    apply (smt One_nat_def Suc_diff_Suc append_Cons empty_replicate list.sel(3) neq0_conv replicate_Suc replicate_app_Cons_same tl_append2 tl_replicate)
+    apply (smt One_nat_def Suc_diff_Suc append_Cons empty_replicate list.sel(3) neq0_conv replicate_Suc
+           replicate_app_Cons_same tl_append2 tl_replicate)
    apply(rule_tac disjI1)
    apply (metis add_Suc_shift less_SucI list.exhaust_sel list.inject list.simps(3) replicate_Suc_iff_anywhere)
   by simp
 
 declare replicate_Suc[simp]
 
 lemma wcode_on_moving_1_Elim[elim]: 
   "\<lbrakk>wcode_on_left_moving_1 ires rs (b, Oc # list); tl b = aa \<and> hd b # Oc # list = ba\<rbrakk> 
     \<Longrightarrow> wcode_on_checking_1 ires rs (aa, ba)"
   apply(simp only: wcode_double_case_inv_simps)
   apply(erule_tac disjE)
    apply (metis cell.distinct(1) empty_replicate hd_append2 hd_replicate list.sel(1) not_gr_zero)
   apply force.
 
 lemma wcode_on_checking_1_Elim[elim]: "\<lbrakk>wcode_on_checking_1 ires rs (b, Oc # ba);Oc # b = aa \<and> list = ba\<rbrakk>
   \<Longrightarrow> wcode_erase1 ires rs (aa, ba)"
   apply(simp only: wcode_double_case_inv_simps)
   apply(erule_tac exE)+ by auto
 
 lemma wcode_on_checking_1_simp[simp]:
   "wcode_on_checking_1 ires rs (b, []) = False" 
   "wcode_on_checking_1 ires rs (b, Bk # list) = False"
   by(auto simp: wcode_double_case_inv_simps)
 
 lemma wcode_erase1_nonempty_snd[simp]: "wcode_erase1 ires rs (b, []) = False"
   apply(simp add: wcode_double_case_inv_simps)
   done
 
 lemma wcode_on_right_moving_1_nonempty_snd[simp]: "wcode_on_right_moving_1 ires rs (b, []) = False"
   apply(simp add: wcode_double_case_inv_simps)
   done
 
 lemma wcode_on_right_moving_1_BkE[elim]:
   "\<lbrakk>wcode_on_right_moving_1 ires rs (b, Bk # ba);  Bk # b = aa \<and> list = b\<rbrakk> \<Longrightarrow> 
   wcode_on_right_moving_1 ires rs (aa, ba)"
   apply(simp only: wcode_double_case_inv_simps)
   apply(erule_tac exE)+
   apply(rename_tac ml mr rn)
   apply(rule_tac x = "Suc ml" in exI, rule_tac x = "mr - Suc 0" in exI,
       rule_tac x = rn in exI)
   apply(simp)
   apply(case_tac mr, simp, simp)
   done
 
 lemma wcode_on_right_moving_1_OcE[elim]: 
   "\<lbrakk>wcode_on_right_moving_1 ires rs (b, Oc # ba); Oc # b = aa \<and> list = ba\<rbrakk> 
   \<Longrightarrow> wcode_goon_right_moving_1 ires rs (aa, ba)"
   apply(simp only: wcode_double_case_inv_simps)
   apply(erule_tac exE)+
   apply(rename_tac ml mr rn)
   apply(rule_tac x = "Suc 0" in exI, rule_tac x = "rs" in exI,
       rule_tac x = "ml - Suc (Suc 0)" in exI, rule_tac x = rn in exI)
   apply(case_tac mr, simp_all)
   apply(case_tac ml, simp, case_tac nat, simp, simp)
   done
 
 lemma wcode_erase1_BkE[elim]:
   assumes "wcode_erase1 ires rs (b, Bk # ba)" "Bk # b = aa \<and> list = ba" "c = Bk # ba"
   shows "wcode_on_right_moving_1 ires rs (aa, ba)"
 proof -
   from assms obtain rn ln where "b = Oc # ires"
     "tl (Bk # ba) = Bk \<up> ln @ Bk # Bk # Oc \<up> Suc rs @ Bk \<up> rn"
     unfolding wcode_double_case_inv_simps by auto
   thus ?thesis using assms(2-) unfolding wcode_double_case_inv_simps
     apply(rule_tac x = "Suc 0" in exI, rule_tac x = "Suc (Suc ln)" in exI, 
         rule_tac x = rn in exI, simp add: exp_ind del: replicate_Suc)
     done
 qed
 
 lemma wcode_erase1_OcE[elim]: "\<lbrakk>wcode_erase1 ires rs (aa, Oc # list);  b = aa \<and> Bk # list = ba\<rbrakk> \<Longrightarrow> 
   wcode_erase1 ires rs (aa, ba)"
   unfolding wcode_double_case_inv_simps
   by auto auto
 
 lemma wcode_goon_right_moving_1_emptyE[elim]:
   assumes "wcode_goon_right_moving_1 ires rs (aa, [])" "b = aa \<and> [Oc] = ba"
   shows "wcode_backto_standard_pos ires rs (aa, ba)"
 proof -
   from assms obtain ml ln rn mr where "aa = Oc \<up> ml @ Bk # Bk # Bk \<up> ln @ Oc # ires"
     "[] = Oc \<up> mr @ Bk \<up> rn" "ml + mr = Suc rs"
     by(auto simp:wcode_double_case_inv_simps)
   thus ?thesis using assms(2)
     apply(simp only: wcode_double_case_inv_simps)
     apply(rule_tac disjI2)
     apply(simp only:wcode_backto_standard_pos_O.simps)
     apply(rule_tac x = ml in exI, rule_tac x = "Suc 0" in exI, rule_tac x = ln in exI,
         rule_tac x = rn in exI, simp)
     done
 qed
 
 lemma wcode_goon_right_moving_1_BkE[elim]: 
   assumes "wcode_goon_right_moving_1 ires rs (aa, Bk # list)" "b = aa \<and> Oc # list = ba"
   shows "wcode_backto_standard_pos ires rs (aa, ba)"
 proof -
   from assms obtain ln rn where "aa = Oc \<up> Suc rs @ Bk \<up> Suc (Suc ln) @ Oc # ires"
     "Bk # list = Bk \<up> rn" "b = Oc \<up> Suc rs @ Bk \<up> Suc (Suc ln) @ Oc # ires" "ba = Oc # list"
     by(auto simp:wcode_double_case_inv_simps)
   thus ?thesis using assms(2)
     apply(simp only: wcode_double_case_inv_simps wcode_backto_standard_pos_O.simps)
     apply(rule_tac disjI2)
     apply(rule exI[of _ "Suc rs"], rule exI[of _ "Suc 0"], rule_tac x = ln in exI,
         rule_tac x = "rn - Suc 0" in exI, simp)
     apply(cases rn;auto)
     done
 qed
 
 lemma wcode_goon_right_moving_1_OcE[elim]: 
   assumes "wcode_goon_right_moving_1 ires rs (b, Oc # ba)" "Oc # b = aa \<and> list = ba"
   shows "wcode_goon_right_moving_1 ires rs (aa, ba)"
 proof -
   from assms obtain ml mr ln rn where
     "b = Oc \<up> ml @ Bk # Bk # Bk \<up> ln @ Oc # ires \<and>
        Oc # ba = Oc \<up> mr @ Bk \<up> rn \<and> ml + mr = Suc rs"
     unfolding wcode_double_case_inv_simps by auto
   with assms(2) show ?thesis unfolding wcode_double_case_inv_simps
     apply(rule_tac x = "Suc ml" in exI, rule_tac x = "mr - Suc 0" in exI, 
         rule_tac x = ln in exI, rule_tac x = rn in exI)
     apply(simp)
     apply(case_tac mr, simp, case_tac rn, simp_all)
     done
 qed
 
 
 lemma wcode_backto_standard_pos_BkE[elim]: "\<lbrakk>wcode_backto_standard_pos ires rs (b, Bk # ba); Bk # b = aa \<and> list = ba\<rbrakk> 
   \<Longrightarrow> wcode_before_double ires rs (aa, ba)"
   apply(simp only: wcode_double_case_inv_simps wcode_backto_standard_pos_B.simps
       wcode_backto_standard_pos_O.simps wcode_before_double.simps)
   apply(erule_tac disjE)
    apply(erule_tac exE)+ 
   by auto
 
 lemma wcode_backto_standard_pos_no_Oc[simp]: "wcode_backto_standard_pos ires rs ([], Oc # list) = False"
   apply(auto simp: wcode_backto_standard_pos.simps wcode_backto_standard_pos_B.simps
       wcode_backto_standard_pos_O.simps)
   done
 
 lemma wcode_backto_standard_pos_nonempty_snd[simp]: "wcode_backto_standard_pos ires rs (b, []) = False"
   apply(auto simp: wcode_backto_standard_pos.simps wcode_backto_standard_pos_B.simps
       wcode_backto_standard_pos_O.simps)
   done
 
 lemma wcode_backto_standard_pos_OcE[elim]: "\<lbrakk>wcode_backto_standard_pos ires rs (b, Oc # list); tl b = aa; hd b # Oc # list =  ba\<rbrakk>
        \<Longrightarrow> wcode_backto_standard_pos ires rs (aa, ba)"
   apply(simp only:  wcode_backto_standard_pos.simps wcode_backto_standard_pos_B.simps
       wcode_backto_standard_pos_O.simps)
   apply(erule_tac disjE)
    apply(simp)
   apply(erule_tac exE)+ 
   apply(simp)
   apply (rename_tac ml mr ln rn)
   apply(case_tac ml)
    apply(rule_tac disjI1, rule_tac conjI)
     apply(rule_tac x = ln  in exI, force, rule_tac x = rn in exI, force, force).
 
-declare nth_of.simps[simp del] fetch.simps[simp del]
+declare nth_of.simps[simp del]
+
 lemma wcode_double_case_first_correctness:
   "let P = (\<lambda> (st, l, r). st = 13) in 
        let Q = (\<lambda> (st, l, r). wcode_double_case_inv st ires rs (l, r)) in 
-       let f = (\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp) in
+       let f = (\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp) in
        \<exists> n .P (f n) \<and> Q (f (n::nat))"
 proof -
   let ?P = "(\<lambda> (st, l, r). st = 13)"
   let ?Q = "(\<lambda> (st, l, r). wcode_double_case_inv st ires rs (l, r))"
-  let ?f = "(\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp)"
+  let ?f = "(\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp)"
   have "\<exists> n. ?P (?f n) \<and> ?Q (?f (n::nat))"
   proof(rule_tac halt_lemma2)
     show "wf wcode_double_case_le"
       by auto
   next
     show "\<forall> na. \<not> ?P (?f na) \<and> ?Q (?f na) \<longrightarrow>
                    ?Q (?f (Suc na)) \<and> (?f (Suc na), ?f na) \<in> wcode_double_case_le"
     proof(rule_tac allI, case_tac "?f na", simp)
       fix na a b c
       show "a \<noteq> 13 \<and> wcode_double_case_inv a ires rs (b, c) \<longrightarrow>
-               (case step0 (a, b, c) t_wcode_main of (st, x) \<Rightarrow> 
+               (case step0 (a, b, c) wcode_main_tm of (st, x) \<Rightarrow> 
                    wcode_double_case_inv st ires rs x) \<and> 
-                (step0 (a, b, c) t_wcode_main, a, b, c) \<in> wcode_double_case_le"
+                (step0 (a, b, c) wcode_main_tm, a, b, c) \<in> wcode_double_case_le"
         apply(rule_tac impI, simp add: wcode_double_case_inv.simps)
         apply(auto split: if_splits simp: step.simps, 
             case_tac [!] c, simp_all, case_tac [!] "(c::cell list)!0")
                             apply(simp_all add: wcode_double_case_inv.simps wcode_double_case_le_def
             lex_pair_def)
                       apply(auto split: if_splits)
         done
     qed
   next
     show "?Q (?f 0)"
       apply(simp add: steps.simps wcode_double_case_inv.simps 
           wcode_on_left_moving_1.simps
           wcode_on_left_moving_1_B.simps)
       apply(rule_tac disjI1)
       apply(rule_tac x = "Suc m" in exI, simp)
       apply(rule_tac x = "Suc 0" in exI, simp)
       done
   next
     show "\<not> ?P (?f 0)"
       apply(simp add: steps.simps)
       done
   qed
   thus "let P = \<lambda>(st, l, r). st = 13;
     Q = \<lambda>(st, l, r). wcode_double_case_inv st ires rs (l, r);
-    f = steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main
+    f = steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm
     in \<exists>n. P (f n) \<and> Q (f n)"
     apply(simp)
     done
 qed
 
 lemma tm_append_shift_append_steps: 
   "\<lbrakk>steps0 (st, l, r) tp stp = (st', l', r'); 
   0 < st';
   length tp1 mod 2 = 0
   \<rbrakk>
   \<Longrightarrow> steps0 (st + length tp1 div 2, l, r) (tp1 @ shift tp (length tp1 div 2) @ tp2) stp 
   = (st' + length tp1 div 2, l', r')"
 proof -
   assume h: 
     "steps0 (st, l, r) tp stp = (st', l', r')"
     "0 < st'"
     "length tp1 mod 2 = 0 "
   from h have 
     "steps (st + length tp1 div 2, l, r) (tp1 @ shift tp (length tp1 div 2), 0) stp = 
                             (st' + length tp1 div 2, l', r')"
     by(rule_tac tm_append_second_steps_eq, simp_all)
   then have "steps (st + length tp1 div 2, l, r) ((tp1 @ shift tp (length tp1 div 2)) @ tp2, 0) stp = 
                             (st' + length tp1 div 2, l', r')"
     using h
     apply(rule_tac tm_append_first_steps_eq, simp_all)
     done
   thus "?thesis"
     by simp
 qed 
 
-declare start_of.simps[simp del]
-
 lemma twice_lemma: "rec_exec rec_twice [rs] = 2*rs"
   by(auto simp: rec_twice_def rec_exec.simps)
 
-lemma t_twice_correct: 
+lemma twice_tm_correct: 
   "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) 
-  (tm_of abc_twice @ shift (mopup (Suc 0)) ((length (tm_of abc_twice) div 2))) stp =
+  (tm_of abc_twice @ shift (mopup_n_tm (Suc 0)) ((length (tm_of abc_twice) div 2))) stp =
   (0, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))"
 proof(case_tac "rec_ci rec_twice")
   fix a b c
   assume h: "rec_ci rec_twice = (a, b, c)"
-  have "\<exists>stp m l. steps0 (Suc 0, Bk # Bk # ires, <[rs]> @ Bk\<up>(n)) (tm_of abc_twice @ shift (mopup (length [rs])) 
+  have "\<exists>stp m l. steps0 (Suc 0, Bk # Bk # ires, <[rs]> @ Bk\<up>(n)) (tm_of abc_twice @ shift (mopup_n_tm (length [rs])) 
     (length (tm_of abc_twice) div 2)) stp = (0, Bk\<up>(m) @ Bk # Bk # ires, Oc\<up>(Suc (rec_exec rec_twice [rs])) @ Bk\<up>(l))"
     thm  recursive_compile_to_tm_correct1
   proof(rule_tac recursive_compile_to_tm_correct1)
     show "rec_ci rec_twice = (a, b, c)" by (simp add: h)
   next
     show "terminate rec_twice [rs]"
       apply(rule_tac primerec_terminate, auto)
       apply(simp add: rec_twice_def, auto simp: constn.simps numeral_2_eq_2)
       by(auto)
   next
     show "tm_of abc_twice = tm_of (a [+] dummy_abc (length [rs]))"
       using h
       by(simp add: abc_twice_def)
   qed
   thus "?thesis"
     apply(simp add: tape_of_list_def tape_of_nat_def rec_exec.simps twice_lemma)
     done
 qed
 
 declare adjust.simps[simp]
 
 lemma adjust_fetch0: 
   "\<lbrakk>0 < a; a \<le> length ap div 2;  fetch ap a b = (aa, 0)\<rbrakk>
   \<Longrightarrow> fetch (adjust0 ap) a b = (aa, Suc (length ap div 2))"
-  apply(case_tac b, auto simp: fetch.simps nth_of.simps nth_map
+  apply(case_tac b, auto 
       split: if_splits)
    apply(case_tac [!] a, auto simp: fetch.simps nth_of.simps)
   done
 
 lemma adjust_fetch_norm: 
   "\<lbrakk>st > 0;  st \<le> length tp div 2; fetch ap st b = (aa, ns); ns \<noteq> 0\<rbrakk>
  \<Longrightarrow>  fetch (adjust0 ap) st b = (aa, ns)"
-  apply(case_tac b, auto simp: fetch.simps nth_of.simps nth_map
+  apply(case_tac b, auto simp: fetch.simps 
       split: if_splits)
    apply(case_tac [!] st, auto simp: fetch.simps nth_of.simps)
   done
 
 declare adjust.simps[simp del]
 
 lemma adjust_step_eq: 
   assumes exec: "step0 (st,l,r) ap = (st', l', r')"
-    and wf_tm: "tm_wf (ap, 0)"
+    and "composable_tm (ap, 0)"
     and notfinal: "st' > 0"
   shows "step0 (st, l, r) (adjust0 ap) = (st', l', r')"
   using assms
 proof -
   have "st > 0"
     using assms
     by(case_tac st, simp_all add: step.simps fetch.simps)
   moreover hence "st \<le> (length ap) div 2"
     using assms
     apply(case_tac "st \<le> (length ap) div 2", simp)
     apply(case_tac st, auto simp: step.simps fetch.simps)
     apply(case_tac "read r", simp_all add: fetch.simps 
-        nth_of.simps adjust.simps tm_wf.simps split: if_splits)
+        nth_of.simps adjust.simps composable_tm.simps split: if_splits)
      apply(auto simp: mod_ex2)
     done    
   ultimately have "fetch (adjust0 ap) st (read r) = fetch ap st (read r)"
     using assms
     apply(case_tac "fetch ap st (read r)")
     apply(drule_tac adjust_fetch_norm, simp_all)
     apply(simp add: step.simps)
     done
   thus "?thesis"
     using exec
     by(simp add: step.simps)
 qed
 
-declare adjust.simps[simp del]
 
 lemma adjust_steps_eq: 
   assumes exec: "steps0 (st,l,r) ap stp = (st', l', r')"
-    and wf_tm: "tm_wf (ap, 0)"
+    and "composable_tm (ap, 0)"
     and notfinal: "st' > 0"
   shows "steps0 (st, l, r) (adjust0 ap) stp = (st', l', r')"
   using exec notfinal
 proof(induct stp arbitrary: st' l' r')
   case 0
   thus "?case"
     by(simp add: steps.simps)
 next
   case (Suc stp st' l' r')
   have ind: "\<And>st' l' r'. \<lbrakk>steps0 (st, l, r) ap stp = (st', l', r'); 0 < st'\<rbrakk> 
     \<Longrightarrow> steps0 (st, l, r) (adjust0 ap) stp = (st', l', r')" by fact
   have h: "steps0 (st, l, r) ap (Suc stp) = (st', l', r')" by fact
   have g:   "0 < st'" by fact
   obtain st'' l'' r'' where a: "steps0 (st, l, r) ap stp = (st'', l'', r'')"
     by (metis prod_cases3)
   hence c:"0 < st''"
     using h g
-    apply(simp add: step_red)
+    apply(simp)
     apply(case_tac st'', auto)
     done
   hence b: "steps0 (st, l, r) (adjust0 ap) stp = (st'', l'', r'')"
     using a
     by(rule_tac ind, simp_all)
   thus "?case"
     using assms a b h g
-    apply(simp add: step_red) 
+    apply(simp ) 
     apply(rule_tac adjust_step_eq, simp_all)
     done
 qed 
 
 lemma adjust_halt_eq:
   assumes exec: "steps0 (1, l, r) ap stp = (0, l', r')"
-    and tm_wf: "tm_wf (ap, 0)" 
+    and composable_tm: "composable_tm (ap, 0)" 
   shows "\<exists> stp. steps0 (Suc 0, l, r) (adjust0 ap) stp = 
         (Suc (length ap div 2), l', r')"
 proof -
   have "\<exists> stp. \<not> is_final (steps0 (1, l, r) ap stp) \<and> (steps0 (1, l, r) ap (Suc stp) = (0, l', r'))"
     using exec
     by(erule_tac before_final)
   then obtain stpa where a: 
     "\<not> is_final (steps0 (1, l, r) ap stpa) \<and> (steps0 (1, l, r) ap (Suc stpa) = (0, l', r'))" ..
   obtain sa la ra where b:"steps0 (1, l, r) ap stpa = (sa, la, ra)"  by (metis prod_cases3)
   hence c: "steps0 (Suc 0, l, r) (adjust0 ap) stpa = (sa, la, ra)"
     using assms a
     apply(rule_tac adjust_steps_eq, simp_all)
     done
   have d: "sa \<le> length ap div 2"
-    using steps_in_range[of  "(l, r)" ap stpa] a tm_wf b
+    using steps_in_range[of  "(l, r)" ap stpa] a composable_tm b
     by(simp)
   obtain ac ns where e: "fetch ap sa (read ra) = (ac, ns)"
     by (metis prod.exhaust)
   hence f: "ns = 0"
     using b a
-    apply(simp add: step_red step.simps)
+    apply(simp add:  step.simps)
     done
   have k: "fetch (adjust0 ap) sa (read ra) = (ac, Suc (length ap div 2))"
     using a b c d e f
     apply(rule_tac adjust_fetch0, simp_all)
     done
   from a b e f k and c show "?thesis"
     apply(rule_tac x = "Suc stpa" in exI)
-    apply(simp add: step_red, auto)
+    apply(simp  , auto)
     apply(simp add: step.simps)
     done
-qed    
-
-declare tm_wf.simps[simp del]
-
-lemma tm_wf_t_twice_compile [simp]: "tm_wf (t_twice_compile, 0)"
-  apply(simp only: t_twice_compile_def)
-  apply(rule_tac wf_tm_from_abacus, simp)
+qed
+
+lemma composable_tm_twice_compile_tm [simp]: "composable_tm (twice_compile_tm, 0)"
+  apply(simp only: twice_compile_tm_def)
+  apply(rule_tac composable_tm_from_abacus, simp)
   done
 
-lemma t_twice_change_term_state:
-  "\<exists> stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) t_twice stp
-     = (Suc t_twice_len, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))"
+lemma twice_tm_change_term_state:
+  "\<exists> stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) twice_tm stp
+     = (Suc twice_tm_len, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))"
 proof -
   have "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) 
-    (tm_of abc_twice @ shift (mopup (Suc 0)) ((length (tm_of abc_twice) div 2))) stp =
+    (tm_of abc_twice @ shift (mopup_n_tm (Suc 0)) ((length (tm_of abc_twice) div 2))) stp =
     (0, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))"
-    by(rule_tac t_twice_correct)
+    by(rule_tac twice_tm_correct)
   then obtain stp ln rn where " steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) 
-    (tm_of abc_twice @ shift (mopup (Suc 0)) ((length (tm_of abc_twice) div 2))) stp =
+    (tm_of abc_twice @ shift (mopup_n_tm (Suc 0)) ((length (tm_of abc_twice) div 2))) stp =
     (0, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))" by blast
   hence "\<exists> stp. steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
-    (adjust0 t_twice_compile) stp
-     = (Suc (length t_twice_compile div 2), Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))"
+    (adjust0 twice_compile_tm) stp
+     = (Suc (length twice_compile_tm div 2), Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))"
     apply(rule_tac stp = stp in adjust_halt_eq)
-     apply(simp add: t_twice_compile_def, auto)
+     apply(simp add: twice_compile_tm_def, auto)
     done
   then obtain stpb where 
     "steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
-    (adjust0 t_twice_compile) stpb
-     = (Suc (length t_twice_compile div 2), Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))" ..
+    (adjust0 twice_compile_tm) stpb
+     = (Suc (length twice_compile_tm div 2), Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))" ..
   thus "?thesis"
-    apply(simp add: t_twice_def t_twice_len_def)
+    apply(simp add: twice_tm_def twice_tm_len_def)
     by metis
 qed
 
-lemma length_t_wcode_main_first_part_even[intro]: "length t_wcode_main_first_part mod 2 = 0"
-  apply(auto simp: t_wcode_main_first_part_def)
+lemma length_wcode_main_first_part_tm_even[intro]: "length wcode_main_first_part_tm mod 2 = 0"
+  apply(auto simp: wcode_main_first_part_tm_def)
   done
 
-lemma t_twice_append_pre:
-  "steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) t_twice stp
-  = (Suc t_twice_len, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))
-   \<Longrightarrow> steps0 (Suc 0 + length t_wcode_main_first_part div 2, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
-     (t_wcode_main_first_part @ shift t_twice (length t_wcode_main_first_part div 2) @
-      ([(L, 1), (L, 1)] @ shift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)])) stp 
-    = (Suc (t_twice_len) + length t_wcode_main_first_part div 2, 
+lemma twice_tm_append_pre:
+  "steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) twice_tm stp
+  = (Suc twice_tm_len, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))
+   \<Longrightarrow> steps0 (Suc 0 + length wcode_main_first_part_tm div 2, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
+     (wcode_main_first_part_tm @ shift twice_tm (length wcode_main_first_part_tm div 2) @
+      ([(L, 1), (L, 1)] @ shift fourtimes_tm (twice_tm_len + 13) @ [(L, 1), (L, 1)])) stp 
+    = (Suc (twice_tm_len) + length wcode_main_first_part_tm div 2, 
              Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))"
   by(rule_tac tm_append_shift_append_steps, auto)
 
-lemma t_twice_append:
-  "\<exists> stp ln rn. steps0 (Suc 0 + length t_wcode_main_first_part div 2, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
-     (t_wcode_main_first_part @ shift t_twice (length t_wcode_main_first_part div 2) @
-      ([(L, 1), (L, 1)] @ shift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)])) stp 
-    = (Suc (t_twice_len) + length t_wcode_main_first_part div 2, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))"
-  using t_twice_change_term_state[of ires rs n]
+lemma twice_tm_append:
+  "\<exists> stp ln rn. steps0 (Suc 0 + length wcode_main_first_part_tm div 2, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
+     (wcode_main_first_part_tm @ shift twice_tm (length wcode_main_first_part_tm div 2) @
+      ([(L, 1), (L, 1)] @ shift fourtimes_tm (twice_tm_len + 13) @ [(L, 1), (L, 1)])) stp 
+    = (Suc (twice_tm_len) + length wcode_main_first_part_tm div 2, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))"
+  using twice_tm_change_term_state[of ires rs n]
   apply(erule_tac exE)
   apply(erule_tac exE)
   apply(erule_tac exE)
-  apply(drule_tac t_twice_append_pre)
+  apply(drule_tac twice_tm_append_pre)
   apply(rename_tac stp ln rn)
   apply(rule_tac x = stp in exI, rule_tac x = ln in exI, rule_tac x = rn in exI)
   apply(simp)
   done
 
-lemma mopup_mod2: "length (mopup k) mod 2  = 0"
-  by(auto simp: mopup.simps)
-
-lemma fetch_t_wcode_main_Oc[simp]: "fetch t_wcode_main (Suc (t_twice_len + length t_wcode_main_first_part div 2)) Oc
+lemma mopup_mod2: "length (mopup_n_tm k) mod 2  = 0"
+  by(auto simp: mopup_n_tm.simps)
+
+lemma fetch_wcode_main_tm_Oc[simp]: "fetch wcode_main_tm (Suc (twice_tm_len + length wcode_main_first_part_tm div 2)) Oc
      = (L, Suc 0)"
-  apply(subgoal_tac "length (t_twice) mod 2 = 0")
-   apply(simp add: t_wcode_main_def nth_append fetch.simps t_wcode_main_first_part_def 
-      nth_of.simps t_twice_len_def, auto)
-  apply(simp add: t_twice_def t_twice_compile_def)
+  apply(subgoal_tac "length (twice_tm) mod 2 = 0")
+   apply(simp add: wcode_main_tm_def nth_append fetch.simps wcode_main_first_part_tm_def 
+      nth_of.simps twice_tm_len_def, auto)
+  apply(simp add: twice_tm_def twice_compile_tm_def)
   using mopup_mod2[of 1]
   apply(simp)
   done
 
 lemma wcode_jump1: 
-  "\<exists> stp ln rn. steps0 (Suc (t_twice_len) + length t_wcode_main_first_part div 2,
+  "\<exists> stp ln rn. steps0 (Suc (twice_tm_len) + length wcode_main_first_part_tm div 2,
                        Bk\<up>(m) @ Bk # Bk # ires, Oc\<up>(Suc (2 * rs)) @ Bk\<up>(n))
-     t_wcode_main stp 
+     wcode_main_tm stp 
     = (Suc 0, Bk\<up>(ln) @ Bk # ires, Bk # Oc\<up>(Suc (2 * rs)) @ Bk\<up>(rn))"
   apply(rule_tac x = "Suc 0" in exI, rule_tac x = "m" in exI, rule_tac x = n in exI)
   apply(simp add: steps.simps step.simps exp_ind)
   apply(case_tac m, simp_all)
   apply(simp add: exp_ind[THEN sym])
   done
 
 lemma wcode_main_first_part_len[simp]:
-  "length t_wcode_main_first_part = 24"
-  apply(simp add: t_wcode_main_first_part_def)
+  "length wcode_main_first_part_tm = 24"
+  apply(simp add: wcode_main_first_part_tm_def)
   done
 
 lemma wcode_double_case: 
-  shows "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+  shows "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
           (Suc 0, Bk # Bk\<up>(ln) @ Oc # ires, Bk # Oc\<up>(Suc (2 * rs + 2)) @ Bk\<up>(rn))"
     (is "\<exists>stp ln rn. ?tm stp ln rn")
 proof -
   from wcode_double_case_first_correctness[of ires rs m n] obtain na ln rn where
-    "steps0 (Suc 0, Bk # Bk \<up> m @ Oc # Oc # ires, Bk # Oc # Oc \<up> rs @ Bk \<up> n) t_wcode_main na
+    "steps0 (Suc 0, Bk # Bk \<up> m @ Oc # Oc # ires, Bk # Oc # Oc \<up> rs @ Bk \<up> n) wcode_main_tm na
       = (13, Bk # Bk # Bk \<up> ln @ Oc # ires, Oc # Oc # Oc \<up> rs @ Bk \<up> rn)"
     by(auto simp: wcode_double_case_inv.simps wcode_before_double.simps)
-  hence "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+  hence "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
           (13,  Bk # Bk # Bk\<up>(ln) @ Oc # ires, Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rn))"
     by(case_tac "steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, 
-           Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main na", auto)  
+           Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm na", auto)  
   from this obtain stpa lna rna where stp1: 
-    "steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stpa = 
+    "steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stpa = 
     (13, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rna))" by blast
-  from t_twice_append[of "Bk\<up>(lna) @ Oc # ires" "Suc rs" rna] obtain stp ln rn
-    where "steps0 (Suc 0 + length t_wcode_main_first_part div 2,
+  from twice_tm_append[of "Bk\<up>(lna) @ Oc # ires" "Suc rs" rna] obtain stp ln rn
+    where "steps0 (Suc 0 + length wcode_main_first_part_tm div 2,
                    Bk # Bk # Bk \<up> lna @ Oc # ires, Oc \<up> Suc (Suc rs) @ Bk \<up> rna)
-                  (t_wcode_main_first_part @ shift t_twice (length t_wcode_main_first_part div 2) @
-                   [(L, 1), (L, 1)] @ shift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)]) stp =
-           (Suc t_twice_len + length t_wcode_main_first_part div 2, 
+                  (wcode_main_first_part_tm @ shift twice_tm (length wcode_main_first_part_tm div 2) @
+                   [(L, 1), (L, 1)] @ shift fourtimes_tm (twice_tm_len + 13) @ [(L, 1), (L, 1)]) stp =
+           (Suc twice_tm_len + length wcode_main_first_part_tm div 2, 
             Bk \<up> ln @ Bk # Bk # Bk \<up> lna @ Oc # ires, Oc \<up> Suc (2 * Suc rs) @ Bk \<up> rn)" by blast
-  hence "\<exists> stp ln rn. steps0 (13, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rna)) t_wcode_main stp =
-    (13 + t_twice_len, Bk # Bk # Bk\<up>(ln) @ Oc # ires, Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rn))"
-    using t_twice_append[of "Bk\<up>(lna) @ Oc # ires" "Suc rs" rna]
+  hence "\<exists> stp ln rn. steps0 (13, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rna)) wcode_main_tm stp =
+    (13 + twice_tm_len, Bk # Bk # Bk\<up>(ln) @ Oc # ires, Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rn))"
+    using twice_tm_append[of "Bk\<up>(lna) @ Oc # ires" "Suc rs" rna]
     apply(simp)
     apply(rule_tac x = stp in exI, rule_tac x = "ln + lna" in exI, 
         rule_tac x = rn in exI)
-    apply(simp add: t_wcode_main_def)
+    apply(simp add: wcode_main_tm_def)
     apply(simp add: replicate_Suc[THEN sym] replicate_add [THEN sym] del: replicate_Suc)
     done
   from this obtain stpb lnb rnb where stp2: 
-    "steps0 (13, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rna)) t_wcode_main stpb =
-    (13 + t_twice_len, Bk # Bk # Bk\<up>(lnb) @ Oc # ires, Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rnb))" by blast
+    "steps0 (13, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rna)) wcode_main_tm stpb =
+    (13 + twice_tm_len, Bk # Bk # Bk\<up>(lnb) @ Oc # ires, Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rnb))" by blast
   from wcode_jump1[of lnb "Oc # ires" "Suc rs" rnb] obtain stp ln rn where
-    "steps0 (Suc t_twice_len + length t_wcode_main_first_part div 2, 
-             Bk \<up> lnb @ Bk # Bk # Oc # ires, Oc \<up> Suc (2 * Suc rs) @ Bk \<up> rnb) t_wcode_main stp =
+    "steps0 (Suc twice_tm_len + length wcode_main_first_part_tm div 2, 
+             Bk \<up> lnb @ Bk # Bk # Oc # ires, Oc \<up> Suc (2 * Suc rs) @ Bk \<up> rnb) wcode_main_tm stp =
      (Suc 0, Bk \<up> ln @ Bk # Oc # ires, Bk # Oc \<up> Suc (2 * Suc rs) @ Bk \<up> rn)" by metis
-  hence "steps0 (13 + t_twice_len, Bk # Bk # Bk\<up>(lnb) @ Oc # ires,
-    Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rnb)) t_wcode_main stp = 
+  hence "steps0 (13 + twice_tm_len, Bk # Bk # Bk\<up>(lnb) @ Oc # ires,
+    Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rnb)) wcode_main_tm stp = 
        (Suc 0,  Bk # Bk\<up>(ln) @ Oc # ires, Bk # Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rn))"
-    apply(auto simp add: t_wcode_main_def)
+    apply(auto simp add: wcode_main_tm_def)
     apply(subgoal_tac "Bk\<up>(lnb) @ Bk # Bk # Oc # ires = Bk # Bk # Bk\<up>(lnb) @ Oc # ires", simp)
      apply(simp add: replicate_Suc[THEN sym] exp_ind[THEN sym] del: replicate_Suc)
     apply(simp)
     apply(simp add: replicate_Suc[THEN sym] exp_ind del: replicate_Suc)
     done 
-  hence "\<exists>stp ln rn. steps0 (13 + t_twice_len, Bk # Bk # Bk\<up>(lnb) @ Oc # ires,
-    Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rnb)) t_wcode_main stp = 
+  hence "\<exists>stp ln rn. steps0 (13 + twice_tm_len, Bk # Bk # Bk\<up>(lnb) @ Oc # ires,
+    Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rnb)) wcode_main_tm stp = 
        (Suc 0,  Bk # Bk\<up>(ln) @ Oc # ires, Bk # Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rn))"
     by blast
   from this obtain stpc lnc rnc where stp3: 
-    "steps0 (13 + t_twice_len, Bk # Bk # Bk\<up>(lnb) @ Oc # ires,
-    Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rnb)) t_wcode_main stpc = 
+    "steps0 (13 + twice_tm_len, Bk # Bk # Bk\<up>(lnb) @ Oc # ires,
+    Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rnb)) wcode_main_tm stpc = 
        (Suc 0,  Bk # Bk\<up>(lnc) @ Oc # ires, Bk # Oc\<up>(Suc (Suc (Suc (2 *rs)))) @ Bk\<up>(rnc))"
     by blast
   from stp1 stp2 stp3 have "?tm (stpa + stpb + stpc) lnc rnc" by simp
   thus "?thesis" by blast
 qed
 
 
 (* Begin: fourtime_case*)
 fun wcode_on_left_moving_2_B :: "bin_inv_t"
   where
     "wcode_on_left_moving_2_B ires rs (l, r) =
      (\<exists> ml mr rn. l = Bk\<up>(ml) @ Oc # Bk # Oc # ires \<and>
                  r = Bk\<up>(mr) @ Oc\<up>(Suc rs) @ Bk\<up>(rn) \<and> 
                  ml + mr > Suc 0 \<and> mr > 0)"
 
 fun wcode_on_left_moving_2_O :: "bin_inv_t"
   where
     "wcode_on_left_moving_2_O ires rs (l, r) =
      (\<exists> ln rn. l = Bk # Oc # ires \<and>
                r = Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wcode_on_left_moving_2 :: "bin_inv_t"
   where
     "wcode_on_left_moving_2 ires rs (l, r) = 
       (wcode_on_left_moving_2_B ires rs (l, r) \<or> 
       wcode_on_left_moving_2_O ires rs (l, r))"
 
 fun wcode_on_checking_2 :: "bin_inv_t"
   where
     "wcode_on_checking_2 ires rs (l, r) =
        (\<exists> ln rn. l = Oc#ires \<and> 
                  r = Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wcode_goon_checking :: "bin_inv_t"
   where
     "wcode_goon_checking ires rs (l, r) =
        (\<exists> ln rn. l = ires \<and>
                  r = Oc # Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wcode_right_move :: "bin_inv_t"
   where
     "wcode_right_move ires rs (l, r) = 
      (\<exists> ln rn. l = Oc # ires \<and>
                  r = Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wcode_erase2 :: "bin_inv_t"
   where
     "wcode_erase2 ires rs (l, r) = 
         (\<exists> ln rn. l = Bk # Oc # ires \<and>
                  tl r = Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wcode_on_right_moving_2 :: "bin_inv_t"
   where
     "wcode_on_right_moving_2 ires rs (l, r) = 
         (\<exists> ml mr rn. l = Bk\<up>(ml) @ Oc # ires \<and> 
                      r = Bk\<up>(mr) @ Oc\<up>(Suc rs) @ Bk\<up>(rn) \<and> ml + mr > Suc 0)"
 
 fun wcode_goon_right_moving_2 :: "bin_inv_t"
   where
     "wcode_goon_right_moving_2 ires rs (l, r) = 
         (\<exists> ml mr ln rn. l = Oc\<up>(ml) @ Bk # Bk # Bk\<up>(ln) @ Oc # ires \<and>
                         r = Oc\<up>(mr) @ Bk\<up>(rn) \<and> ml + mr = Suc rs)"
 
 fun wcode_backto_standard_pos_2_B :: "bin_inv_t"
   where
     "wcode_backto_standard_pos_2_B ires rs (l, r) = 
            (\<exists> ln rn. l = Bk # Bk\<up>(ln) @ Oc # ires \<and> 
                      r = Bk # Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rn))"
 
 fun wcode_backto_standard_pos_2_O :: "bin_inv_t"
   where
     "wcode_backto_standard_pos_2_O ires rs (l, r) = 
           (\<exists> ml mr ln rn. l = Oc\<up>(ml )@ Bk # Bk # Bk\<up>(ln) @ Oc # ires \<and> 
                           r = Oc\<up>(mr) @ Bk\<up>(rn) \<and> 
                           ml + mr = (Suc (Suc rs)) \<and> mr > 0)"
 
 fun wcode_backto_standard_pos_2 :: "bin_inv_t"
   where
     "wcode_backto_standard_pos_2 ires rs (l, r) = 
            (wcode_backto_standard_pos_2_O ires rs (l, r) \<or> 
            wcode_backto_standard_pos_2_B ires rs (l, r))"
 
 fun wcode_before_fourtimes :: "bin_inv_t"
   where
     "wcode_before_fourtimes ires rs (l, r) = 
           (\<exists> ln rn. l = Bk # Bk # Bk\<up>(ln) @ Oc # ires \<and> 
                     r = Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rn))"
 
 declare wcode_on_left_moving_2_B.simps[simp del] wcode_on_left_moving_2.simps[simp del]
   wcode_on_left_moving_2_O.simps[simp del] wcode_on_checking_2.simps[simp del]
   wcode_goon_checking.simps[simp del] wcode_right_move.simps[simp del]
   wcode_erase2.simps[simp del]
   wcode_on_right_moving_2.simps[simp del] wcode_goon_right_moving_2.simps[simp del]
   wcode_backto_standard_pos_2_B.simps[simp del] wcode_backto_standard_pos_2_O.simps[simp del]
   wcode_backto_standard_pos_2.simps[simp del]
 
 lemmas wcode_fourtimes_invs = 
   wcode_on_left_moving_2_B.simps wcode_on_left_moving_2.simps
   wcode_on_left_moving_2_O.simps wcode_on_checking_2.simps
   wcode_goon_checking.simps wcode_right_move.simps
   wcode_erase2.simps
   wcode_on_right_moving_2.simps wcode_goon_right_moving_2.simps
   wcode_backto_standard_pos_2_B.simps wcode_backto_standard_pos_2_O.simps
   wcode_backto_standard_pos_2.simps
 
 fun wcode_fourtimes_case_inv :: "nat \<Rightarrow> bin_inv_t"
   where
     "wcode_fourtimes_case_inv st ires rs (l, r) = 
            (if st = Suc 0 then wcode_on_left_moving_2 ires rs (l, r)
             else if st = Suc (Suc 0) then wcode_on_checking_2 ires rs (l, r)
             else if st = 7 then wcode_goon_checking ires rs (l, r)
             else if st = 8 then wcode_right_move ires rs (l, r)
             else if st = 9 then wcode_erase2 ires rs (l, r)
             else if st = 10 then wcode_on_right_moving_2 ires rs (l, r)
             else if st = 11 then wcode_goon_right_moving_2 ires rs (l, r)
             else if st = 12 then wcode_backto_standard_pos_2 ires rs (l, r)
-            else if st = t_twice_len + 14 then wcode_before_fourtimes ires rs (l, r)
+            else if st = twice_tm_len + 14 then wcode_before_fourtimes ires rs (l, r)
             else False)"
 
 declare wcode_fourtimes_case_inv.simps[simp del]
 
 fun wcode_fourtimes_case_state :: "config \<Rightarrow> nat"
   where
     "wcode_fourtimes_case_state (st, l, r) = 13 - st"
 
 fun wcode_fourtimes_case_step :: "config \<Rightarrow> nat"
   where
     "wcode_fourtimes_case_step (st, l, r) = 
          (if st = Suc 0 then length l
           else if st = 9 then 
            (if hd r = Oc then 1
             else 0)
           else if st = 10 then length r
           else if st = 11 then length r
           else if st = 12 then length l
           else 0)"
 
 fun wcode_fourtimes_case_measure :: "config \<Rightarrow> nat \<times> nat"
   where
     "wcode_fourtimes_case_measure (st, l, r) = 
      (wcode_fourtimes_case_state (st, l, r), 
       wcode_fourtimes_case_step (st, l, r))"
 
 definition wcode_fourtimes_case_le :: "(config \<times> config) set"
   where "wcode_fourtimes_case_le \<equiv> (inv_image lex_pair wcode_fourtimes_case_measure)"
 
 lemma wf_wcode_fourtimes_case_le[intro]: "wf wcode_fourtimes_case_le"
   by(auto simp: wcode_fourtimes_case_le_def)
 
 lemma nonempty_snd [simp]:
   "wcode_on_left_moving_2 ires rs (b, []) = False"
   "wcode_on_checking_2 ires rs (b, []) = False"
   "wcode_goon_checking ires rs (b, []) = False"
   "wcode_right_move ires rs (b, []) = False"
   "wcode_erase2 ires rs (b, []) = False"
   "wcode_on_right_moving_2 ires rs (b, []) = False"
   "wcode_backto_standard_pos_2 ires rs (b, []) = False"
   "wcode_on_checking_2 ires rs (b, Oc # list) = False"
   by(auto simp: wcode_fourtimes_invs) 
 
+lemma gr1_conv_Suc:"Suc 0 < mr \<longleftrightarrow> (\<exists> nat. mr = Suc (Suc nat))" by presburger
+
 lemma wcode_on_left_moving_2[simp]:
   "wcode_on_left_moving_2 ires rs (b, Bk # list) \<Longrightarrow>  wcode_on_left_moving_2 ires rs (tl b, hd b # Bk # list)"
   apply(simp only: wcode_fourtimes_invs)
   apply(erule_tac disjE)
    apply(erule_tac exE)+
-   apply(simp add: gr1_conv_Suc exp_ind replicate_app_Cons_same split:hd_repeat_cases)
-   apply (auto simp add: gr0_conv_Suc[symmetric] replicate_app_Cons_same split:hd_repeat_cases)
+   apply(simp add: gr1_conv_Suc exp_ind replicate_app_Cons_same hd_repeat_cases')
+   apply (auto simp add: gr0_conv_Suc[symmetric] replicate_app_Cons_same hd_repeat_cases')
   by force+
 
 
 lemma wcode_goon_checking_via_2 [simp]: "wcode_on_checking_2 ires rs (b, Bk # list)
        \<Longrightarrow>   wcode_goon_checking ires rs (tl b, hd b # Bk # list)"
   unfolding wcode_fourtimes_invs by auto
 
 lemma wcode_erase2_via_move [simp]: "wcode_right_move ires rs (b, Bk # list) \<Longrightarrow>  wcode_erase2 ires rs (Bk # b, list)"
   by (auto simp:wcode_fourtimes_invs ) auto
 
 lemma wcode_on_right_moving_2_via_erase2[simp]:
   "wcode_erase2 ires rs (b, Bk # list) \<Longrightarrow> wcode_on_right_moving_2 ires rs (Bk # b, list)"
   apply(auto simp:wcode_fourtimes_invs )
   apply(rule_tac x = "Suc (Suc 0)" in exI, simp add: exp_ind)
   by (metis replicate_Suc_iff_anywhere replicate_app_Cons_same)
 
 lemma wcode_on_right_moving_2_move_Bk[simp]: "wcode_on_right_moving_2 ires rs (b, Bk # list)
        \<Longrightarrow> wcode_on_right_moving_2 ires rs (Bk # b, list)"
   apply(auto simp: wcode_fourtimes_invs) apply(rename_tac ml mr rn)
   apply(rule_tac x = "Suc ml" in exI, simp)
   apply(rule_tac x = "mr - 1" in exI, case_tac mr,auto)
   done
 
 lemma wcode_backto_standard_pos_2_via_right[simp]:
   "wcode_goon_right_moving_2 ires rs (b, Bk # list) \<Longrightarrow> 
                  wcode_backto_standard_pos_2 ires rs (b, Oc # list)"
   apply(simp add: wcode_fourtimes_invs, auto)
   by (metis add.right_neutral add_Suc_shift append_Cons list.sel(3)
       replicate.simps(1) replicate_Suc replicate_Suc_iff_anywhere self_append_conv2
       tl_replicate zero_less_Suc)
 
 lemma wcode_on_checking_2_via_left[simp]: "wcode_on_left_moving_2 ires rs (b, Oc # list) \<Longrightarrow> 
                      wcode_on_checking_2 ires rs (tl b, hd b # Oc # list)"
   by(auto simp: wcode_fourtimes_invs)
 
 lemma wcode_backto_standard_pos_2_empty_via_right[simp]:
   "wcode_goon_right_moving_2 ires rs (b, []) \<Longrightarrow>
               wcode_backto_standard_pos_2 ires rs (b, [Oc])"
   by (auto simp add: wcode_fourtimes_invs) force
 
 lemma wcode_goon_checking_cases[simp]: "wcode_goon_checking ires rs (b, Oc # list) \<Longrightarrow>
   (b = [] \<longrightarrow> wcode_right_move ires rs ([Oc], list)) \<and>
   (b \<noteq> [] \<longrightarrow> wcode_right_move ires rs (Oc # b, list))"
   apply(simp only: wcode_fourtimes_invs)
   apply(erule_tac exE)+
   apply(auto)
   done
 
 lemma wcode_right_move_no_Oc[simp]: "wcode_right_move ires rs (b, Oc # list) = False"
   apply(auto simp: wcode_fourtimes_invs)
   done
 
 lemma wcode_erase2_Bk_via_Oc[simp]: "wcode_erase2 ires rs (b, Oc # list)
        \<Longrightarrow> wcode_erase2 ires rs (b, Bk # list)"
   apply(auto simp: wcode_fourtimes_invs)
   done
 
 lemma wcode_goon_right_moving_2_Oc_move[simp]:
   "wcode_on_right_moving_2 ires rs (b, Oc # list)
        \<Longrightarrow> wcode_goon_right_moving_2 ires rs (Oc # b, list)"
   apply(auto simp: wcode_fourtimes_invs)
   apply(rule_tac x = "Suc 0" in exI, auto)
   apply(rule_tac x = "ml - 2" in exI)
   apply(case_tac ml, simp, case_tac "ml - 1", simp_all)
   done
 
 lemma wcode_backto_standard_pos_2_exists[simp]: "wcode_backto_standard_pos_2 ires rs (b, Bk # list)
        \<Longrightarrow> (\<exists>ln. b = Bk # Bk\<up>(ln) @ Oc # ires) \<and> (\<exists>rn. list = Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rn))"
   by(simp add: wcode_fourtimes_invs)
 
 lemma wcode_goon_right_moving_2_move_Oc[simp]: "wcode_goon_right_moving_2 ires rs (b, Oc # list) \<Longrightarrow>
        wcode_goon_right_moving_2 ires rs (Oc # b, list)"
   apply(simp only:wcode_fourtimes_invs, auto)
   apply(rename_tac ml ln mr rn)
   apply(case_tac mr;force)
   done
 
 
 lemma wcode_backto_standard_pos_2_Oc_mv_hd[simp]:
   "wcode_backto_standard_pos_2 ires rs (b, Oc # list)    
             \<Longrightarrow> wcode_backto_standard_pos_2 ires rs (tl b, hd b # Oc # list)"
   apply(simp only: wcode_fourtimes_invs)
   apply(erule_tac disjE)
    apply(erule_tac exE)+ apply(rename_tac ml mr ln rn)
   by (case_tac ml, force,force,force)
 
 lemma nonempty_fst[simp]:
   "wcode_on_left_moving_2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
   "wcode_on_checking_2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
   "wcode_goon_checking ires rs (b, Bk # list) = False"
   "wcode_right_move ires rs (b, Bk # list) \<Longrightarrow> b\<noteq> []" 
   "wcode_erase2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
   "wcode_on_right_moving_2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
   "wcode_goon_right_moving_2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
   "wcode_backto_standard_pos_2 ires rs (b, Bk # list) \<Longrightarrow>  b \<noteq> []"
   "wcode_on_left_moving_2 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
   "wcode_goon_right_moving_2 ires rs (b, []) \<Longrightarrow> b \<noteq> []"
   "wcode_erase2 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
   "wcode_on_right_moving_2 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
   "wcode_goon_right_moving_2 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
   "wcode_backto_standard_pos_2 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
   by(auto simp: wcode_fourtimes_invs)
 
 
 lemma wcode_fourtimes_case_first_correctness:
-  shows "let P = (\<lambda> (st, l, r). st = t_twice_len + 14) in 
+  shows "let P = (\<lambda> (st, l, r). st = twice_tm_len + 14) in 
   let Q = (\<lambda> (st, l, r). wcode_fourtimes_case_inv st ires rs (l, r)) in 
-  let f = (\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp) in
+  let f = (\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp) in
   \<exists> n .P (f n) \<and> Q (f (n::nat))"
 proof -
-  let ?P = "(\<lambda> (st, l, r). st = t_twice_len + 14)"
+  let ?P = "(\<lambda> (st, l, r). st = twice_tm_len + 14)"
   let ?Q = "(\<lambda> (st, l, r). wcode_fourtimes_case_inv st ires rs (l, r))"
-  let ?f = "(\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp)"
+  let ?f = "(\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp)"
   have "\<exists> n . ?P (?f n) \<and> ?Q (?f (n::nat))"
   proof(rule_tac halt_lemma2)
     show "wf wcode_fourtimes_case_le"
       by auto
   next
     have "\<not> ?P (?f na) \<and> ?Q (?f na) \<longrightarrow>
                   ?Q (?f (Suc na)) \<and> (?f (Suc na), ?f na) \<in> wcode_fourtimes_case_le" for na
       apply(cases "?f na", rule_tac impI)
-      apply(simp add: step_red step.simps)
+      apply(simp add: step.simps)
       apply(case_tac "snd (snd (?f na))", simp, case_tac [2] "hd (snd (snd (?f na)))", simp_all)
         apply(simp_all add: wcode_fourtimes_case_inv.simps
           wcode_fourtimes_case_le_def lex_pair_def split: if_splits)
       by(auto simp: wcode_backto_standard_pos_2.simps wcode_backto_standard_pos_2_O.simps
           wcode_backto_standard_pos_2_B.simps gr0_conv_Suc)
     thus "\<forall> na. \<not> ?P (?f na) \<and> ?Q (?f na) \<longrightarrow>
                   ?Q (?f (Suc na)) \<and> (?f (Suc na), ?f na) \<in> wcode_fourtimes_case_le" by auto
   next
     show "?Q (?f 0)"
       apply(simp add: steps.simps wcode_fourtimes_case_inv.simps)
       apply(simp add: wcode_on_left_moving_2.simps wcode_on_left_moving_2_B.simps 
           wcode_on_left_moving_2_O.simps)
       apply(rule_tac x = "Suc m" in exI, simp )
       apply(rule_tac x ="Suc 0" in exI, auto)
       done
   next
     show "\<not> ?P (?f 0)"
       apply(simp add: steps.simps)
       done
   qed
   thus "?thesis"
     apply(erule_tac exE, simp)
     done
 qed
 
-definition t_fourtimes_len :: "nat"
+definition fourtimes_tm_len :: "nat"
   where
-    "t_fourtimes_len = (length t_fourtimes div 2)"
+    "fourtimes_tm_len = (length fourtimes_tm div 2)"
 
 lemma primerec_rec_fourtimes_1[intro]: "primerec rec_fourtimes (Suc 0)"
   apply(auto simp: rec_fourtimes_def numeral_4_eq_4 constn.simps)
   by auto
 
 lemma fourtimes_lemma: "rec_exec rec_fourtimes [rs] = 4 * rs"
   by(simp add: rec_exec.simps rec_fourtimes_def)
 
-lemma t_fourtimes_correct: 
+lemma fourtimes_tm_correct: 
   "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) 
-    (tm_of abc_fourtimes @ shift (mopup 1) (length (tm_of abc_fourtimes) div 2)) stp =
+    (tm_of abc_fourtimes @ shift (mopup_n_tm 1) (length (tm_of abc_fourtimes) div 2)) stp =
        (0, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))"
 proof(case_tac "rec_ci rec_fourtimes")
   fix a b c
   assume h: "rec_ci rec_fourtimes = (a, b, c)"
-  have "\<exists>stp m l. steps0 (Suc 0, Bk # Bk # ires, <[rs]> @ Bk\<up>(n)) (tm_of abc_fourtimes @ shift (mopup (length [rs])) 
+  have "\<exists>stp m l. steps0 (Suc 0, Bk # Bk # ires, <[rs]> @ Bk\<up>(n)) (tm_of abc_fourtimes @ shift (mopup_n_tm (length [rs])) 
     (length (tm_of abc_fourtimes) div 2)) stp = (0, Bk\<up>(m) @ Bk # Bk # ires, Oc\<up>(Suc (rec_exec rec_fourtimes [rs])) @ Bk\<up>(l))"
     thm recursive_compile_to_tm_correct1
   proof(rule_tac recursive_compile_to_tm_correct1)
     show "rec_ci rec_fourtimes = (a, b, c)" by (simp add: h)
   next
     show "terminate rec_fourtimes [rs]"
       apply(rule_tac primerec_terminate)
       by auto
   next
     show "tm_of abc_fourtimes = tm_of (a [+] dummy_abc (length [rs]))"
       using h
       by(simp add: abc_fourtimes_def)
   qed
   thus "?thesis"
     apply(simp add: tape_of_list_def tape_of_nat_def fourtimes_lemma)
     done
 qed
 
-lemma wf_fourtimes[intro]: "tm_wf (t_fourtimes_compile, 0)"
-  apply(simp only: t_fourtimes_compile_def)
-  apply(rule_tac wf_tm_from_abacus, simp)
+lemma composable_fourtimes_tm[intro]: "composable_tm (fourtimes_compile_tm, 0)"
+  apply(simp only: fourtimes_compile_tm_def)
+  apply(rule_tac composable_tm_from_abacus, simp)
   done
 
-lemma t_fourtimes_change_term_state:
-  "\<exists> stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) t_fourtimes stp
-     = (Suc t_fourtimes_len, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))"
+lemma fourtimes_tm_change_term_state:
+  "\<exists> stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) fourtimes_tm stp
+     = (Suc fourtimes_tm_len, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))"
 proof -
   have "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) 
-    (tm_of abc_fourtimes @ shift (mopup 1) ((length (tm_of abc_fourtimes) div 2))) stp =
+    (tm_of abc_fourtimes @ shift (mopup_n_tm 1) ((length (tm_of abc_fourtimes) div 2))) stp =
     (0, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))"
-    by(rule_tac t_fourtimes_correct)
+    by(rule_tac fourtimes_tm_correct)
   then obtain stp ln rn where 
     "steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) 
-    (tm_of abc_fourtimes @ shift (mopup 1) ((length (tm_of abc_fourtimes) div 2))) stp =
+    (tm_of abc_fourtimes @ shift (mopup_n_tm 1) ((length (tm_of abc_fourtimes) div 2))) stp =
     (0, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))" by blast
   hence "\<exists> stp. steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
-    (adjust0 t_fourtimes_compile) stp
-     = (Suc (length t_fourtimes_compile div 2), Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))"
+    (adjust0 fourtimes_compile_tm) stp
+     = (Suc (length fourtimes_compile_tm div 2), Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))"
     apply(rule_tac stp = stp in adjust_halt_eq)
-     apply(simp add: t_fourtimes_compile_def, auto)
+     apply(simp add: fourtimes_compile_tm_def, auto)
     done
   then obtain stpb where 
     "steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
-    (adjust0 t_fourtimes_compile) stpb
-     = (Suc (length t_fourtimes_compile div 2), Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))" ..
+    (adjust0 fourtimes_compile_tm) stpb
+     = (Suc (length fourtimes_compile_tm div 2), Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))" ..
   thus "?thesis"
-    apply(simp add: t_fourtimes_def t_fourtimes_len_def)
+    apply(simp add: fourtimes_tm_def fourtimes_tm_len_def)
     by metis
 qed
 
-lemma length_t_twice_even[intro]: "is_even (length t_twice)"
-  by(auto simp: t_twice_def t_twice_compile_def intro!:mopup_mod2)
-
-lemma t_fourtimes_append_pre:
-  "steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) t_fourtimes stp
-  = (Suc t_fourtimes_len, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))
-   \<Longrightarrow> steps0 (Suc 0 + length (t_wcode_main_first_part @ 
-              shift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2,
+lemma length_twice_tm_even[intro]: "is_even (length twice_tm)"
+  by(auto simp: twice_tm_def twice_compile_tm_def intro!:mopup_mod2)
+
+lemma fourtimes_tm_append_pre:
+  "steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n)) fourtimes_tm stp
+  = (Suc fourtimes_tm_len, Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))
+   \<Longrightarrow> steps0 (Suc 0 + length (wcode_main_first_part_tm @ 
+              shift twice_tm (length wcode_main_first_part_tm div 2) @ [(L, 1), (L, 1)]) div 2,
        Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
-     ((t_wcode_main_first_part @ 
-  shift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) @ 
-  shift t_fourtimes (length (t_wcode_main_first_part @ 
-  shift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2) @ ([(L, 1), (L, 1)])) stp 
-  = ((Suc t_fourtimes_len) + length (t_wcode_main_first_part @ 
-  shift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2,
+     ((wcode_main_first_part_tm @ 
+  shift twice_tm (length wcode_main_first_part_tm div 2) @ [(L, 1), (L, 1)]) @ 
+  shift fourtimes_tm (length (wcode_main_first_part_tm @ 
+  shift twice_tm (length wcode_main_first_part_tm div 2) @ [(L, 1), (L, 1)]) div 2) @ ([(L, 1), (L, 1)])) stp 
+  = ((Suc fourtimes_tm_len) + length (wcode_main_first_part_tm @ 
+  shift twice_tm (length wcode_main_first_part_tm div 2) @ [(L, 1), (L, 1)]) div 2,
   Bk\<up>(ln) @ Bk # Bk # ires, Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))"
-  using length_t_twice_even
+  using length_twice_tm_even
   by(intro tm_append_shift_append_steps, auto)
 
 lemma split_26_even[simp]: "(26 + l::nat) div 2 = l div 2 + 13" by(simp)
 
-lemma t_twice_len_plust_14[simp]: "t_twice_len + 14 =  14 + length (shift t_twice 12) div 2"
-  apply(simp add: t_twice_def t_twice_len_def)
+lemma twice_tm_len_plus_14[simp]: "twice_tm_len + 14 =  14 + length (shift twice_tm 12) div 2"
+  apply(simp add: twice_tm_def twice_tm_len_def)
   done
 
-lemma t_fourtimes_append:
+lemma fourtimes_tm_append:
   "\<exists> stp ln rn. 
-  steps0 (Suc 0 + length (t_wcode_main_first_part @ shift t_twice
-  (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2, 
+  steps0 (Suc 0 + length (wcode_main_first_part_tm @ shift twice_tm
+  (length wcode_main_first_part_tm div 2) @ [(L, 1), (L, 1)]) div 2, 
   Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
-  ((t_wcode_main_first_part @ shift t_twice (length t_wcode_main_first_part div 2) @
-  [(L, 1), (L, 1)]) @ shift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)]) stp 
-  = (Suc t_fourtimes_len + length (t_wcode_main_first_part @ shift t_twice
-  (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2, Bk\<up>(ln) @ Bk # Bk # ires,
+  ((wcode_main_first_part_tm @ shift twice_tm (length wcode_main_first_part_tm div 2) @
+  [(L, 1), (L, 1)]) @ shift fourtimes_tm (twice_tm_len + 13) @ [(L, 1), (L, 1)]) stp 
+  = (Suc fourtimes_tm_len + length (wcode_main_first_part_tm @ shift twice_tm
+  (length wcode_main_first_part_tm div 2) @ [(L, 1), (L, 1)]) div 2, Bk\<up>(ln) @ Bk # Bk # ires,
                                                                  Oc\<up>(Suc (4 * rs)) @ Bk\<up>(rn))"
-  using t_fourtimes_change_term_state[of ires rs n]
+  using fourtimes_tm_change_term_state[of ires rs n]
   apply(erule_tac exE)
   apply(erule_tac exE)
   apply(erule_tac exE)
-  apply(drule_tac t_fourtimes_append_pre)
+  apply(drule_tac fourtimes_tm_append_pre)
   apply(rule_tac x = stp in exI, rule_tac x = ln in exI, rule_tac x = rn in exI)
-  apply(simp add: t_twice_len_def)
+  apply(simp add: twice_tm_len_def)
   done
 
-lemma even_fourtimes_len: "length t_fourtimes mod 2 = 0"
-  apply(auto simp: t_fourtimes_def t_fourtimes_compile_def)
+lemma even_fourtimes_len: "length fourtimes_tm mod 2 = 0"
+  apply(auto simp: fourtimes_tm_def fourtimes_compile_tm_def)
   by (metis mopup_mod2)
 
-lemma t_twice_even[simp]: "2 * (length t_twice div 2) = length t_twice"
-  using length_t_twice_even by arith
-
-lemma t_fourtimes_even[simp]: "2 * (length t_fourtimes div 2) = length t_fourtimes"
+lemma twice_tm_even[simp]: "2 * (length twice_tm div 2) = length twice_tm"
+  using length_twice_tm_even by arith
+
+lemma fourtimes_tm_even[simp]: "2 * (length fourtimes_tm div 2) = length fourtimes_tm"
   using even_fourtimes_len
   by arith
 
-lemma fetch_t_wcode_14_Oc: "fetch t_wcode_main (14 + length t_twice div 2 + t_fourtimes_len) Oc
+lemma fetch_wcode_tm_14_Oc: "fetch wcode_main_tm (14 + length twice_tm div 2 + fourtimes_tm_len) Oc
              = (L, Suc 0)" 
   apply(subgoal_tac "14 = Suc 13")
-   apply(simp only: fetch.simps add_Suc nth_of.simps t_wcode_main_def)
-   apply(simp add:length_t_twice_even t_fourtimes_len_def nth_append)
+   apply(simp only: fetch.simps add_Suc nth_of.simps wcode_main_tm_def)
+   apply(simp add:length_twice_tm_even fourtimes_tm_len_def nth_append)
   by arith
 
-lemma fetch_t_wcode_14_Bk: "fetch t_wcode_main (14 + length t_twice div 2 + t_fourtimes_len) Bk
+lemma fetch_wcode_tm_14_Bk: "fetch wcode_main_tm (14 + length twice_tm div 2 + fourtimes_tm_len) Bk
              = (L, Suc 0)"
   apply(subgoal_tac "14 = Suc 13")
-   apply(simp only: fetch.simps add_Suc nth_of.simps t_wcode_main_def)
-   apply(simp add:length_t_twice_even t_fourtimes_len_def nth_append)
+   apply(simp only: fetch.simps add_Suc nth_of.simps wcode_main_tm_def)
+   apply(simp add:length_twice_tm_even fourtimes_tm_len_def nth_append)
   by arith
 
-lemma fetch_t_wcode_14 [simp]: "fetch t_wcode_main (14 + length t_twice div 2 + t_fourtimes_len) b
+lemma fetch_wcode_tm_14 [simp]: "fetch wcode_main_tm (14 + length twice_tm div 2 + fourtimes_tm_len) b
              = (L, Suc 0)"
-  apply(case_tac b, simp_all add:fetch_t_wcode_14_Bk fetch_t_wcode_14_Oc)
+  apply(case_tac b, simp_all add:fetch_wcode_tm_14_Bk fetch_wcode_tm_14_Oc)
   done
 
 lemma wcode_jump2: 
-  "\<exists> stp ln rn. steps0 (t_twice_len + 14 + t_fourtimes_len
-  , Bk # Bk # Bk\<up>(lnb) @ Oc # ires, Oc\<up>(Suc (4 * rs + 4)) @ Bk\<up>(rnb)) t_wcode_main stp =
+  "\<exists> stp ln rn. steps0 (twice_tm_len + 14 + fourtimes_tm_len
+  , Bk # Bk # Bk\<up>(lnb) @ Oc # ires, Oc\<up>(Suc (4 * rs + 4)) @ Bk\<up>(rnb)) wcode_main_tm stp =
   (Suc 0, Bk # Bk\<up>(ln) @ Oc # ires, Bk # Oc\<up>(Suc (4 * rs + 4)) @ Bk\<up>(rn))"
   apply(rule_tac x = "Suc 0" in exI)
   apply(simp add: steps.simps)
   apply(rule_tac x = lnb in exI, rule_tac x = rnb in exI)
   apply(simp add: step.simps)
   done
 
 lemma wcode_fourtimes_case:
   shows "\<exists>stp ln rn.
-  steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+  steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
   (Suc 0, Bk # Bk\<up>(ln) @ Oc # ires, Bk # Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rn))"
 proof -
   have "\<exists>stp ln rn.
-  steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
-  (t_twice_len + 14, Bk # Bk # Bk\<up>(ln) @ Oc # ires, Oc\<up>(Suc (rs + 1)) @ Bk\<up>(rn))"
+  steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
+  (twice_tm_len + 14, Bk # Bk # Bk\<up>(ln) @ Oc # ires, Oc\<up>(Suc (rs + 1)) @ Bk\<up>(rn))"
     using wcode_fourtimes_case_first_correctness[of ires rs m n]
     by (auto simp add: wcode_fourtimes_case_inv.simps) auto
   from this obtain stpa lna rna where stp1:
-    "steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stpa =
-  (t_twice_len + 14, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (rs + 1)) @ Bk\<up>(rna))" by blast
-  have "\<exists>stp ln rn. steps0 (t_twice_len + 14, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (rs + 1)) @ Bk\<up>(rna))
-                     t_wcode_main stp =
-          (t_twice_len + 14 + t_fourtimes_len, Bk # Bk # Bk\<up>(ln) @ Oc # ires,  Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rn))"
-    using t_fourtimes_append[of " Bk\<up>(lna) @ Oc # ires" "rs + 1" rna]
+    "steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Oc # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stpa =
+  (twice_tm_len + 14, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (rs + 1)) @ Bk\<up>(rna))" by blast
+  have "\<exists>stp ln rn. steps0 (twice_tm_len + 14, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (rs + 1)) @ Bk\<up>(rna))
+                     wcode_main_tm stp =
+          (twice_tm_len + 14 + fourtimes_tm_len, Bk # Bk # Bk\<up>(ln) @ Oc # ires,  Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rn))"
+    using fourtimes_tm_append[of " Bk\<up>(lna) @ Oc # ires" "rs + 1" rna]
     apply(erule_tac exE)
     apply(erule_tac exE)
     apply(erule_tac exE)
-    apply(simp add: t_wcode_main_def) apply(rename_tac stp ln rn)
+    apply(simp add: wcode_main_tm_def) apply(rename_tac stp ln rn)
     apply(rule_tac x = stp in exI, 
         rule_tac x = "ln + lna" in exI,
         rule_tac x = rn in exI, simp)
     apply(simp add: replicate_Suc[THEN sym] replicate_add[THEN sym] del: replicate_Suc)
     done
   from this obtain stpb lnb rnb where stp2:
-    "steps0 (t_twice_len + 14, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (rs + 1)) @ Bk\<up>(rna))
-                     t_wcode_main stpb =
-       (t_twice_len + 14 + t_fourtimes_len, Bk # Bk # Bk\<up>(lnb) @ Oc # ires,  Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rnb))"
+    "steps0 (twice_tm_len + 14, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (rs + 1)) @ Bk\<up>(rna))
+                     wcode_main_tm stpb =
+       (twice_tm_len + 14 + fourtimes_tm_len, Bk # Bk # Bk\<up>(lnb) @ Oc # ires,  Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rnb))"
     by blast
-  have "\<exists>stp ln rn. steps0 (t_twice_len + 14 + t_fourtimes_len,
+  have "\<exists>stp ln rn. steps0 (twice_tm_len + 14 + fourtimes_tm_len,
     Bk # Bk # Bk\<up>(lnb) @ Oc # ires,  Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rnb))
-    t_wcode_main stp =
+    wcode_main_tm stp =
     (Suc 0, Bk # Bk\<up>(ln) @ Oc # ires, Bk # Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rn))"
     apply(rule wcode_jump2)
     done
   from this obtain stpc lnc rnc where stp3: 
-    "steps0 (t_twice_len + 14 + t_fourtimes_len,
+    "steps0 (twice_tm_len + 14 + fourtimes_tm_len,
     Bk # Bk # Bk\<up>(lnb) @ Oc # ires,  Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rnb))
-    t_wcode_main stpc =
+    wcode_main_tm stpc =
     (Suc 0, Bk # Bk\<up>(lnc) @ Oc # ires, Bk # Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rnc))"
     by blast
   from stp1 stp2 stp3 show "?thesis"
     apply(rule_tac x = "stpa + stpb + stpc" in exI,
         rule_tac x = lnc in exI, rule_tac x = rnc in exI)
     apply(simp)
     done
 qed
 
 fun wcode_on_left_moving_3_B :: "bin_inv_t"
   where
     "wcode_on_left_moving_3_B ires rs (l, r) = 
        (\<exists> ml mr rn. l = Bk\<up>(ml) @ Oc # Bk # Bk # ires \<and>
                     r = Bk\<up>(mr) @ Oc\<up>(Suc rs) @ Bk\<up>(rn) \<and> 
                     ml + mr > Suc 0 \<and> mr > 0 )"
 
 fun wcode_on_left_moving_3_O :: "bin_inv_t"
   where
     "wcode_on_left_moving_3_O ires rs (l, r) = 
          (\<exists> ln rn. l = Bk # Bk # ires \<and>
                    r = Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wcode_on_left_moving_3 :: "bin_inv_t"
   where
     "wcode_on_left_moving_3 ires rs (l, r) = 
        (wcode_on_left_moving_3_B ires rs (l, r) \<or>  
         wcode_on_left_moving_3_O ires rs (l, r))"
 
 fun wcode_on_checking_3 :: "bin_inv_t"
   where
     "wcode_on_checking_3 ires rs (l, r) = 
          (\<exists> ln rn. l = Bk # ires \<and>
              r = Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wcode_goon_checking_3 :: "bin_inv_t"
   where
     "wcode_goon_checking_3 ires rs (l, r) = 
          (\<exists> ln rn. l = ires \<and>
              r = Bk # Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wcode_stop :: "bin_inv_t"
   where
     "wcode_stop ires rs (l, r) = 
           (\<exists> ln rn. l = Bk # ires \<and>
              r = Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wcode_halt_case_inv :: "nat \<Rightarrow> bin_inv_t"
   where
     "wcode_halt_case_inv st ires rs (l, r) = 
           (if st = 0 then wcode_stop ires rs (l, r)
            else if st = Suc 0 then wcode_on_left_moving_3 ires rs (l, r)
            else if st = Suc (Suc 0) then wcode_on_checking_3 ires rs (l, r)
            else if st = 7 then wcode_goon_checking_3 ires rs (l, r)
            else False)"
 
 fun wcode_halt_case_state :: "config \<Rightarrow> nat"
   where
     "wcode_halt_case_state (st, l, r) = 
            (if st = 1 then 5
             else if st = Suc (Suc 0) then 4
             else if st = 7 then 3
             else 0)"
 
 fun wcode_halt_case_step :: "config \<Rightarrow> nat"
   where
     "wcode_halt_case_step (st, l, r) = 
          (if st = 1 then length l
          else 0)"
 
 fun wcode_halt_case_measure :: "config \<Rightarrow> nat \<times> nat"
   where
     "wcode_halt_case_measure (st, l, r) = 
      (wcode_halt_case_state (st, l, r), 
       wcode_halt_case_step (st, l, r))"
 
 definition wcode_halt_case_le :: "(config \<times> config) set"
   where "wcode_halt_case_le \<equiv> (inv_image lex_pair wcode_halt_case_measure)"
 
 lemma wf_wcode_halt_case_le[intro]: "wf wcode_halt_case_le"
   by(auto simp: wcode_halt_case_le_def)
 
 declare wcode_on_left_moving_3_B.simps[simp del] wcode_on_left_moving_3_O.simps[simp del]  
   wcode_on_checking_3.simps[simp del] wcode_goon_checking_3.simps[simp del] 
   wcode_on_left_moving_3.simps[simp del] wcode_stop.simps[simp del]
 
 lemmas wcode_halt_invs = 
   wcode_on_left_moving_3_B.simps wcode_on_left_moving_3_O.simps
   wcode_on_checking_3.simps wcode_goon_checking_3.simps 
   wcode_on_left_moving_3.simps wcode_stop.simps
 
 
 lemma wcode_on_left_moving_3_mv_Bk[simp]: "wcode_on_left_moving_3 ires rs (b, Bk # list)
  \<Longrightarrow> wcode_on_left_moving_3 ires rs (tl b, hd b # Bk # list)"
   apply(simp only: wcode_halt_invs)
   apply(erule_tac disjE)
    apply(erule_tac exE)+ apply(rename_tac ml mr rn)
    apply(case_tac ml, simp)
     apply(rule_tac x = "mr - 2" in exI, rule_tac x = rn in exI)
     apply(case_tac mr, force, simp add: exp_ind del: replicate_Suc)
     apply(case_tac "mr - 1", force, simp add: exp_ind del: replicate_Suc)
    apply force
   apply force
   done
 
 lemma wcode_goon_checking_3_cases[simp]: "wcode_goon_checking_3 ires rs (b, Bk # list) \<Longrightarrow> 
   (b = [] \<longrightarrow> wcode_stop ires rs ([Bk], list)) \<and>
   (b \<noteq> [] \<longrightarrow> wcode_stop ires rs (Bk # b, list))"
   apply(auto simp: wcode_halt_invs)
   done
 
 lemma wcode_on_checking_3_mv_Oc[simp]: "wcode_on_left_moving_3 ires rs (b, Oc # list) \<Longrightarrow> 
                wcode_on_checking_3 ires rs (tl b, hd b # Oc # list)"
   by(simp add:wcode_halt_invs)
 
 lemma wcode_3_nonempty[simp]:
   "wcode_on_left_moving_3 ires rs (b, []) = False"
   "wcode_on_checking_3 ires rs (b, []) = False"
   "wcode_goon_checking_3 ires rs (b, []) = False"
   "wcode_on_left_moving_3 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
   "wcode_on_checking_3 ires rs (b, Oc # list) = False"
   "wcode_on_left_moving_3 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
   "wcode_on_checking_3 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
   "wcode_goon_checking_3 ires rs (b, Oc # list) = False"
   by(auto simp: wcode_halt_invs)
 
 lemma wcode_goon_checking_3_mv_Bk[simp]: "wcode_on_checking_3 ires rs (b, Bk # list) \<Longrightarrow> 
   wcode_goon_checking_3 ires rs (tl b, hd b # Bk # list)"
   apply(auto simp: wcode_halt_invs)
   done
 
 lemma t_halt_case_correctness: 
   shows "let P = (\<lambda> (st, l, r). st = 0) in 
        let Q = (\<lambda> (st, l, r). wcode_halt_case_inv st ires rs (l, r)) in 
-       let f = (\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp) in
+       let f = (\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp) in
        \<exists> n .P (f n) \<and> Q (f (n::nat))"
 proof -
   let ?P = "(\<lambda> (st, l, r). st = 0)"
   let ?Q = "(\<lambda> (st, l, r). wcode_halt_case_inv st ires rs (l, r))"
-  let ?f = "(\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp)"
+  let ?f = "(\<lambda> stp. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp)"
   have "\<exists> n. ?P (?f n) \<and> ?Q (?f (n::nat))"
   proof(rule_tac halt_lemma2)
     show "wf wcode_halt_case_le" by auto
   next
     { fix na
       obtain a b c where abc:"?f na = (a,b,c)" by(cases "?f na",auto)
       hence "\<not> ?P (?f na) \<and> ?Q (?f na) \<Longrightarrow>
                     ?Q (?f (Suc na)) \<and> (?f (Suc na), ?f na) \<in> wcode_halt_case_le"
         apply(simp add: step.simps)
         apply(cases c;cases "hd c")
            apply(auto simp: wcode_halt_case_le_def lex_pair_def split: if_splits)
         done
     }
     thus "\<forall> na. \<not> ?P (?f na) \<and> ?Q (?f na) \<longrightarrow> 
                     ?Q (?f (Suc na)) \<and> (?f (Suc na), ?f na) \<in> wcode_halt_case_le" by blast     
   next 
     show "?Q (?f 0)"
       apply(simp add: steps.simps wcode_halt_invs)
       apply(rule_tac x = "Suc m" in exI, simp)
       apply(rule_tac x = "Suc 0" in exI, auto)
       done
   next
     show "\<not> ?P (?f 0)"
       apply(simp add: steps.simps)
       done
   qed
   thus "?thesis"
     apply(auto)
     done
 qed
 
 declare wcode_halt_case_inv.simps[simp del]
 lemma leading_Oc[intro]: "\<exists> xs. (<rev list @ [aa::nat]> :: cell list) = Oc # xs"
   apply(case_tac "rev list", simp)
   apply(simp add: tape_of_nl_cons)
   done
 
 lemma wcode_halt_case:
   "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n))
-  t_wcode_main stp  = (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
+  wcode_main_tm stp  = (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 proof -
   let ?P = "\<lambda>(st, l, r). st = 0"
   let ?Q = "\<lambda>(st, l, r). wcode_halt_case_inv st ires rs (l, r)"
-  let ?f = "steps0 (Suc 0, Bk # Bk \<up> m @ Oc # Bk # Bk # ires, Bk # Oc \<up> Suc rs @ Bk \<up> n) t_wcode_main"
+  let ?f = "steps0 (Suc 0, Bk # Bk \<up> m @ Oc # Bk # Bk # ires, Bk # Oc \<up> Suc rs @ Bk \<up> n) wcode_main_tm"
   from t_halt_case_correctness[of ires rs m n] obtain n where "?P (?f n) \<and> ?Q (?f n)" by metis
   thus ?thesis
     apply(simp add: wcode_halt_case_inv.simps wcode_stop.simps)
     apply(case_tac "steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # Bk # ires,
-                Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main n")
+                Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm n")
     apply(auto simp: wcode_halt_case_inv.simps wcode_stop.simps)
     by auto
 qed
 
 lemma bl_bin_one[simp]: "bl_bin [Oc] = 1"
   apply(simp add: bl_bin.simps)
   done
 
 lemma twice_power[intro]: "2 * 2 ^ a = Suc (Suc (2 * bl_bin (Oc \<up> a)))"
   apply(induct a, auto simp: bl_bin.simps)
   done
 declare replicate_Suc[simp del]
 
-lemma t_wcode_main_lemma_pre:
+lemma wcode_main_tm_lemma_pre:
   "\<lbrakk>args \<noteq> []; lm = <args::nat list>\<rbrakk> \<Longrightarrow> 
-       \<exists> stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(m) @ rev lm @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main
+       \<exists> stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(m) @ rev lm @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm
                     stp
       = (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(bl_bin lm + rs * 2^(length lm - 1) ) @ Bk\<up>(rn))"
 proof(induct "length args" arbitrary: args lm rs m n, simp)
   fix x args lm rs m n
   assume ind:
     "\<And>args lm rs m n.
     \<lbrakk>x = length args; (args::nat list) \<noteq> []; lm = <args>\<rbrakk>
     \<Longrightarrow> \<exists>stp ln rn.
-    steps0 (Suc 0, Bk # Bk\<up>(m) @ rev lm @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+    steps0 (Suc 0, Bk # Bk\<up>(m) @ rev lm @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
     (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(bl_bin lm + rs * 2 ^ (length lm - 1)) @ Bk\<up>(rn))"
     and h: "Suc x = length args" "(args::nat list) \<noteq> []" "lm = <args>"
   from h have "\<exists> (a::nat) xs. args = xs @ [a]"
     apply(rule_tac x = "last args" in exI)
     apply(rule_tac x = "butlast args" in exI, auto)
     done    
   from this obtain a xs where "args = xs @ [a]" by blast
   from h and this show
     "\<exists>stp ln rn.
-    steps0 (Suc 0, Bk # Bk\<up>(m) @ rev lm @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+    steps0 (Suc 0, Bk # Bk\<up>(m) @ rev lm @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
     (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(bl_bin lm + rs * 2 ^ (length lm - 1)) @ Bk\<up>(rn))"
   proof(case_tac "xs::nat list", simp)
     show "\<exists>stp ln rn.
-          steps0 (Suc 0, Bk # Bk \<up> m @ Oc \<up> Suc a @ Bk # Bk # ires, Bk # Oc \<up> Suc rs @ Bk \<up> n) t_wcode_main stp =
+          steps0 (Suc 0, Bk # Bk \<up> m @ Oc \<up> Suc a @ Bk # Bk # ires, Bk # Oc \<up> Suc rs @ Bk \<up> n) wcode_main_tm stp =
           (0, Bk # ires, Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> (bl_bin (Oc \<up> Suc a) + rs * 2 ^ a) @ Bk \<up> rn)"
     proof(induct "a" arbitrary: m n rs ires, simp)
       fix m n rs ires
       show "\<exists>stp ln rn.
-          steps0 (Suc 0, Bk # Bk \<up> m @ Oc # Bk # Bk # ires, Bk # Oc \<up> Suc rs @ Bk \<up> n) t_wcode_main stp =
+          steps0 (Suc 0, Bk # Bk \<up> m @ Oc # Bk # Bk # ires, Bk # Oc \<up> Suc rs @ Bk \<up> n) wcode_main_tm stp =
           (0, Bk # ires, Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> Suc rs @ Bk \<up> rn)"
         apply(rule_tac wcode_halt_case)
         done
     next
       fix a m n rs ires
       assume ind2:
         "\<And>m n rs ires.
            \<exists>stp ln rn.
-              steps0 (Suc 0, Bk # Bk \<up> m @ Oc \<up> Suc a @ Bk # Bk # ires, Bk # Oc \<up> Suc rs @ Bk \<up> n) t_wcode_main stp =
+              steps0 (Suc 0, Bk # Bk \<up> m @ Oc \<up> Suc a @ Bk # Bk # ires, Bk # Oc \<up> Suc rs @ Bk \<up> n) wcode_main_tm stp =
               (0, Bk # ires, Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> (bl_bin (Oc \<up> Suc a) + rs * 2 ^ a) @ Bk \<up> rn)"
       show " \<exists>stp ln rn.
-          steps0 (Suc 0, Bk # Bk \<up> m @ Oc \<up> Suc (Suc a) @ Bk # Bk # ires, Bk # Oc \<up> Suc rs @ Bk \<up> n) t_wcode_main stp =
+          steps0 (Suc 0, Bk # Bk \<up> m @ Oc \<up> Suc (Suc a) @ Bk # Bk # ires, Bk # Oc \<up> Suc rs @ Bk \<up> n) wcode_main_tm stp =
           (0, Bk # ires, Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> (bl_bin (Oc \<up> Suc (Suc a)) + rs * 2 ^ Suc a) @ Bk \<up> rn)"
       proof -
         have "\<exists>stp ln rn.
-          steps0 (Suc 0, Bk # Bk\<up>(m) @ rev (<Suc a>) @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+          steps0 (Suc 0, Bk # Bk\<up>(m) @ rev (<Suc a>) @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
           (Suc 0, Bk # Bk\<up>(ln) @ rev (<a>) @ Bk # Bk # ires, Bk # Oc\<up>(Suc (2 * rs + 2)) @ Bk\<up>(rn))"
           apply(simp add: tape_of_nat)
           using wcode_double_case[of m "Oc\<up>(a) @ Bk # Bk # ires" rs n]
           apply(simp add: replicate_Suc)
           done
         from this obtain stpa lna rna where stp1:  
-          "steps0 (Suc 0, Bk # Bk\<up>(m) @ rev (<Suc a>) @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stpa =
+          "steps0 (Suc 0, Bk # Bk\<up>(m) @ rev (<Suc a>) @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stpa =
           (Suc 0, Bk # Bk\<up>(lna) @ rev (<a>) @ Bk # Bk # ires, Bk # Oc\<up>(Suc (2 * rs + 2)) @ Bk\<up>(rna))" by blast
         moreover have 
           "\<exists>stp ln rn.
-          steps0 (Suc 0,  Bk # Bk\<up>(lna) @ rev (<a::nat>) @ Bk # Bk # ires, Bk # Oc\<up>(Suc (2 * rs + 2)) @ Bk\<up>(rna)) t_wcode_main stp =
+          steps0 (Suc 0,  Bk # Bk\<up>(lna) @ rev (<a::nat>) @ Bk # Bk # ires, Bk # Oc\<up>(Suc (2 * rs + 2)) @ Bk\<up>(rna)) wcode_main_tm stp =
           (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(bl_bin (<a>) + (2*rs + 2)  * 2 ^ a) @ Bk\<up>(rn))"
           using ind2[of lna ires "2*rs + 2" rna] by(simp add: tape_of_list_def tape_of_nat_def)   
         from this obtain stpb lnb rnb where stp2:  
-          "steps0 (Suc 0,  Bk # Bk\<up>(lna) @ rev (<a>) @ Bk # Bk # ires, Bk # Oc\<up>(Suc (2 * rs + 2)) @ Bk\<up>(rna)) t_wcode_main stpb =
+          "steps0 (Suc 0,  Bk # Bk\<up>(lna) @ rev (<a>) @ Bk # Bk # ires, Bk # Oc\<up>(Suc (2 * rs + 2)) @ Bk\<up>(rna)) wcode_main_tm stpb =
           (0, Bk # ires, Bk # Oc # Bk\<up>(lnb) @ Bk # Bk # Oc\<up>(bl_bin (<a>) + (2*rs + 2)  * 2 ^ a) @ Bk\<up>(rnb))"
           by blast
         from stp1 and stp2 show "?thesis"
           apply(rule_tac x = "stpa + stpb" in exI,
               rule_tac x = lnb in exI, rule_tac x = rnb in exI, simp add: tape_of_nat_def)
           apply(simp add:  bl_bin.simps replicate_Suc)
           apply(auto)
           done
       qed
     qed
   next
     fix aa list
     assume g: "Suc x = length args" "args \<noteq> []" "lm = <args>" "args = xs @ [a::nat]" "xs = (aa::nat) # list"
-    thus "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(m) @ rev lm @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+    thus "\<exists>stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(m) @ rev lm @ Bk # Bk # ires, Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
       (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(bl_bin lm + rs * 2 ^ (length lm - 1)) @ Bk\<up>(rn))"
-    proof(induct a arbitrary: m n rs args lm, simp_all add: tape_of_nl_rev del: subst_all, 
+   proof(induct a arbitrary: m n rs args lm, simp_all add: tape_of_nl_rev del: subst_all, 
         simp only: tape_of_nl_cons_app1, simp del: subst_all)
       fix m n rs args lm
       have "\<exists>stp ln rn.
         steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # rev (<(aa::nat) # list>) @ Bk # Bk # ires,
-        Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+        Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
         (Suc 0, Bk # Bk\<up>(ln) @ rev (<aa # list>) @ Bk # Bk # ires, 
         Bk # Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rn))"
       proof(simp add: tape_of_nl_rev)
         have "\<exists> xs. (<rev list @ [aa]>) = Oc # xs" by auto           
         from this obtain xs where "(<rev list @ [aa]>) = Oc # xs" ..
         thus "\<exists>stp ln rn.
             steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # <rev list @ [aa]> @ Bk # Bk # ires,
-            Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+            Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
             (Suc 0, Bk # Bk\<up>(ln) @ <rev list @ [aa]> @ Bk # Bk # ires, Bk # Oc\<up>(5 + 4 * rs) @ Bk\<up>(rn))"
           apply(simp)
           using wcode_fourtimes_case[of m "xs @ Bk # Bk # ires" rs n]
           apply(simp)
           done
       qed
       from this obtain stpa lna rna where stp1:
         "steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # rev (<aa # list>) @ Bk # Bk # ires,
-        Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stpa =
+        Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stpa =
         (Suc 0, Bk # Bk\<up>(lna) @ rev (<aa # list>) @ Bk # Bk # ires, 
         Bk # Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rna))" by blast
       from g have 
         "\<exists> stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(lna) @ rev (<(aa::nat) # list>) @ Bk # Bk # ires, 
-        Bk # Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rna)) t_wcode_main stp = (0, Bk # ires, 
+        Bk # Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rna)) wcode_main_tm stp = (0, Bk # ires, 
         Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(bl_bin (<aa#list>)+ (4*rs + 4) * 2^(length (<aa#list>) - 1) ) @ Bk\<up>(rn))"
         apply(rule_tac args = "(aa::nat)#list" in ind, simp_all)
         done
       from this obtain stpb lnb rnb where stp2:
         "steps0 (Suc 0, Bk # Bk\<up>(lna) @ rev (<(aa::nat) # list>) @ Bk # Bk # ires, 
-         Bk # Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rna)) t_wcode_main stpb = (0, Bk # ires, 
+         Bk # Oc\<up>(Suc (4*rs + 4)) @ Bk\<up>(rna)) wcode_main_tm stpb = (0, Bk # ires, 
          Bk # Oc # Bk\<up>(lnb) @ Bk # Bk # Oc\<up>(bl_bin (<aa#list>)+ (4*rs + 4) * 2^(length (<aa#list>) - 1) ) @ Bk\<up>(rnb))"
         by blast
       from stp1 and stp2 and h
       show "\<exists>stp ln rn.
          steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc # Bk # <rev list @ [aa]> @ Bk # Bk # ires,
-         Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+         Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
          (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk #
          Bk # Oc\<up>(bl_bin (Oc\<up>(Suc aa) @ Bk # <list @ [0]>) + rs * (2 * 2 ^ (aa + length (<list @ [0]>)))) @ Bk\<up>(rn))"
         apply(rule_tac x = "stpa + stpb" in exI, rule_tac x = lnb in exI,
-            rule_tac x = rnb in exI, simp add: steps_add tape_of_nl_rev)
+            rule_tac x = rnb in exI, simp add: tape_of_nl_rev)
         done
     next
       fix ab m n rs args lm
       assume ind2:
         "\<And> m n rs args lm.
          \<lbrakk>lm = <aa # list @ [ab]>; args = aa # list @ [ab]\<rbrakk>
          \<Longrightarrow> \<exists>stp ln rn.
          steps0 (Suc 0, Bk # Bk\<up>(m) @ <ab # rev list @ [aa]> @ Bk # Bk # ires,
-         Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+         Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
          (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk #
          Bk # Oc\<up>(bl_bin (<aa # list @ [ab]>) + rs * 2 ^ (length (<aa # list @ [ab]>) - Suc 0)) @ Bk\<up>(rn))"
         and k: "args = aa # list @ [Suc ab]" "lm = <aa # list @ [Suc ab]>"
       show "\<exists>stp ln rn.
          steps0 (Suc 0, Bk # Bk\<up>(m) @ <Suc ab # rev list @ [aa]> @ Bk # Bk # ires,
-         Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+         Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
          (0, Bk # ires,Bk # Oc # Bk\<up>(ln) @ Bk # 
          Bk # Oc\<up>(bl_bin (<aa # list @ [Suc ab]>) + rs * 2 ^ (length (<aa # list @ [Suc ab]>) - Suc 0)) @ Bk\<up>(rn))"
       proof(simp add: tape_of_nl_cons_app1)
         have "\<exists>stp ln rn.
            steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc\<up>(Suc (Suc ab)) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires, 
-           Bk # Oc # Oc\<up>(rs) @ Bk\<up>(n)) t_wcode_main stp
+           Bk # Oc # Oc\<up>(rs) @ Bk\<up>(n)) wcode_main_tm stp
            = (Suc 0, Bk # Bk\<up>(ln) @ Oc\<up>(Suc ab) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
            Bk # Oc\<up>(Suc (2*rs + 2)) @ Bk\<up>(rn))"
           using wcode_double_case[of m "Oc\<up>(ab) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires"
               rs n]
           apply(simp add: replicate_Suc)
           done
         from this obtain stpa lna rna where stp1:
           "steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc\<up>(Suc (Suc ab)) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires, 
-           Bk # Oc # Oc\<up>(rs) @ Bk\<up>(n)) t_wcode_main stpa
+           Bk # Oc # Oc\<up>(rs) @ Bk\<up>(n)) wcode_main_tm stpa
            = (Suc 0, Bk # Bk\<up>(lna) @ Oc\<up>(Suc ab) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
            Bk # Oc\<up>(Suc (2*rs + 2)) @ Bk\<up>(rna))" by blast
         from k have 
           "\<exists> stp ln rn. steps0 (Suc 0, Bk # Bk\<up>(lna) @ <ab # rev list @ [aa]> @ Bk # Bk # ires,
-           Bk # Oc\<up>(Suc (2*rs + 2)) @ Bk\<up>(rna)) t_wcode_main stp
+           Bk # Oc\<up>(Suc (2*rs + 2)) @ Bk\<up>(rna)) wcode_main_tm stp
            = (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk #
            Bk # Oc\<up>(bl_bin (<aa # list @ [ab]> ) +  (2*rs + 2)* 2^(length (<aa # list @ [ab]>) - Suc 0)) @ Bk\<up>(rn))"
           apply(rule_tac ind2, simp_all)
           done
         from this obtain stpb lnb rnb where stp2: 
           "steps0 (Suc 0, Bk # Bk\<up>(lna) @  <ab # rev list @ [aa]> @ Bk # Bk # ires,
-           Bk # Oc\<up>(Suc (2*rs + 2)) @ Bk\<up>(rna)) t_wcode_main stpb
+           Bk # Oc\<up>(Suc (2*rs + 2)) @ Bk\<up>(rna)) wcode_main_tm stpb
            = (0, Bk # ires, Bk # Oc # Bk\<up>(lnb) @ Bk #
            Bk # Oc\<up>(bl_bin (<aa # list @ [ab]> ) +  (2*rs + 2)* 2^(length (<aa # list @ [ab]>) - Suc 0)) @ Bk\<up>(rnb))" 
           by blast
         from stp1 and stp2 show 
           "\<exists>stp ln rn.
            steps0 (Suc 0, Bk # Bk\<up>(m) @ Oc\<up>(Suc (Suc ab)) @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
-           Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) t_wcode_main stp =
+           Bk # Oc\<up>(Suc rs) @ Bk\<up>(n)) wcode_main_tm stp =
            (0, Bk # ires, Bk # Oc # Bk\<up>(ln) @ Bk # Bk # 
            Oc\<up>(bl_bin (Oc\<up>(Suc aa) @ Bk # <list @ [Suc ab]>) + rs * (2 * 2 ^ (aa + length (<list @ [Suc ab]>)))) 
            @ Bk\<up>(rn))"
           apply(rule_tac x = "stpa + stpb" in exI, rule_tac x = lnb in exI,
-              rule_tac x = rnb in exI, simp add: steps_add tape_of_nl_cons_app1 replicate_Suc)
+              rule_tac x = rnb in exI, simp add: tape_of_nl_cons_app1 replicate_Suc)
           done
       qed
     qed
   qed
 qed
 
-
-definition t_wcode_prepare :: "instr list"
+definition wcode_prepare_tm :: "instr list"
   where
-    "t_wcode_prepare \<equiv> 
-         [(W1, 2), (L, 1), (L, 3), (R, 2), (R, 4), (W0, 3),
+    "wcode_prepare_tm \<equiv> 
+         [(WO, 2), (L, 1), (L, 3), (R, 2), (R, 4), (WB, 3),
           (R, 4), (R, 5), (R, 6), (R, 5), (R, 7), (R, 5),
-          (W1, 7), (L, 0)]"
+          (WO, 7), (L, 0)]"
 
 fun wprepare_add_one :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_add_one m lm (l, r) = 
       (\<exists> rn. l = [] \<and>
                (r = <m # lm> @ Bk\<up>(rn) \<or> 
                 r = Bk # <m # lm> @ Bk\<up>(rn)))"
 
 fun wprepare_goto_first_end :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_goto_first_end m lm (l, r) = 
       (\<exists> ml mr rn. l = Oc\<up>(ml) \<and>
                       r = Oc\<up>(mr) @ Bk # <lm> @ Bk\<up>(rn) \<and>
                       ml + mr = Suc (Suc m))"
 
 fun wprepare_erase :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow>  bool"
   where
     "wprepare_erase m lm (l, r) = 
      (\<exists> rn. l = Oc\<up>(Suc m) \<and> 
                tl r = Bk # <lm> @ Bk\<up>(rn))"
 
 fun wprepare_goto_start_pos_B :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_goto_start_pos_B m lm (l, r) = 
      (\<exists> rn. l = Bk # Oc\<up>(Suc m) \<and>
                r = Bk # <lm> @ Bk\<up>(rn))"
 
 fun wprepare_goto_start_pos_O :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_goto_start_pos_O m lm (l, r) = 
      (\<exists> rn. l = Bk # Bk # Oc\<up>(Suc m) \<and>
                r = <lm> @ Bk\<up>(rn))"
 
 fun wprepare_goto_start_pos :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_goto_start_pos m lm (l, r) = 
        (wprepare_goto_start_pos_B m lm (l, r) \<or>
         wprepare_goto_start_pos_O m lm (l, r))"
 
 fun wprepare_loop_start_on_rightmost :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_loop_start_on_rightmost m lm (l, r) = 
      (\<exists> rn mr. rev l @ r = Oc\<up>(Suc m) @ Bk # Bk # <lm> @ Bk\<up>(rn) \<and> l \<noteq> [] \<and>
                        r = Oc\<up>(mr) @ Bk\<up>(rn))"
 
 fun wprepare_loop_start_in_middle :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_loop_start_in_middle m lm (l, r) =
      (\<exists> rn (mr:: nat) (lm1::nat list). 
   rev l @ r = Oc\<up>(Suc m) @ Bk # Bk # <lm> @ Bk\<up>(rn) \<and> l \<noteq> [] \<and>
   r = Oc\<up>(mr) @ Bk # <lm1> @ Bk\<up>(rn) \<and> lm1 \<noteq> [])"
 
 fun wprepare_loop_start :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_loop_start m lm (l, r) = (wprepare_loop_start_on_rightmost m lm (l, r) \<or> 
                                       wprepare_loop_start_in_middle m lm (l, r))"
 
 fun wprepare_loop_goon_on_rightmost :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_loop_goon_on_rightmost m lm (l, r) = 
      (\<exists> rn. l = Bk # <rev lm> @ Bk # Bk # Oc\<up>(Suc m) \<and>
                r = Bk\<up>(rn))"
 
 fun wprepare_loop_goon_in_middle :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_loop_goon_in_middle m lm (l, r) = 
      (\<exists> rn (mr:: nat) (lm1::nat list). 
   rev l @ r = Oc\<up>(Suc m) @ Bk # Bk # <lm> @ Bk\<up>(rn) \<and> l \<noteq> [] \<and>
                      (if lm1 = [] then r = Oc\<up>(mr) @ Bk\<up>(rn) 
                      else r = Oc\<up>(mr) @ Bk # <lm1> @ Bk\<up>(rn)) \<and> mr > 0)"
 
 fun wprepare_loop_goon :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_loop_goon m lm (l, r) = 
               (wprepare_loop_goon_in_middle m lm (l, r) \<or> 
                wprepare_loop_goon_on_rightmost m lm (l, r))"
 
 fun wprepare_add_one2 :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_add_one2 m lm (l, r) =
           (\<exists> rn. l = Bk # Bk # <rev lm> @ Bk # Bk # Oc\<up>(Suc m) \<and>
                (r = [] \<or> tl r = Bk\<up>(rn)))"
 
 fun wprepare_stop :: "nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_stop m lm (l, r) = 
          (\<exists> rn. l = Bk # <rev lm> @ Bk # Bk # Oc\<up>(Suc m) \<and>
                r = Bk # Oc # Bk\<up>(rn))"
 
 fun wprepare_inv :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wprepare_inv st m lm (l, r) = 
         (if st = 0 then wprepare_stop m lm (l, r) 
          else if st = Suc 0 then wprepare_add_one m lm (l, r)
          else if st = Suc (Suc 0) then wprepare_goto_first_end m lm (l, r)
          else if st = Suc (Suc (Suc 0)) then wprepare_erase m lm (l, r)
          else if st = 4 then wprepare_goto_start_pos m lm (l, r)
          else if st = 5 then wprepare_loop_start m lm (l, r)
          else if st = 6 then wprepare_loop_goon m lm (l, r)
          else if st = 7 then wprepare_add_one2 m lm (l, r)
          else False)"
 
 fun wprepare_stage :: "config \<Rightarrow> nat"
   where
     "wprepare_stage (st, l, r) = 
       (if st \<ge> 1 \<and> st \<le> 4 then 3
        else if st = 5 \<or> st = 6 then 2
        else 1)"
 
 fun wprepare_state :: "config \<Rightarrow> nat"
   where
     "wprepare_state (st, l, r) = 
        (if st = 1 then 4
         else if st = Suc (Suc 0) then 3
         else if st = Suc (Suc (Suc 0)) then 2
         else if st = 4 then 1
         else if st = 7 then 2
         else 0)"
 
 fun wprepare_step :: "config \<Rightarrow> nat"
   where
     "wprepare_step (st, l, r) = 
       (if st = 1 then (if hd r = Oc then Suc (length l)
                        else 0)
        else if st = Suc (Suc 0) then length r
        else if st = Suc (Suc (Suc 0)) then (if hd r = Oc then 1
                             else 0)
        else if st = 4 then length r
        else if st = 5 then Suc (length r)
        else if st = 6 then (if r = [] then 0 else Suc (length r))
        else if st = 7 then (if (r \<noteq> [] \<and> hd r = Oc) then 0
                             else 1)
        else 0)"
 
 fun wcode_prepare_measure :: "config \<Rightarrow> nat \<times> nat \<times> nat"
   where
     "wcode_prepare_measure (st, l, r) = 
      (wprepare_stage (st, l, r), 
       wprepare_state (st, l, r), 
       wprepare_step (st, l, r))"
 
 definition wcode_prepare_le :: "(config \<times> config) set"
   where "wcode_prepare_le \<equiv> (inv_image lex_triple wcode_prepare_measure)"
 
 lemma wf_wcode_prepare_le[intro]: "wf wcode_prepare_le"
-  by(auto intro:wf_inv_image simp: wcode_prepare_le_def 
+  by(auto simp: wcode_prepare_le_def 
       lex_triple_def)
 
 declare wprepare_add_one.simps[simp del] wprepare_goto_first_end.simps[simp del]
   wprepare_erase.simps[simp del] wprepare_goto_start_pos.simps[simp del]
   wprepare_loop_start.simps[simp del] wprepare_loop_goon.simps[simp del]
   wprepare_add_one2.simps[simp del]
 
 lemmas wprepare_invs = wprepare_add_one.simps wprepare_goto_first_end.simps
   wprepare_erase.simps wprepare_goto_start_pos.simps
   wprepare_loop_start.simps wprepare_loop_goon.simps
   wprepare_add_one2.simps
 
 declare wprepare_inv.simps[simp del]
 
-lemma fetch_t_wcode_prepare[simp]:
-  "fetch t_wcode_prepare (Suc 0) Bk = (W1, 2)"
-  "fetch t_wcode_prepare (Suc 0) Oc = (L, 1)"
-  "fetch t_wcode_prepare (Suc (Suc 0)) Bk = (L, 3)"
-  "fetch t_wcode_prepare (Suc (Suc 0)) Oc = (R, 2)"
-  "fetch t_wcode_prepare (Suc (Suc (Suc 0))) Bk = (R, 4)"
-  "fetch t_wcode_prepare (Suc (Suc (Suc 0))) Oc = (W0, 3)"
-  "fetch t_wcode_prepare 4 Bk = (R, 4)"
-  "fetch t_wcode_prepare 4 Oc = (R, 5)"
-  "fetch t_wcode_prepare 5 Oc = (R, 5)"
-  "fetch t_wcode_prepare 5 Bk = (R, 6)"
-  "fetch t_wcode_prepare 6 Oc = (R, 5)"
-  "fetch t_wcode_prepare 6 Bk = (R, 7)"
-  "fetch t_wcode_prepare 7 Oc = (L, 0)"
-  "fetch t_wcode_prepare 7 Bk = (W1, 7)"
-  unfolding fetch.simps t_wcode_prepare_def nth_of.simps
-    numeral by auto
+lemma fetch_wcode_prepare_tm[simp]:
+  "fetch wcode_prepare_tm (Suc 0) Bk = (WO, 2)"
+  "fetch wcode_prepare_tm (Suc 0) Oc = (L, 1)"
+  "fetch wcode_prepare_tm (Suc (Suc 0)) Bk = (L, 3)"
+  "fetch wcode_prepare_tm (Suc (Suc 0)) Oc = (R, 2)"
+  "fetch wcode_prepare_tm (Suc (Suc (Suc 0))) Bk = (R, 4)"
+  "fetch wcode_prepare_tm (Suc (Suc (Suc 0))) Oc = (WB, 3)"
+  "fetch wcode_prepare_tm 4 Bk = (R, 4)"
+  "fetch wcode_prepare_tm 4 Oc = (R, 5)"
+  "fetch wcode_prepare_tm 5 Oc = (R, 5)"
+  "fetch wcode_prepare_tm 5 Bk = (R, 6)"
+  "fetch wcode_prepare_tm 6 Oc = (R, 5)"
+  "fetch wcode_prepare_tm 6 Bk = (R, 7)"
+  "fetch wcode_prepare_tm 7 Oc = (L, 0)"
+  "fetch wcode_prepare_tm 7 Bk = (WO, 7)"
+  unfolding fetch.simps wcode_prepare_tm_def nth_of.simps
+    numeral_eqs_upto_12 by auto
 
 lemma wprepare_add_one_nonempty_snd[simp]: "lm \<noteq> [] \<Longrightarrow> wprepare_add_one m lm (b, []) = False"
   apply(simp add: wprepare_invs)
   done
 
 lemma wprepare_goto_first_end_nonempty_snd[simp]: "lm \<noteq> [] \<Longrightarrow> wprepare_goto_first_end m lm (b, []) = False"
   apply(simp add: wprepare_invs)
   done
 
 lemma wprepare_erase_nonempty_snd[simp]: "lm \<noteq> [] \<Longrightarrow> wprepare_erase m lm (b, []) = False"
   apply(simp add: wprepare_invs)
   done
 
 lemma wprepare_goto_start_pos_nonempty_snd[simp]: "lm \<noteq> [] \<Longrightarrow> wprepare_goto_start_pos m lm (b, []) = False"
   apply(simp add: wprepare_invs)
   done
 
 lemma wprepare_loop_start_empty_nonempty_fst[simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_start m lm (b, [])\<rbrakk> \<Longrightarrow> b \<noteq> []"
   apply(simp add: wprepare_invs)
   done
 
 lemma rev_eq: "rev xs = rev ys \<Longrightarrow> xs = ys" by auto
 
 lemma wprepare_loop_goon_Bk_empty_snd[simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_start m lm (b, [])\<rbrakk> \<Longrightarrow> 
                                   wprepare_loop_goon m lm (Bk # b, [])"
   apply(simp only: wprepare_invs)
   apply(erule_tac disjE)
    apply(rule_tac disjI2)
-   apply(simp add: wprepare_loop_start_on_rightmost.simps
-      wprepare_loop_goon_on_rightmost.simps, auto)
+   apply(simp, auto)
   apply(rule_tac rev_eq, simp add: tape_of_nl_rev)
   done
 
 lemma wprepare_loop_goon_nonempty_fst[simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_goon m lm (b, [])\<rbrakk> \<Longrightarrow> b \<noteq> []"
   apply(simp only: wprepare_invs, auto)
   done
 
 lemma wprepare_add_one2_Bk_empty[simp]:"\<lbrakk>lm \<noteq> []; wprepare_loop_goon m lm (b, [])\<rbrakk> \<Longrightarrow> 
   wprepare_add_one2 m lm (Bk # b, [])"
   apply(simp only: wprepare_invs, auto split: if_splits)
   done
 
 lemma wprepare_add_one2_nonempty_fst[simp]: "wprepare_add_one2 m lm (b, []) \<Longrightarrow> b \<noteq> []"
   apply(simp only: wprepare_invs, auto)
   done
 
 lemma wprepare_add_one2_Oc[simp]: "wprepare_add_one2 m lm (b, []) \<Longrightarrow> wprepare_add_one2 m lm (b, [Oc])"
   apply(simp only: wprepare_invs, auto)
   done
 
 lemma Bk_not_tape_start[simp]: "(Bk # list = <(m::nat) # lm> @ ys) = False"
   apply(case_tac lm, auto simp: tape_of_nl_cons replicate_Suc)
   done
 
 lemma wprepare_goto_first_end_cases[simp]:
   "\<lbrakk>lm \<noteq> []; wprepare_add_one m lm (b, Bk # list)\<rbrakk>
        \<Longrightarrow> (b = [] \<longrightarrow> wprepare_goto_first_end m lm ([], Oc # list)) \<and> 
            (b \<noteq> [] \<longrightarrow> wprepare_goto_first_end m lm (b, Oc # list))"
   apply(simp only: wprepare_invs)
   apply(auto simp: tape_of_nl_cons split: if_splits)
   apply(cases lm, auto simp add:tape_of_list_def replicate_Suc)
   done
 
 lemma wprepare_goto_first_end_Bk_nonempty_fst[simp]:
   "wprepare_goto_first_end m lm (b, Bk # list) \<Longrightarrow> b \<noteq> []"
   apply(simp only: wprepare_invs , auto simp: replicate_Suc)
   done
 
 declare replicate_Suc[simp]
 
 lemma wprepare_erase_elem_Bk_rest[simp]: "wprepare_goto_first_end m lm (b, Bk # list) \<Longrightarrow>
                           wprepare_erase m lm (tl b, hd b # Bk # list)"
   by(simp add: wprepare_invs)
 
 lemma wprepare_erase_Bk_nonempty_fst[simp]: "wprepare_erase m lm (b, Bk # list) \<Longrightarrow> b \<noteq> []"
   by(simp add: wprepare_invs)
 
 lemma wprepare_goto_start_pos_Bk[simp]: "wprepare_erase m lm (b, Bk # list) \<Longrightarrow> 
                            wprepare_goto_start_pos m lm (Bk # b, list)"
   apply(simp only: wprepare_invs, auto)
   done
 
 lemma wprepare_add_one_Bk_nonempty_snd[simp]: "\<lbrakk>wprepare_add_one m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> list \<noteq> []"
   apply(simp only: wprepare_invs)
   apply(case_tac lm, simp_all add: tape_of_list_def tape_of_nat_def, auto)
   done
 
 lemma wprepare_goto_first_end_nonempty_snd_tl[simp]:
   "\<lbrakk>lm \<noteq> [];  wprepare_goto_first_end m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> list \<noteq> []"
   by(simp only: wprepare_invs, auto)
 
 lemma wprepare_erase_Bk_nonempty_list[simp]: "\<lbrakk>lm \<noteq> []; wprepare_erase m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> list \<noteq> []"
   apply(simp only: wprepare_invs, auto)
   done
 
 
 lemma wprepare_goto_start_pos_Bk_nonempty[simp]: "\<lbrakk>lm \<noteq> [];  wprepare_goto_start_pos m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> list \<noteq> []"
   by(cases lm;cases list;simp only: wprepare_invs, auto)
 
 lemma wprepare_goto_start_pos_Bk_nonempty_fst[simp]: "\<lbrakk>lm \<noteq> [];  wprepare_goto_start_pos m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> b \<noteq> []"
   apply(simp only: wprepare_invs)
   apply(auto)
   done
 
 lemma wprepare_loop_goon_Bk_nonempty[simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_goon m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> b \<noteq> []"
   apply(simp only: wprepare_invs, auto)
   done
 
 lemma wprepare_loop_goon_wprepare_add_one2_cases[simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_goon m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> 
   (list = [] \<longrightarrow> wprepare_add_one2 m lm (Bk # b, [])) \<and> 
   (list \<noteq> [] \<longrightarrow> wprepare_add_one2 m lm (Bk # b, list))"
   unfolding wprepare_invs
   apply(cases list;auto split:nat.split if_splits)
   by (metis list.sel(3) tl_replicate)
 
 lemma wprepare_add_one2_nonempty[simp]: "wprepare_add_one2 m lm (b, Bk # list) \<Longrightarrow> b \<noteq> []"
   apply(simp only: wprepare_invs, simp)
   done
 
 lemma wprepare_add_one2_cases[simp]: "wprepare_add_one2 m lm (b, Bk # list) \<Longrightarrow> 
       (list = [] \<longrightarrow> wprepare_add_one2 m lm (b, [Oc])) \<and> 
       (list \<noteq> [] \<longrightarrow> wprepare_add_one2 m lm (b, Oc # list))"
   apply(simp only:  wprepare_invs, auto)
   done
 
 lemma wprepare_goto_first_end_cases_Oc[simp]: "wprepare_goto_first_end m lm (b, Oc # list)
        \<Longrightarrow> (b = [] \<longrightarrow> wprepare_goto_first_end m lm ([Oc], list)) \<and> 
            (b \<noteq> [] \<longrightarrow> wprepare_goto_first_end m lm (Oc # b, list))"
   apply(simp only:  wprepare_invs, auto)
    apply(rule_tac x = 1 in exI, auto) apply(rename_tac ml mr rn)
   apply(case_tac mr, simp_all add: )
   apply(case_tac ml, simp_all add: )
   apply(rule_tac x = "Suc ml" in exI, simp_all add: )
   apply(rule_tac x = "mr - 1" in exI, simp)
   done
 
 lemma wprepare_erase_nonempty[simp]: "wprepare_erase m lm (b, Oc # list) \<Longrightarrow> b \<noteq> []"
   apply(simp only: wprepare_invs, auto simp: )
   done
 
 lemma wprepare_erase_Bk[simp]: "wprepare_erase m lm (b, Oc # list)
   \<Longrightarrow> wprepare_erase m lm (b, Bk # list)"
   apply(simp  only:wprepare_invs, auto simp: )
   done
 
 lemma wprepare_goto_start_pos_Bk_move[simp]: "\<lbrakk>lm \<noteq> []; wprepare_goto_start_pos m lm (b, Bk # list)\<rbrakk>
        \<Longrightarrow> wprepare_goto_start_pos m lm (Bk # b, list)"
   apply(simp only:wprepare_invs, auto)
           apply(case_tac [!] lm, simp, simp_all)
   done
 
 lemma wprepare_loop_start_b_nonempty[simp]: "wprepare_loop_start m lm (b, aa) \<Longrightarrow> b \<noteq> []"
   apply(simp only:wprepare_invs, auto)
   done
 lemma exists_exp_of_Bk[elim]: "Bk # list = Oc\<up>(mr) @ Bk\<up>(rn)  \<Longrightarrow> \<exists>rn. list = Bk\<up>(rn)"
   apply(case_tac mr, simp_all)
   apply(case_tac rn, simp_all)
   done
 
 lemma wprepare_loop_start_in_middle_Bk_False[simp]: "wprepare_loop_start_in_middle m lm (b, [Bk]) = False"
   by(auto)
 
 declare wprepare_loop_start_in_middle.simps[simp del]
 
 declare wprepare_loop_start_on_rightmost.simps[simp del] 
   wprepare_loop_goon_in_middle.simps[simp del]
   wprepare_loop_goon_on_rightmost.simps[simp del]
 
 lemma wprepare_loop_goon_in_middle_Bk_False[simp]: "wprepare_loop_goon_in_middle m lm (Bk # b, []) = False"
   apply(simp add: wprepare_loop_goon_in_middle.simps, auto)
   done
 
 lemma wprepare_loop_goon_Bk[simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_start m lm (b, [Bk])\<rbrakk> \<Longrightarrow>
   wprepare_loop_goon m lm (Bk # b, [])"
   unfolding wprepare_invs
   apply(auto simp add: wprepare_loop_goon_on_rightmost.simps 
       wprepare_loop_start_on_rightmost.simps)
   apply(rule_tac rev_eq)
   apply(simp add: tape_of_nl_rev)
   apply(simp add: exp_ind replicate_Suc[THEN sym] del: replicate_Suc)
   done
 
 lemma wprepare_loop_goon_in_middle_Bk_False2[simp]: "wprepare_loop_start_on_rightmost m lm (b, Bk # a # lista)
  \<Longrightarrow> wprepare_loop_goon_in_middle m lm (Bk # b, a # lista) = False"
   apply(auto simp: wprepare_loop_start_on_rightmost.simps
       wprepare_loop_goon_in_middle.simps)
   done
 
 lemma wprepare_loop_goon_on_rightbmost_Bk_False[simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_start_on_rightmost m lm (b, Bk # a # lista)\<rbrakk>
     \<Longrightarrow> wprepare_loop_goon_on_rightmost m lm (Bk # b, a # lista)"
   apply(simp only: wprepare_loop_start_on_rightmost.simps
       wprepare_loop_goon_on_rightmost.simps, auto simp: tape_of_nl_rev)
    apply(simp add: replicate_Suc[THEN sym] exp_ind tape_of_nl_rev del: replicate_Suc)
   by (meson Cons_replicate_eq)
 
 
 lemma wprepare_loop_goon_in_middle_Bk_False3[simp]: 
   assumes "lm \<noteq> []" "wprepare_loop_start_in_middle m lm (b, Bk # a # lista)"
   shows "wprepare_loop_goon_in_middle m lm (Bk # b, a # lista)" (is "?t1")
     and "wprepare_loop_goon_on_rightmost m lm (Bk # b, a # lista) = False" (is ?t2)
 proof -
   from assms obtain rn mr lm1 where *:"rev b @ Oc \<up> mr @ Bk # <lm1> = Oc # Oc \<up> m @ Bk # Bk # <lm>"
     "b \<noteq> []" "Bk # a # lista = Oc \<up> mr @ Bk # <lm1::nat list> @ Bk \<up> rn" "lm1 \<noteq> []"
     by(auto simp add: wprepare_loop_start_in_middle.simps)
   thus ?t1 apply(simp add: wprepare_loop_start_in_middle.simps
         wprepare_loop_goon_in_middle.simps, auto)
     apply(rule_tac x = rn in exI, simp)
     apply(case_tac mr, simp_all add: )
     apply(case_tac lm1, simp)
     apply(rule_tac x = "Suc (hd lm1)" in exI, simp)
     apply(rule_tac x = "tl lm1" in exI)
     apply(case_tac "tl lm1", simp_all add: tape_of_list_def  tape_of_nat_def)
     done
   from * show ?t2 
     apply(simp add: wprepare_loop_start_in_middle.simps
         wprepare_loop_goon_on_rightmost.simps del:split_head_repeat, auto simp del:split_head_repeat)
      apply(case_tac mr)
       apply(case_tac  "lm1::nat list", simp_all, case_tac "tl lm1", simp_all)
       apply(auto simp add: tape_of_list_def )
       apply(case_tac [!] rna, simp_all add: )
      apply(case_tac mr, simp_all add: )
      apply(case_tac lm1, simp, case_tac list, simp)
      apply(simp_all add: tape_of_nat_def)
     by (metis Bk_not_tape_start tape_of_list_def tape_of_nat_list.elims)
 qed
 
 lemma wprepare_loop_goon_Bk2[simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_start m lm (b, Bk # a # lista)\<rbrakk> \<Longrightarrow> 
   wprepare_loop_goon m lm (Bk # b, a # lista)"
   apply(simp add: wprepare_loop_start.simps 
       wprepare_loop_goon.simps)
   apply(erule_tac disjE, simp, auto)
   done
 
 lemma start_2_goon:
   "\<lbrakk>lm \<noteq> []; wprepare_loop_start m lm (b, Bk # list)\<rbrakk> \<Longrightarrow>
    (list = [] \<longrightarrow> wprepare_loop_goon m lm (Bk # b, [])) \<and>
   (list \<noteq> [] \<longrightarrow> wprepare_loop_goon m lm (Bk # b, list))"
   apply(case_tac list, auto)
   done
 
 lemma add_one_2_add_one: "wprepare_add_one m lm (b, Oc # list)
   \<Longrightarrow> (hd b = Oc \<longrightarrow> (b = [] \<longrightarrow> wprepare_add_one m lm ([], Bk # Oc # list)) \<and>
                      (b \<noteq> [] \<longrightarrow> wprepare_add_one m lm (tl b, Oc # Oc # list))) \<and>
   (hd b \<noteq> Oc \<longrightarrow> (b = [] \<longrightarrow> wprepare_add_one m lm ([], Bk # Oc # list)) \<and>
                  (b \<noteq> [] \<longrightarrow> wprepare_add_one m lm (tl b, hd b # Oc # list)))"
   unfolding wprepare_add_one.simps by auto
 
 lemma wprepare_loop_start_on_rightmost_Oc[simp]: "wprepare_loop_start_on_rightmost m lm (b, Oc # list) \<Longrightarrow> 
   wprepare_loop_start_on_rightmost m lm (Oc # b, list)"
   apply(simp add: wprepare_loop_start_on_rightmost.simps)
   by (metis Cons_replicate_eq cell.distinct(1) list.sel(3) self_append_conv2 tl_append2 tl_replicate)
 
 lemma wprepare_loop_start_in_middle_Oc[simp]:
   assumes "wprepare_loop_start_in_middle m lm (b, Oc # list)"
   shows "wprepare_loop_start_in_middle m lm (Oc # b, list)"
 proof -
   from assms obtain mr lm1 rn
     where "rev b @ Oc \<up> mr @ Bk # <lm1::nat list> = Oc # Oc \<up> m @ Bk # Bk # <lm>"
       "Oc # list = Oc \<up> mr @ Bk # <lm1> @ Bk \<up> rn" "lm1 \<noteq> []"
     by(auto simp add: wprepare_loop_start_in_middle.simps)
   thus ?thesis 
     apply(auto simp add: wprepare_loop_start_in_middle.simps)
     apply(rule_tac x = rn in exI, auto)
     apply(case_tac mr, simp, simp add: )
     apply(rule_tac x = "mr - 1" in exI, simp)
     apply(rule_tac x = lm1 in exI, simp)
     done
 qed
 
 lemma start_2_start: "wprepare_loop_start m lm (b, Oc # list) \<Longrightarrow> 
        wprepare_loop_start m lm (Oc # b, list)"
   apply(simp add: wprepare_loop_start.simps)
   apply(erule_tac disjE, simp_all )
   done
 
 lemma wprepare_loop_goon_Oc_nonempty[simp]: "wprepare_loop_goon m lm (b, Oc # list) \<Longrightarrow> b \<noteq> []"
   apply(simp add: wprepare_loop_goon.simps     
       wprepare_loop_goon_in_middle.simps 
       wprepare_loop_goon_on_rightmost.simps)
   apply(auto)
   done
 
 lemma wprepare_goto_start_pos_Oc_nonempty[simp]: "wprepare_goto_start_pos m lm (b, Oc # list) \<Longrightarrow> b \<noteq> []"
   apply(simp add: wprepare_goto_start_pos.simps)
   done
 
 lemma wprepare_loop_goon_on_rightmost_Oc_False[simp]: "wprepare_loop_goon_on_rightmost m lm (b, Oc # list) = False"
   apply(simp add: wprepare_loop_goon_on_rightmost.simps)
   done
 
 lemma wprepare_loop1: "\<lbrakk>rev b @ Oc\<up>(mr) =  Oc\<up>(Suc m) @ Bk # Bk # <lm>; 
          b \<noteq> []; 0 < mr; Oc # list = Oc\<up>(mr) @ Bk\<up>(rn)\<rbrakk>
        \<Longrightarrow> wprepare_loop_start_on_rightmost m lm (Oc # b, list)"
   apply(simp add: wprepare_loop_start_on_rightmost.simps)
   apply(rule_tac x = rn in exI, simp)
   apply(case_tac mr, simp, simp)
   done
 
 lemma wprepare_loop2: "\<lbrakk>rev b @ Oc\<up>(mr) @ Bk # <a # lista> = Oc\<up>(Suc m) @ Bk # Bk # <lm>;
                 b \<noteq> []; Oc # list = Oc\<up>(mr) @ Bk # <(a::nat) # lista> @ Bk\<up>(rn)\<rbrakk>
        \<Longrightarrow>  wprepare_loop_start_in_middle m lm (Oc # b, list)"
   apply(simp add: wprepare_loop_start_in_middle.simps)
   apply(rule_tac x = rn in exI, simp)
   apply(case_tac mr, simp_all add: ) apply(rename_tac nat)
   apply(rule_tac x = nat in exI, simp)
   apply(rule_tac x = "a#lista" in exI, simp)
   done
 
 lemma wprepare_loop_goon_in_middle_cases[simp]: "wprepare_loop_goon_in_middle m lm (b, Oc # list) \<Longrightarrow>
                 wprepare_loop_start_on_rightmost m lm (Oc # b, list) \<or>
                 wprepare_loop_start_in_middle m lm (Oc # b, list)"
   apply(simp add: wprepare_loop_goon_in_middle.simps split: if_splits) apply(rename_tac lm1)
   apply(case_tac lm1, simp_all add: wprepare_loop1 wprepare_loop2)
   done
 
 lemma wprepare_add_one_b[simp]: "wprepare_add_one m lm (b, Oc # list)
        \<Longrightarrow> b = [] \<longrightarrow> wprepare_add_one m lm ([], Bk # Oc # list)"
   "wprepare_loop_goon m lm (b, Oc # list)
   \<Longrightarrow>  wprepare_loop_start m lm (Oc # b, list)"
    apply(auto simp add: wprepare_add_one.simps wprepare_loop_goon.simps
       wprepare_loop_start.simps)
   done
 
 lemma wprepare_loop_start_on_rightmost_Oc2[simp]: "wprepare_goto_start_pos m [a] (b, Oc # list)
               \<Longrightarrow> wprepare_loop_start_on_rightmost m [a] (Oc # b, list) "
   apply(auto simp: wprepare_goto_start_pos.simps 
       wprepare_loop_start_on_rightmost.simps) apply(rename_tac rn)
   apply(rule_tac x = rn in exI, simp)
   apply(simp add: replicate_Suc[THEN sym] exp_ind del: replicate_Suc)
   done
 
 lemma wprepare_loop_start_in_middle_2_Oc[simp]:  "wprepare_goto_start_pos m (a # aa # listaa) (b, Oc # list)
        \<Longrightarrow>wprepare_loop_start_in_middle m (a # aa # listaa) (Oc # b, list)"
   apply(auto simp: wprepare_goto_start_pos.simps
       wprepare_loop_start_in_middle.simps) apply(rename_tac rn)
   apply(rule_tac x = rn in exI, simp)
   apply(simp add: exp_ind[THEN sym])
   apply(rule_tac x = a in exI, rule_tac x = "aa#listaa" in exI, simp)
   apply(simp add: tape_of_nl_cons)
   done
 
 lemma wprepare_loop_start_Oc2[simp]: "\<lbrakk>lm \<noteq> []; wprepare_goto_start_pos m lm (b, Oc # list)\<rbrakk>
        \<Longrightarrow> wprepare_loop_start m lm (Oc # b, list)"
   by(cases lm;cases "tl lm", auto simp add: wprepare_loop_start.simps)
 
 lemma wprepare_add_one2_Oc_nonempty[simp]: "wprepare_add_one2 m lm (b, Oc # list) \<Longrightarrow> b \<noteq> []"
   apply(auto simp: wprepare_add_one2.simps)
   done
 
 lemma add_one_2_stop:
   "wprepare_add_one2 m lm (b, Oc # list)      
   \<Longrightarrow>  wprepare_stop m lm (tl b, hd b # Oc # list)"
   apply(simp add: wprepare_add_one2.simps)
   done
 
 declare wprepare_stop.simps[simp del]
 
 lemma wprepare_correctness:
   assumes h: "lm \<noteq> []"
   shows "let P = (\<lambda> (st, l, r). st = 0) in 
   let Q = (\<lambda> (st, l, r). wprepare_inv st m lm (l, r)) in 
-  let f = (\<lambda> stp. steps0 (Suc 0, [], (<m # lm>)) t_wcode_prepare stp) in
+  let f = (\<lambda> stp. steps0 (Suc 0, [], (<m # lm>)) wcode_prepare_tm stp) in
     \<exists> n .P (f n) \<and> Q (f n)"
 proof -
   let ?P = "(\<lambda> (st, l, r). st = 0)"
   let ?Q = "(\<lambda> (st, l, r). wprepare_inv st m lm (l, r))"
-  let ?f = "(\<lambda> stp. steps0 (Suc 0, [], (<m # lm>)) t_wcode_prepare stp)"
+  let ?f = "(\<lambda> stp. steps0 (Suc 0, [], (<m # lm>)) wcode_prepare_tm stp)"
   have "\<exists> n. ?P (?f n) \<and> ?Q (?f n)"
   proof(rule_tac halt_lemma2)
     show "\<forall> n. \<not> ?P (?f n) \<and> ?Q (?f n) \<longrightarrow> 
                  ?Q (?f (Suc n)) \<and> (?f (Suc n), ?f n) \<in> wcode_prepare_le"
       using h
       apply(rule_tac allI, rule_tac impI) apply(rename_tac n)
       apply(case_tac "?f n", simp add: step.simps) apply(rename_tac c)
       apply(case_tac c, simp, case_tac [2] aa)
         apply(simp_all add: wprepare_inv.simps wcode_prepare_le_def lex_triple_def lex_pair_def
           split: if_splits) (* slow *)
          apply(simp_all add: start_2_goon  start_2_start
           add_one_2_add_one add_one_2_stop)
       apply(auto simp: wprepare_add_one2.simps)
       done
   qed (auto simp add: steps.simps wprepare_inv.simps wprepare_invs)
   thus "?thesis"
     apply(auto)
     done
 qed
 
-lemma tm_wf_t_wcode_prepare[intro]: "tm_wf (t_wcode_prepare, 0)"
-  apply(simp add:tm_wf.simps t_wcode_prepare_def)
+lemma composable_tm_wcode_prepare_tm[intro]: "composable_tm (wcode_prepare_tm, 0)"
+  apply(simp add:composable_tm.simps wcode_prepare_tm_def)
   done
 
-lemma is_28_even[intro]: "(28 + (length t_twice_compile + length t_fourtimes_compile)) mod 2 = 0"
-  by(auto simp: t_twice_compile_def t_fourtimes_compile_def)
-
-lemma b_le_28[elim]: "(a, b) \<in> set t_wcode_main_first_part \<Longrightarrow>
-  b \<le> (28 + (length t_twice_compile + length t_fourtimes_compile)) div 2"
-  apply(auto simp: t_wcode_main_first_part_def t_twice_def)
+lemma is_28_even[intro]: "(28 + (length twice_compile_tm + length fourtimes_compile_tm)) mod 2 = 0"
+  by(auto simp: twice_compile_tm_def fourtimes_compile_tm_def)
+
+lemma b_le_28[elim]: "(a, b) \<in> set wcode_main_first_part_tm \<Longrightarrow>
+  b \<le> (28 + (length twice_compile_tm + length fourtimes_compile_tm)) div 2"
+  apply(auto simp: wcode_main_first_part_tm_def twice_tm_def)
   done
 
 
 
-lemma tm_wf_change_termi:
-  assumes "tm_wf (tp, 0)"
+lemma composable_tm_change_termi:
+  assumes "composable_tm (tp, 0)"
   shows "list_all (\<lambda>(acn, st). (st \<le> Suc (length tp div 2))) (adjust0 tp)"
 proof -
   { fix acn st n
     assume "tp ! n = (acn, st)" "n < length tp" "0 < st"
     hence "(acn, st)\<in>set tp" by (metis nth_mem)
-    with assms tm_wf.simps have "st \<le> length tp div 2 + 0" by auto
+    with assms composable_tm.simps have "st \<le> length tp div 2 + 0" by auto
     hence "st \<le> Suc (length tp div 2)" by auto
   }
   thus ?thesis
-    by(auto simp: tm_wf.simps List.list_all_length adjust.simps split: if_splits prod.split)
+    by(auto simp: composable_tm.simps List.list_all_length adjust.simps split: if_splits prod.split)
 qed
 
-lemma tm_wf_shift:
+lemma composable_tm_shift:
   assumes "list_all (\<lambda>(acn, st). (st \<le> y)) tp"
   shows "list_all (\<lambda>(acn, st). (st \<le> y + off)) (shift tp off)"
 proof -
   have [dest!]:"\<And> P Q n. \<forall>n. Q n \<longrightarrow> P n \<Longrightarrow> Q n \<Longrightarrow> P n" by metis
-  from assms show ?thesis by(auto simp: tm_wf.simps List.list_all_length shift.simps)
+  from assms show ?thesis by(auto simp: composable_tm.simps List.list_all_length shift.simps)
 qed
 
 declare length_tp'[simp del]
 
-lemma length_mopup_1[simp]: "length (mopup (Suc 0)) = 16"
-  apply(auto simp: mopup.simps)
+lemma length_mopup_1[simp]: "length (mopup_n_tm (Suc 0)) = 16"
+  apply(auto simp: mopup_n_tm.simps)
   done
 
-lemma twice_plus_28_elim[elim]: "(a, b) \<in> set (shift (adjust0 t_twice_compile) 12) \<Longrightarrow> 
-  b \<le> (28 + (length t_twice_compile + length t_fourtimes_compile)) div 2"
-  apply(simp add: t_twice_compile_def t_fourtimes_compile_def)
+lemma twice_plus_28_elim[elim]: "(a, b) \<in> set (shift (adjust0 twice_compile_tm) 12) \<Longrightarrow> 
+  b \<le> (28 + (length twice_compile_tm + length fourtimes_compile_tm)) div 2"
+  apply(simp add: twice_compile_tm_def fourtimes_compile_tm_def)
 proof -
   assume g: "(a, b)
     \<in> set (shift
             (adjust
               (tm_of abc_twice @
-               shift (mopup (Suc 0)) (length (tm_of abc_twice) div 2))
+               shift (mopup_n_tm (Suc 0)) (length (tm_of abc_twice) div 2))
               (Suc ((length (tm_of abc_twice) + 16) div 2)))
             12)"
   moreover have "length (tm_of abc_twice) mod 2 = 0" by auto
   moreover have "length (tm_of abc_fourtimes) mod 2 = 0" by auto
   ultimately have "list_all (\<lambda>(acn, st). (st \<le> (60 + (length (tm_of abc_twice) + length (tm_of abc_fourtimes))) div 2)) 
-    (shift (adjust0 t_twice_compile) 12)"
-  proof(auto simp add: mod_ex1 del: adjust.simps)
+    (shift (adjust0 twice_compile_tm) 12)"
+  proof(auto simp add: mod_ex1)
     assume "even (length (tm_of abc_twice))"
     then obtain q where q:"length (tm_of abc_twice) = 2 * q" by auto
     assume "even (length (tm_of abc_fourtimes))"
     then obtain qa where qa:"length (tm_of abc_fourtimes) = 2 * qa" by auto
     note h = q qa
-    hence "list_all (\<lambda>(acn, st). st \<le> (18 + (q + qa)) + 12) (shift (adjust0 t_twice_compile) 12)"
-    proof(rule_tac tm_wf_shift t_twice_compile_def)
-      have "list_all (\<lambda>(acn, st). st \<le> Suc (length t_twice_compile div 2)) (adjust0 t_twice_compile)"
-        by(rule_tac tm_wf_change_termi, auto)
-      thus "list_all (\<lambda>(acn, st). st \<le> 18 + (q + qa)) (adjust0 t_twice_compile)"
+    hence "list_all (\<lambda>(acn, st). st \<le> (18 + (q + qa)) + 12) (shift (adjust0 twice_compile_tm) 12)"
+    proof(rule_tac composable_tm_shift twice_compile_tm_def)
+      have "list_all (\<lambda>(acn, st). st \<le> Suc (length twice_compile_tm div 2)) (adjust0 twice_compile_tm)"
+        by(rule_tac composable_tm_change_termi, auto)
+      thus "list_all (\<lambda>(acn, st). st \<le> 18 + (q + qa)) (adjust0 twice_compile_tm)"
         using h
-        apply(simp add: t_twice_compile_def, auto simp: List.list_all_length)
+        apply(simp add: twice_compile_tm_def, auto simp: List.list_all_length)
         done
     qed
     thus "list_all (\<lambda>(acn, st). st \<le> 30 + (length (tm_of abc_twice) div 2 + length (tm_of abc_fourtimes) div 2))
-     (shift (adjust0 t_twice_compile) 12)" using h
+     (shift (adjust0 twice_compile_tm) 12)" using h
       by simp
   qed
   thus "b \<le> (60 + (length (tm_of abc_twice) + length (tm_of abc_fourtimes))) div 2"
     using g
-    apply(auto simp:t_twice_compile_def)
+    apply(auto simp:twice_compile_tm_def)
     apply(simp add: Ball_set[THEN sym])
     apply(erule_tac x = "(a, b)" in ballE, simp, simp)
     done
 qed 
 
-lemma length_plus_28_elim2[elim]: "(a, b) \<in> set (shift (adjust0 t_fourtimes_compile) (t_twice_len + 13)) 
-  \<Longrightarrow> b \<le> (28 + (length t_twice_compile + length t_fourtimes_compile)) div 2"
-  apply(simp add: t_twice_compile_def t_fourtimes_compile_def t_twice_len_def)
+lemma length_plus_28_elim2[elim]: "(a, b) \<in> set (shift (adjust0 fourtimes_compile_tm) (twice_tm_len + 13)) 
+  \<Longrightarrow> b \<le> (28 + (length twice_compile_tm + length fourtimes_compile_tm)) div 2"
+  apply(simp add: twice_compile_tm_def fourtimes_compile_tm_def twice_tm_len_def)
 proof -
   assume g: "(a, b)
     \<in> set (shift
-             (adjust (tm_of abc_fourtimes @ shift (mopup (Suc 0)) (length (tm_of abc_fourtimes) div 2))
+             (adjust (tm_of abc_fourtimes @ shift (mopup_n_tm (Suc 0)) (length (tm_of abc_fourtimes) div 2))
                (Suc ((length (tm_of abc_fourtimes) + 16) div 2)))
-             (length t_twice div 2 + 13))"
+             (length twice_tm div 2 + 13))"
   moreover have "length (tm_of abc_twice) mod 2 = 0" by auto
   moreover have "length (tm_of abc_fourtimes) mod 2 = 0" by auto
   ultimately have "list_all (\<lambda>(acn, st). (st \<le> (60 + (length (tm_of abc_twice) + length (tm_of abc_fourtimes))) div 2)) 
-    (shift (adjust0 (tm_of abc_fourtimes @ shift (mopup (Suc 0))
-    (length (tm_of abc_fourtimes) div 2))) (length t_twice div 2 + 13))"
-  proof(auto simp: mod_ex1 t_twice_def t_twice_compile_def)
+    (shift (adjust0 (tm_of abc_fourtimes @ shift (mopup_n_tm (Suc 0))
+    (length (tm_of abc_fourtimes) div 2))) (length twice_tm div 2 + 13))"
+  proof(auto simp: mod_ex1 twice_tm_def twice_compile_tm_def)
     assume "even (length (tm_of abc_twice))"
     then obtain q where q:"length (tm_of abc_twice) = 2 * q" by auto
     assume "even (length (tm_of abc_fourtimes))"
     then obtain qa where qa:"length (tm_of abc_fourtimes) = 2 * qa" by auto
     note h = q qa
     hence "list_all (\<lambda>(acn, st). st \<le> (9 + qa + (21 + q)))
-      (shift (adjust0 (tm_of abc_fourtimes @ shift (mopup (Suc 0)) qa)) (21 + q))"
-    proof(rule_tac tm_wf_shift t_twice_compile_def)
+      (shift (adjust0 (tm_of abc_fourtimes @ shift (mopup_n_tm (Suc 0)) qa)) (21 + q))"
+    proof(rule_tac composable_tm_shift twice_compile_tm_def)
       have "list_all (\<lambda>(acn, st). st \<le> Suc (length (tm_of abc_fourtimes @ shift 
-        (mopup (Suc 0)) qa) div 2)) (adjust0 (tm_of abc_fourtimes @ shift (mopup (Suc 0)) qa))"
-        apply(rule_tac tm_wf_change_termi)
-        using wf_fourtimes h
-        apply(simp add: t_fourtimes_compile_def)
+        (mopup_n_tm (Suc 0)) qa) div 2)) (adjust0 (tm_of abc_fourtimes @ shift (mopup_n_tm (Suc 0)) qa))"
+        apply(rule_tac composable_tm_change_termi)
+        using composable_fourtimes_tm h
+        apply(simp add: fourtimes_compile_tm_def)
         done
       thus "list_all (\<lambda>(acn, st). st \<le> 9 + qa)
-        (adjust (tm_of abc_fourtimes @ shift (mopup (Suc 0)) qa)
-          (Suc (length (tm_of abc_fourtimes @ shift (mopup (Suc 0)) qa) div
+        (adjust (tm_of abc_fourtimes @ shift (mopup_n_tm (Suc 0)) qa)
+          (Suc (length (tm_of abc_fourtimes @ shift (mopup_n_tm (Suc 0)) qa) div
                 2)))"
         using h
         apply(simp)
         done
     qed
     thus "list_all
      (\<lambda>(acn, st). st \<le> 30 + (length (tm_of abc_twice) div 2 + length (tm_of abc_fourtimes) div 2))
      (shift
-       (adjust (tm_of abc_fourtimes @ shift (mopup (Suc 0)) (length (tm_of abc_fourtimes) div 2))
+       (adjust (tm_of abc_fourtimes @ shift (mopup_n_tm (Suc 0)) (length (tm_of abc_fourtimes) div 2))
          (9 + length (tm_of abc_fourtimes) div 2))
        (21 + length (tm_of abc_twice) div 2))"
       apply(subgoal_tac "qa + q = q + qa")
        apply(simp add: h)
       apply(simp)
       done
   qed
   thus "b \<le> (60 + (length (tm_of abc_twice) + length (tm_of abc_fourtimes))) div 2"
     using g
     apply(simp add: Ball_set[THEN sym])
     apply(erule_tac x = "(a, b)" in ballE, simp, simp)
     done
 qed
 
-lemma tm_wf_t_wcode_main[intro]: "tm_wf (t_wcode_main, 0)"
-  by(auto simp: t_wcode_main_def tm_wf.simps
-      t_twice_def t_fourtimes_def del: List.list_all_iff)
-
-declare tm_comp.simps[simp del]
+lemma composable_tm_wcode_main_tm[intro]: "composable_tm (wcode_main_tm, 0)"
+  by(auto simp: wcode_main_tm_def composable_tm.simps
+      twice_tm_def fourtimes_tm_def )
 
 lemma prepare_mainpart_lemma:
   "args \<noteq> [] \<Longrightarrow> 
-  \<exists> stp ln rn. steps0 (Suc 0, [], <m # args>) (t_wcode_prepare |+| t_wcode_main) stp
+  \<exists> stp ln rn. steps0 (Suc 0, [], <m # args>) (wcode_prepare_tm |+| wcode_main_tm) stp
               = (0,  Bk # Oc\<up>(Suc m), Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(bl_bin (<args>)) @ Bk\<up>(rn))"
 proof -
   let ?P1 = "(\<lambda> (l, r). (l::cell list) = [] \<and> r = <m # args>)"
   let ?Q1 = "(\<lambda> (l, r). wprepare_stop m args (l, r))"
   let ?P2 = ?Q1
   let ?Q2 = "(\<lambda> (l, r). (\<exists> ln rn. l = Bk # Oc\<up>(Suc m) \<and>
                            r =  Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(bl_bin (<args>)) @ Bk\<up>(rn)))"
   let ?P3 = "\<lambda> tp. False"
   assume h: "args \<noteq> []"
-  have "{?P1} t_wcode_prepare |+| t_wcode_main {?Q2}"
+  have " \<lbrace>?P1\<rbrace> wcode_prepare_tm |+| wcode_main_tm \<lbrace>?Q2\<rbrace>"
   proof(rule_tac Hoare_plus_halt)
-    show "{?P1} t_wcode_prepare {?Q1}"
+    show " \<lbrace>?P1\<rbrace>  wcode_prepare_tm \<lbrace>?Q1\<rbrace> "
     proof(rule_tac Hoare_haltI, auto)
-      show "\<exists>n. is_final (steps0 (Suc 0, [], <m # args>) t_wcode_prepare n) \<and>
-        wprepare_stop m args holds_for steps0 (Suc 0, [], <m # args>) t_wcode_prepare n"
+      show "\<exists>n. is_final (steps0 (Suc 0, [], <m # args>) wcode_prepare_tm n) \<and>
+        wprepare_stop m args holds_for steps0 (Suc 0, [], <m # args>) wcode_prepare_tm n"
         using wprepare_correctness[of args m,OF h]
         apply(auto simp add: wprepare_inv.simps)
         by (metis holds_for.simps is_finalI)
     qed
   next
-    show "{?P2} t_wcode_main {?Q2}"
+    show " \<lbrace>?P2\<rbrace>  wcode_main_tm \<lbrace>?Q2\<rbrace>"
     proof(rule_tac Hoare_haltI, auto)
       fix l r
       assume "wprepare_stop m args (l, r)"
-      thus "\<exists>n. is_final (steps0 (Suc 0, l, r) t_wcode_main n) \<and>
+      thus "\<exists>n. is_final (steps0 (Suc 0, l, r) wcode_main_tm n) \<and>
               (\<lambda>(l, r). l = Bk # Oc # Oc \<up> m \<and> (\<exists>ln rn. r = Bk # Oc # Bk \<up> ln @ 
-        Bk # Bk # Oc \<up> bl_bin (<args>) @ Bk \<up> rn)) holds_for steps0 (Suc 0, l, r) t_wcode_main n"
+        Bk # Bk # Oc \<up> bl_bin (<args>) @ Bk \<up> rn)) holds_for steps0 (Suc 0, l, r) wcode_main_tm n"
       proof(auto simp: wprepare_stop.simps)
         fix rn
-        show " \<exists>n. is_final (steps0 (Suc 0, Bk # <rev args> @ Bk # Bk # Oc # Oc \<up> m, Bk # Oc # Bk \<up> rn) t_wcode_main n) \<and>
+        show " \<exists>n. is_final (steps0 (Suc 0, Bk # <rev args> @ Bk # Bk # Oc # Oc \<up> m, Bk # Oc # Bk \<up> rn) wcode_main_tm n) \<and>
           (\<lambda>(l, r). l = Bk # Oc # Oc \<up> m \<and>
           (\<exists>ln rn. r = Bk # Oc # Bk \<up> ln @
           Bk # Bk # Oc \<up> bl_bin (<args>) @
-          Bk \<up> rn)) holds_for steps0 (Suc 0, Bk # <rev args> @ Bk # Bk # Oc # Oc \<up> m, Bk # Oc # Bk \<up> rn) t_wcode_main n"
-          using t_wcode_main_lemma_pre[of "args" "<args>" 0 "Oc\<up>(Suc m)" 0 rn,OF h refl]
+          Bk \<up> rn)) holds_for steps0 (Suc 0, Bk # <rev args> @ Bk # Bk # Oc # Oc \<up> m, Bk # Oc # Bk \<up> rn) wcode_main_tm n"
+          using wcode_main_tm_lemma_pre[of "args" "<args>" 0 "Oc\<up>(Suc m)" 0 rn,OF h refl]
           apply(auto simp: tape_of_nl_rev)
           apply(rename_tac stp ln rna)
           apply(rule_tac x = stp in exI, auto)
           done
       qed
     qed
   next
-    show "tm_wf0 t_wcode_prepare"
+    show "composable_tm0 wcode_prepare_tm"
       by auto
   qed
   then obtain n 
     where "\<And> tp. (case tp of (l, r) \<Rightarrow> l = [] \<and> r = <m # args>) \<longrightarrow>
-       (is_final (steps0 (1, tp) (t_wcode_prepare |+| t_wcode_main) n) \<and>
+       (is_final (steps0 (1, tp) (wcode_prepare_tm |+| wcode_main_tm) n) \<and>
             (\<lambda>(l, r).
                 \<exists>ln rn.
                    l = Bk # Oc \<up> Suc m \<and>
-                   r = Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> bl_bin (<args>) @ Bk \<up> rn) holds_for steps0 (1, tp) (t_wcode_prepare |+| t_wcode_main) n)"
+                   r = Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> bl_bin (<args>) @ Bk \<up> rn) holds_for steps0 (1, tp) (wcode_prepare_tm |+| wcode_main_tm) n)"
     unfolding Hoare_halt_def by auto
   thus "?thesis"
     apply(rule_tac x = n in exI)
     apply(case_tac "(steps0 (Suc 0, [], <m # args>)
-      (adjust0 t_wcode_prepare @ shift t_wcode_main (length t_wcode_prepare div 2)) n)")
-    apply(auto simp: tm_comp.simps)
+      (adjust0 wcode_prepare_tm @ shift wcode_main_tm (length wcode_prepare_tm div 2)) n)")
+    apply(auto simp: seq_tm.simps)
     done
 qed
 
 definition tinres :: "cell list \<Rightarrow> cell list \<Rightarrow> bool"
   where
     "tinres xs ys = (\<exists>n. xs = ys @ Bk \<up> n \<or> ys = xs @ Bk \<up> n)"
 
 lemma tinres_fetch_congr[simp]:  "tinres r r' \<Longrightarrow> 
   fetch t ss (read r) = 
   fetch t ss (read r')"
   apply(simp add: fetch.simps, auto split: if_splits simp: tinres_def)
   using hd_replicate apply fastforce
   using hd_replicate apply fastforce
   done
 
 lemma nonempty_hd_tinres[simp]: "\<lbrakk>tinres r r'; r \<noteq> []; r' \<noteq> []\<rbrakk> \<Longrightarrow> hd r = hd r'"
   apply(auto simp: tinres_def)
   done
 
 lemma tinres_nonempty[simp]:
   "\<lbrakk>tinres r []; r \<noteq> []\<rbrakk> \<Longrightarrow> hd r = Bk"
   "\<lbrakk>tinres [] r'; r' \<noteq> []\<rbrakk> \<Longrightarrow> hd r' = Bk"
   "\<lbrakk>tinres r [];  r \<noteq> []\<rbrakk> \<Longrightarrow> tinres (tl r) []"
   "tinres r r' \<Longrightarrow> tinres (b # r) (b # r')"
   by(auto simp: tinres_def)
 
 lemma ex_move_tl[intro]: "\<exists>na. tl r = tl (r @ Bk\<up>(n)) @ Bk\<up>(na) \<or> tl (r @ Bk\<up>(n)) = tl r @ Bk\<up>(na)"
   apply(case_tac r, simp)
   by(case_tac n, auto)
 
 lemma tinres_tails[simp]: "tinres r r' \<Longrightarrow> tinres (tl r) (tl r')"
   apply(auto simp: tinres_def)
   by(case_tac r', auto)
 
 lemma tinres_empty[simp]: 
   "\<lbrakk>tinres [] r'\<rbrakk> \<Longrightarrow> tinres [] (tl r')"
   "tinres r [] \<Longrightarrow> tinres (Bk # tl r) [Bk]"
   "tinres r [] \<Longrightarrow> tinres (Oc # tl r) [Oc]"
   by(auto simp: tinres_def)
 
 lemma tinres_step2:
   assumes "tinres r r'" "step0 (ss, l, r) t = (sa, la, ra)" "step0 (ss, l, r') t = (sb, lb, rb)"
   shows "la = lb \<and> tinres ra rb \<and> sa = sb"
 proof (cases "fetch t ss (read r')")
   case (Pair a b)
   have sa:"sa = sb" using assms Pair by(force simp: step.simps)
   have "la = lb \<and> tinres ra rb" using assms Pair
     by(cases a, auto simp: step.simps split: if_splits)
   thus ?thesis using sa by auto
 qed
 
 lemma tinres_steps2: 
   "\<lbrakk>tinres r r'; steps0 (ss, l, r) t stp = (sa, la, ra); steps0 (ss, l, r') t stp = (sb, lb, rb)\<rbrakk>
     \<Longrightarrow> la = lb \<and> tinres ra rb \<and> sa = sb"
 proof(induct stp arbitrary: sa la ra sb lb rb)
   case (Suc stp sa la ra sb lb rb)
   then show ?case 
     apply(simp)
     apply(case_tac "(steps0 (ss, l, r) t stp)")
     apply(case_tac "(steps0 (ss, l, r') t stp)")
   proof -
     fix stp a b c aa ba ca
     assume ind: "\<And>sa la ra sb lb rb. \<lbrakk>steps0 (ss, l, r) t stp = (sa, la, ra); 
     steps0 (ss, l, r') t stp = (sb, lb, rb)\<rbrakk> \<Longrightarrow> la = lb \<and> tinres ra rb \<and> sa = sb"
       and h: " tinres r r'" "step0 (steps0 (ss, l, r) t stp) t = (sa, la, ra)"
       "step0 (steps0 (ss, l, r') t stp) t = (sb, lb, rb)" "steps0 (ss, l, r) t stp = (a, b, c)" 
       "steps0 (ss, l, r') t stp = (aa, ba, ca)"
     have "b = ba \<and> tinres c ca \<and> a = aa"
       apply(rule_tac ind, simp_all add: h)
       done
     thus "la = lb \<and> tinres ra rb \<and> sa = sb"
       apply(rule_tac l = b  and r = c  and ss = a and r' = ca   
           and t = t in tinres_step2)
       using h
         apply(simp, simp, simp)
       done
   qed
 qed (simp add: steps.simps)
 
 
-definition t_wcode_adjust :: "instr list"
+definition wcode_adjust_tm :: "instr list"
   where
-    "t_wcode_adjust = [(W1, 1), (R, 2), (Nop, 2), (R, 3), (R, 3), (R, 4), 
-                   (L, 8), (L, 5), (L, 6), (W0, 5), (L, 6), (R, 7), 
-                   (W1, 2), (Nop, 7), (L, 9), (W0, 8), (L, 9), (L, 10), 
+    "wcode_adjust_tm = [(WO, 1), (R, 2), (Nop, 2), (R, 3), (R, 3), (R, 4), 
+                   (L, 8), (L, 5), (L, 6), (WB, 5), (L, 6), (R, 7), 
+                   (WO, 2), (Nop, 7), (L, 9), (WB, 8), (L, 9), (L, 10), 
                     (L, 11), (L, 10), (R, 0), (L, 11)]"
 
-lemma fetch_t_wcode_adjust[simp]:
-  "fetch t_wcode_adjust (Suc 0) Bk = (W1, 1)"
-  "fetch t_wcode_adjust (Suc 0) Oc = (R, 2)"
-  "fetch t_wcode_adjust (Suc (Suc 0)) Oc = (R, 3)"
-  "fetch t_wcode_adjust (Suc (Suc (Suc 0))) Oc = (R, 4)"
-  "fetch t_wcode_adjust  (Suc (Suc (Suc 0))) Bk = (R, 3)"
-  "fetch t_wcode_adjust 4 Bk = (L, 8)"
-  "fetch t_wcode_adjust 4 Oc = (L, 5)"
-  "fetch t_wcode_adjust 5 Oc = (W0, 5)"
-  "fetch t_wcode_adjust 5 Bk = (L, 6)"
-  "fetch t_wcode_adjust 6 Oc = (R, 7)"
-  "fetch t_wcode_adjust 6 Bk = (L, 6)"
-  "fetch t_wcode_adjust 7 Bk = (W1, 2)"
-  "fetch t_wcode_adjust 8 Bk = (L, 9)"
-  "fetch t_wcode_adjust 8 Oc = (W0, 8)"
-  "fetch t_wcode_adjust 9 Oc = (L, 10)"
-  "fetch t_wcode_adjust 9 Bk = (L, 9)"
-  "fetch t_wcode_adjust 10 Bk = (L, 11)"
-  "fetch t_wcode_adjust 10 Oc = (L, 10)"
-  "fetch t_wcode_adjust 11 Oc = (L, 11)"
-  "fetch t_wcode_adjust 11 Bk = (R, 0)"
-  by(auto simp: fetch.simps t_wcode_adjust_def nth_of.simps numeral)
+lemma fetch_wcode_adjust_tm[simp]:
+  "fetch wcode_adjust_tm (Suc 0) Bk = (WO, 1)"
+  "fetch wcode_adjust_tm (Suc 0) Oc = (R, 2)"
+  "fetch wcode_adjust_tm (Suc (Suc 0)) Oc = (R, 3)"
+  "fetch wcode_adjust_tm (Suc (Suc (Suc 0))) Oc = (R, 4)"
+  "fetch wcode_adjust_tm  (Suc (Suc (Suc 0))) Bk = (R, 3)"
+  "fetch wcode_adjust_tm 4 Bk = (L, 8)"
+  "fetch wcode_adjust_tm 4 Oc = (L, 5)"
+  "fetch wcode_adjust_tm 5 Oc = (WB, 5)"
+  "fetch wcode_adjust_tm 5 Bk = (L, 6)"
+  "fetch wcode_adjust_tm 6 Oc = (R, 7)"
+  "fetch wcode_adjust_tm 6 Bk = (L, 6)"
+  "fetch wcode_adjust_tm 7 Bk = (WO, 2)"
+  "fetch wcode_adjust_tm 8 Bk = (L, 9)"
+  "fetch wcode_adjust_tm 8 Oc = (WB, 8)"
+  "fetch wcode_adjust_tm 9 Oc = (L, 10)"
+  "fetch wcode_adjust_tm 9 Bk = (L, 9)"
+  "fetch wcode_adjust_tm 10 Bk = (L, 11)"
+  "fetch wcode_adjust_tm 10 Oc = (L, 10)"
+  "fetch wcode_adjust_tm 11 Oc = (L, 11)"
+  "fetch wcode_adjust_tm 11 Bk = (R, 0)"
+  by(auto simp: fetch.simps wcode_adjust_tm_def nth_of.simps numeral_eqs_upto_12)
 
 
 fun wadjust_start :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_start m rs (l, r) = 
          (\<exists> ln rn. l = Bk # Oc\<up>(Suc m) \<and>
                    tl r = Oc # Bk\<up>(ln) @ Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn))"
 
 fun wadjust_loop_start :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_loop_start m rs (l, r) = 
           (\<exists> ln rn ml mr. l = Oc\<up>(ml) @ Bk # Oc\<up>(Suc m)  \<and>
                           r = Oc # Bk\<up>(ln) @ Bk # Oc\<up>(mr) @ Bk\<up>(rn) \<and>
                           ml + mr = Suc (Suc rs) \<and> mr > 0)"
 
 fun wadjust_loop_right_move :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_loop_right_move m rs (l, r) = 
    (\<exists> ml mr nl nr rn. l = Bk\<up>(nl) @ Oc # Oc\<up>(ml) @ Bk # Oc\<up>(Suc m) \<and>
                       r = Bk\<up>(nr) @ Oc\<up>(mr) @ Bk\<up>(rn) \<and>
                       ml + mr = Suc (Suc rs) \<and> mr > 0 \<and>
                       nl + nr > 0)"
 
 fun wadjust_loop_check :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_loop_check m rs (l, r) = 
   (\<exists> ml mr ln rn. l = Oc # Bk\<up>(ln) @ Bk # Oc # Oc\<up>(ml) @ Bk # Oc\<up>(Suc m) \<and>
                   r = Oc\<up>(mr) @ Bk\<up>(rn) \<and> ml + mr = (Suc rs))"
 
 fun wadjust_loop_erase :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_loop_erase m rs (l, r) = 
     (\<exists> ml mr ln rn. l = Bk\<up>(ln) @ Bk # Oc # Oc\<up>(ml) @ Bk # Oc\<up>(Suc m) \<and>
                     tl r = Oc\<up>(mr) @ Bk\<up>(rn) \<and> ml + mr = (Suc rs) \<and> mr > 0)"
 
 fun wadjust_loop_on_left_moving_O :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_loop_on_left_moving_O m rs (l, r) = 
       (\<exists> ml mr ln rn. l = Oc\<up>(ml) @ Bk # Oc\<up>(Suc m )\<and>
                       r = Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(mr) @ Bk\<up>(rn) \<and>
                       ml + mr = Suc rs \<and> mr > 0)"
 
 fun wadjust_loop_on_left_moving_B :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_loop_on_left_moving_B m rs (l, r) = 
       (\<exists> ml mr nl nr rn. l = Bk\<up>(nl) @ Oc # Oc\<up>(ml) @ Bk # Oc\<up>(Suc m) \<and>
                          r = Bk\<up>(nr) @ Bk # Bk # Oc\<up>(mr) @ Bk\<up>(rn) \<and> 
                          ml + mr = Suc rs \<and> mr > 0)"
 
 fun wadjust_loop_on_left_moving :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_loop_on_left_moving m rs (l, r) = 
        (wadjust_loop_on_left_moving_O m rs (l, r) \<or>
        wadjust_loop_on_left_moving_B m rs (l, r))"
 
 fun wadjust_loop_right_move2 :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_loop_right_move2 m rs (l, r) = 
         (\<exists> ml mr ln rn. l = Oc # Oc\<up>(ml) @ Bk # Oc\<up>(Suc m) \<and>
                         r = Bk\<up>(ln) @ Bk # Bk # Oc\<up>(mr) @ Bk\<up>(rn) \<and>
                         ml + mr = Suc rs \<and> mr > 0)"
 
 fun wadjust_erase2 :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_erase2 m rs (l, r) = 
      (\<exists> ln rn. l = Bk\<up>(ln) @ Bk # Oc # Oc\<up>(Suc rs) @ Bk # Oc\<up>(Suc m) \<and>
                      tl r = Bk\<up>(rn))"
 
 fun wadjust_on_left_moving_O :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_on_left_moving_O m rs (l, r) = 
         (\<exists> rn. l = Oc\<up>(Suc rs) @ Bk # Oc\<up>(Suc m) \<and>
                   r = Oc # Bk\<up>(rn))"
 
 fun wadjust_on_left_moving_B :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_on_left_moving_B m rs (l, r) = 
          (\<exists> ln rn. l = Bk\<up>(ln) @ Oc # Oc\<up>(Suc rs) @ Bk # Oc\<up>(Suc m) \<and>
                    r = Bk\<up>(rn))"
 
 fun wadjust_on_left_moving :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_on_left_moving m rs (l, r) = 
       (wadjust_on_left_moving_O m rs (l, r) \<or>
        wadjust_on_left_moving_B m rs (l, r))"
 
 fun wadjust_goon_left_moving_B :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where 
     "wadjust_goon_left_moving_B m rs (l, r) = 
         (\<exists> rn. l = Oc\<up>(Suc m) \<and> 
                r = Bk # Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rn))"
 
 fun wadjust_goon_left_moving_O :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_goon_left_moving_O m rs (l, r) = 
       (\<exists> ml mr rn. l = Oc\<up>(ml) @ Bk # Oc\<up>(Suc m) \<and>
                       r = Oc\<up>(mr) @ Bk\<up>(rn) \<and> 
                       ml + mr = Suc (Suc rs) \<and> mr > 0)"
 
 fun wadjust_goon_left_moving :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_goon_left_moving m rs (l, r) = 
             (wadjust_goon_left_moving_B m rs (l, r) \<or>
              wadjust_goon_left_moving_O m rs (l, r))"
 
 fun wadjust_backto_standard_pos_B :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_backto_standard_pos_B m rs (l, r) =
         (\<exists> rn. l = [] \<and> 
                r = Bk # Oc\<up>(Suc m )@ Bk # Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rn))"
 
 fun wadjust_backto_standard_pos_O :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_backto_standard_pos_O m rs (l, r) = 
       (\<exists> ml mr rn. l = Oc\<up>(ml) \<and>
                       r = Oc\<up>(mr) @ Bk # Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rn) \<and> 
                       ml + mr = Suc m \<and> mr > 0)"
 
 fun wadjust_backto_standard_pos :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_backto_standard_pos m rs (l, r) = 
         (wadjust_backto_standard_pos_B m rs (l, r) \<or> 
         wadjust_backto_standard_pos_O m rs (l, r))"
 
 fun wadjust_stop :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_stop m rs (l, r) =
         (\<exists> rn. l = [Bk] \<and> 
                r = Oc\<up>(Suc m )@ Bk # Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rn))"
 
 declare wadjust_start.simps[simp del]  wadjust_loop_start.simps[simp del]
   wadjust_loop_right_move.simps[simp del]  wadjust_loop_check.simps[simp del]
   wadjust_loop_erase.simps[simp del] wadjust_loop_on_left_moving.simps[simp del]
   wadjust_loop_right_move2.simps[simp del] wadjust_erase2.simps[simp del]
   wadjust_on_left_moving_O.simps[simp del] wadjust_on_left_moving_B.simps[simp del]
   wadjust_on_left_moving.simps[simp del] wadjust_goon_left_moving_B.simps[simp del]
   wadjust_goon_left_moving_O.simps[simp del] wadjust_goon_left_moving.simps[simp del]
   wadjust_backto_standard_pos.simps[simp del] wadjust_backto_standard_pos_B.simps[simp del]
   wadjust_backto_standard_pos_O.simps[simp del] wadjust_stop.simps[simp del]
 
 fun wadjust_inv :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
   where
     "wadjust_inv st m rs (l, r) = 
        (if st = Suc 0 then wadjust_start m rs (l, r) 
         else if st = Suc (Suc 0) then wadjust_loop_start m rs (l, r)
         else if st = Suc (Suc (Suc 0)) then wadjust_loop_right_move m rs (l, r)
         else if st = 4 then wadjust_loop_check m rs (l, r)
         else if st = 5 then wadjust_loop_erase m rs (l, r)
         else if st = 6 then wadjust_loop_on_left_moving m rs (l, r)
         else if st = 7 then wadjust_loop_right_move2 m rs (l, r)
         else if st = 8 then wadjust_erase2 m rs (l, r)
         else if st = 9 then wadjust_on_left_moving m rs (l, r)
         else if st = 10 then wadjust_goon_left_moving m rs (l, r)
         else if st = 11 then wadjust_backto_standard_pos m rs (l, r)
         else if st = 0 then wadjust_stop m rs (l, r)
         else False
 )"
 
 declare wadjust_inv.simps[simp del]
 
 fun wadjust_phase :: "nat \<Rightarrow> config \<Rightarrow> nat"
   where
     "wadjust_phase rs (st, l, r) = 
          (if st = 1 then 3 
           else if st \<ge> 2 \<and> st \<le> 7 then 2
           else if st \<ge> 8 \<and> st \<le> 11 then 1
           else 0)"
 
 fun wadjust_stage :: "nat \<Rightarrow> config \<Rightarrow> nat"
   where
     "wadjust_stage rs (st, l, r) = 
            (if st \<ge> 2 \<and> st \<le> 7 then 
                   rs - length (takeWhile (\<lambda> a. a = Oc) 
                           (tl (dropWhile (\<lambda> a. a = Oc) (rev l @ r))))
             else 0)"
 
 fun wadjust_state :: "nat \<Rightarrow> config \<Rightarrow> nat"
   where
     "wadjust_state rs (st, l, r) = 
        (if st \<ge> 2 \<and> st \<le> 7 then 8 - st
         else if st \<ge> 8 \<and> st \<le> 11 then 12 - st
         else 0)"
 
 fun wadjust_step :: "nat \<Rightarrow> config \<Rightarrow> nat"
   where
     "wadjust_step rs (st, l, r) = 
        (if st = 1 then (if hd r = Bk then 1
                         else 0) 
         else if st = 3 then length r
         else if st = 5 then (if hd r = Oc then 1
                              else 0)
         else if st = 6 then length l
         else if st = 8 then (if hd r = Oc then 1
                              else 0)
         else if st = 9 then length l
         else if st = 10 then length l
         else if st = 11 then (if hd r = Bk then 0
                               else Suc (length l))
         else 0)"
 
 fun wadjust_measure :: "(nat \<times> config) \<Rightarrow> nat \<times> nat \<times> nat \<times> nat"
   where
     "wadjust_measure (rs, (st, l, r)) = 
      (wadjust_phase rs (st, l, r), 
       wadjust_stage rs (st, l, r),
       wadjust_state rs (st, l, r), 
       wadjust_step rs (st, l, r))"
 
 definition wadjust_le :: "((nat \<times> config) \<times> nat \<times> config) set"
   where "wadjust_le \<equiv> (inv_image lex_square wadjust_measure)"
 
 lemma wf_lex_square[intro]: "wf lex_square"
-  by(auto intro:wf_lex_prod simp: Abacus.lex_pair_def lex_square_def 
+  by(auto simp: Abacus.lex_pair_def lex_square_def 
       Abacus.lex_triple_def)
 
 lemma wf_wadjust_le[intro]: "wf wadjust_le"
-  by(auto intro:wf_inv_image simp: wadjust_le_def
+  by(auto  simp: wadjust_le_def
       Abacus.lex_triple_def Abacus.lex_pair_def)
 
 lemma wadjust_start_snd_nonempty[simp]: "wadjust_start m rs (c, []) = False"
   apply(auto simp: wadjust_start.simps)
   done
 
 lemma wadjust_loop_right_move_fst_nonempty[simp]: "wadjust_loop_right_move m rs (c, []) \<Longrightarrow> c \<noteq> []"
   apply(auto simp: wadjust_loop_right_move.simps)
   done
 
 lemma wadjust_loop_check_fst_nonempty[simp]: "wadjust_loop_check m rs (c, []) \<Longrightarrow> c \<noteq> []"
   apply(simp only: wadjust_loop_check.simps, auto)
   done
 
 lemma wadjust_loop_start_snd_nonempty[simp]: "wadjust_loop_start m rs (c, []) = False"
   apply(simp add: wadjust_loop_start.simps)
   done
 
 lemma wadjust_erase2_singleton[simp]: "wadjust_loop_check m rs (c, []) \<Longrightarrow> wadjust_erase2 m rs (tl c, [hd c])"
   apply(simp only: wadjust_loop_check.simps wadjust_erase2.simps, auto)
   done
 
 lemma wadjust_loop_on_left_moving_snd_nonempty[simp]:
   "wadjust_loop_on_left_moving m rs (c, []) = False"
   "wadjust_loop_right_move2 m rs (c, []) = False"
   "wadjust_erase2 m rs ([], []) = False"
   by(auto simp: wadjust_loop_on_left_moving.simps
       wadjust_loop_right_move2.simps
       wadjust_erase2.simps)
 
 lemma wadjust_on_left_moving_B_Bk1[simp]: "wadjust_on_left_moving_B m rs 
                  (Oc # Oc # Oc\<up>(rs) @ Bk # Oc # Oc\<up>(m), [Bk])"
   apply(simp add: wadjust_on_left_moving_B.simps, auto)
   done
 
 lemma wadjust_on_left_moving_B_Bk2[simp]: "wadjust_on_left_moving_B m rs 
                  (Bk\<up>(n) @ Bk # Oc # Oc # Oc\<up>(rs) @ Bk # Oc # Oc\<up>(m), [Bk])"
   apply(simp add: wadjust_on_left_moving_B.simps , auto)
   apply(rule_tac x = "Suc n" in exI, simp add: exp_ind del: replicate_Suc)
   done
 
 lemma wadjust_on_left_moving_singleton[simp]: "\<lbrakk>wadjust_erase2 m rs (c, []); c \<noteq> []\<rbrakk> \<Longrightarrow>
             wadjust_on_left_moving m rs (tl c, [hd c])" unfolding wadjust_erase2.simps
   apply(auto simp add: wadjust_on_left_moving.simps)
    apply (metis (no_types, lifting) empty_replicate hd_append hd_replicate list.sel(1) list.sel(3)
       self_append_conv2 tl_append2 tl_replicate
       wadjust_on_left_moving_B_Bk1 wadjust_on_left_moving_B_Bk2)+
   done
 
 lemma wadjust_erase2_cases[simp]: "wadjust_erase2 m rs (c, [])
     \<Longrightarrow> (c = [] \<longrightarrow> wadjust_on_left_moving m rs ([], [Bk])) \<and> 
        (c \<noteq> [] \<longrightarrow> wadjust_on_left_moving m rs (tl c, [hd c]))"
   apply(auto)
   done
 
 lemma wadjust_on_left_moving_nonempty[simp]:
   "wadjust_on_left_moving m rs ([], []) = False"
   "wadjust_on_left_moving_O m rs (c, []) = False"
    apply(auto simp: wadjust_on_left_moving.simps 
       wadjust_on_left_moving_O.simps wadjust_on_left_moving_B.simps)
   done
 
 lemma wadjust_on_left_moving_B_singleton_Bk[simp]:
   " \<lbrakk>wadjust_on_left_moving_B m rs (c, []); c \<noteq> []; hd c = Bk\<rbrakk> \<Longrightarrow>
                                       wadjust_on_left_moving_B m rs (tl c, [Bk])"
   apply(auto simp add: wadjust_on_left_moving_B.simps hd_append)
   by (metis cell.distinct(1) empty_replicate list.sel(1) tl_append2 tl_replicate)
 
 lemma wadjust_on_left_moving_B_singleton_Oc[simp]:
   "\<lbrakk>wadjust_on_left_moving_B m rs (c, []); c \<noteq> []; hd c = Oc\<rbrakk> \<Longrightarrow>
                                   wadjust_on_left_moving_O m rs (tl c, [Oc])"
   apply(auto simp add: wadjust_on_left_moving_B.simps wadjust_on_left_moving_O.simps hd_append)
    apply (metis cell.distinct(1) empty_replicate hd_replicate list.sel(3) self_append_conv2)+
   done
 
 lemma wadjust_on_left_moving_singleton2[simp]:
   "\<lbrakk>wadjust_on_left_moving m rs (c, []); c \<noteq> []\<rbrakk> \<Longrightarrow> 
   wadjust_on_left_moving m rs (tl c, [hd c])"
   apply(simp add: wadjust_on_left_moving.simps)
   apply(case_tac "hd c", simp_all)
   done
 
 lemma wadjust_nonempty[simp]: "wadjust_goon_left_moving m rs (c, []) = False"
   "wadjust_backto_standard_pos m rs (c, []) = False"
   by(auto simp: wadjust_goon_left_moving.simps wadjust_goon_left_moving_B.simps
       wadjust_goon_left_moving_O.simps wadjust_backto_standard_pos.simps
       wadjust_backto_standard_pos_B.simps wadjust_backto_standard_pos_O.simps)
 
 lemma wadjust_loop_start_no_Bk[simp]: "wadjust_loop_start m rs (c, Bk # list) = False"
   apply(auto simp: wadjust_loop_start.simps)
   done
 
 lemma wadjust_loop_check_nonempty[simp]: "wadjust_loop_check m rs (c, b) \<Longrightarrow> c \<noteq> []"
   apply(simp only: wadjust_loop_check.simps, auto)
   done
 
 lemma wadjust_erase2_via_loop_check_Bk[simp]: "wadjust_loop_check m rs (c, Bk # list)
               \<Longrightarrow>  wadjust_erase2 m rs (tl c, hd c # Bk # list)"
   by (auto simp: wadjust_loop_check.simps wadjust_erase2.simps)
 
 declare wadjust_loop_on_left_moving_O.simps[simp del]
   wadjust_loop_on_left_moving_B.simps[simp del]
 
 lemma wadjust_loop_on_left_moving_B_via_erase[simp]: "\<lbrakk>wadjust_loop_erase m rs (c, Bk # list); hd c = Bk\<rbrakk>
     \<Longrightarrow> wadjust_loop_on_left_moving_B m rs (tl c, Bk # Bk # list)"
   unfolding wadjust_loop_erase.simps wadjust_loop_on_left_moving_B.simps
   apply(erule_tac exE)+
   apply(rename_tac ml mr ln rn)
   apply(rule_tac x = ml in exI, rule_tac x = mr in exI, 
       rule_tac x = ln in exI, rule_tac x = 0 in exI)
   apply(case_tac ln, auto)
   apply(simp add: exp_ind [THEN sym])
   done
 
 lemma wadjust_loop_on_left_moving_O_Bk_via_erase[simp]:
   "\<lbrakk>wadjust_loop_erase m rs (c, Bk # list); c \<noteq> []; hd c = Oc\<rbrakk> \<Longrightarrow>
              wadjust_loop_on_left_moving_O m rs (tl c, Oc # Bk # list)"
   apply(auto simp: wadjust_loop_erase.simps wadjust_loop_on_left_moving_O.simps)
   by (metis cell.distinct(1) empty_replicate hd_append hd_replicate list.sel(1))
 
 lemma wadjust_loop_on_left_moving_Bk_via_erase[simp]: "\<lbrakk>wadjust_loop_erase m rs (c, Bk # list); c \<noteq> []\<rbrakk> \<Longrightarrow> 
                 wadjust_loop_on_left_moving m rs (tl c, hd c # Bk # list)"
   apply(case_tac "hd c", simp_all add:wadjust_loop_on_left_moving.simps)
   done
 
 
 lemma wadjust_loop_on_left_moving_B_Bk_move[simp]:
   "\<lbrakk>wadjust_loop_on_left_moving_B m rs (c, Bk # list); hd c = Bk\<rbrakk>
     \<Longrightarrow>  wadjust_loop_on_left_moving_B m rs (tl c, Bk # Bk # list)"
   apply(simp only: wadjust_loop_on_left_moving_B.simps)
   apply(erule_tac exE)+
   by (metis (no_types, lifting) cell.distinct(1) list.sel(1)
       replicate_Suc_iff_anywhere self_append_conv2 tl_append2 tl_replicate)
 
 lemma wadjust_loop_on_left_moving_O_Oc_move[simp]:
   "\<lbrakk>wadjust_loop_on_left_moving_B m rs (c, Bk # list); hd c = Oc\<rbrakk>
     \<Longrightarrow> wadjust_loop_on_left_moving_O m rs (tl c, Oc # Bk # list)"
   apply(simp only: wadjust_loop_on_left_moving_O.simps 
       wadjust_loop_on_left_moving_B.simps)
   by (metis cell.distinct(1) empty_replicate hd_append hd_replicate list.sel(3) self_append_conv2)
 
 
 lemma wadjust_loop_erase_nonempty[simp]: "wadjust_loop_erase m rs (c, b) \<Longrightarrow> c \<noteq> []"
   "wadjust_loop_on_left_moving m rs (c, b) \<Longrightarrow> c \<noteq> []"
   "wadjust_loop_right_move2 m rs (c, b) \<Longrightarrow> c \<noteq> []"
   "wadjust_erase2 m rs (c, Bk # list) \<Longrightarrow> c \<noteq> []"
   "wadjust_on_left_moving m rs (c,b) \<Longrightarrow> c \<noteq> []"
   "wadjust_on_left_moving_O m rs (c, Bk # list) = False"
   "wadjust_goon_left_moving m rs (c, b) \<Longrightarrow> c \<noteq> []"
   "wadjust_loop_on_left_moving_O m rs (c, Bk # list) = False"
   by(auto simp: wadjust_loop_erase.simps wadjust_loop_on_left_moving.simps 
       wadjust_loop_on_left_moving_O.simps wadjust_loop_on_left_moving_B.simps
       wadjust_loop_right_move2.simps wadjust_erase2.simps
       wadjust_on_left_moving.simps
       wadjust_on_left_moving_O.simps
       wadjust_on_left_moving_B.simps wadjust_goon_left_moving.simps
       wadjust_goon_left_moving_B.simps
       wadjust_goon_left_moving_O.simps)
 
 lemma wadjust_loop_on_left_moving_Bk_move[simp]:
   "wadjust_loop_on_left_moving m rs (c, Bk # list)
             \<Longrightarrow> wadjust_loop_on_left_moving m rs (tl c, hd c # Bk # list)"
   apply(simp add: wadjust_loop_on_left_moving.simps)
   apply(case_tac "hd c", simp_all)
   done
 
 lemma wadjust_loop_start_Oc_via_Bk_move[simp]: 
   "wadjust_loop_right_move2 m rs (c, Bk # list) \<Longrightarrow>  wadjust_loop_start m rs (c, Oc # list)"
   apply(auto simp: wadjust_loop_right_move2.simps wadjust_loop_start.simps replicate_app_Cons_same)
   by (metis add_Suc replicate_Suc)
 
 lemma wadjust_on_left_moving_Bk_via_erase[simp]: "wadjust_erase2 m rs (c, Bk # list) \<Longrightarrow> 
                  wadjust_on_left_moving m rs (tl c, hd c # Bk # list)"
   apply(auto simp: wadjust_erase2.simps wadjust_on_left_moving.simps replicate_app_Cons_same
       wadjust_on_left_moving_O.simps wadjust_on_left_moving_B.simps)
    apply (metis exp_ind replicate_append_same)+
   done
 
 
 lemma wadjust_on_left_moving_B_Bk_drop_one: "\<lbrakk>wadjust_on_left_moving_B m rs (c, Bk # list); hd c = Bk\<rbrakk>
     \<Longrightarrow> wadjust_on_left_moving_B m rs (tl c, Bk # Bk # list)"
   apply(auto simp: wadjust_on_left_moving_B.simps)
   by (metis cell.distinct(1) hd_append list.sel(1) tl_append2 tl_replicate)
 
 lemma wadjust_on_left_moving_B_Bk_drop_Oc: "\<lbrakk>wadjust_on_left_moving_B m rs (c, Bk # list); hd c = Oc\<rbrakk>
     \<Longrightarrow> wadjust_on_left_moving_O m rs (tl c, Oc # Bk # list)"
   apply(auto simp: wadjust_on_left_moving_O.simps wadjust_on_left_moving_B.simps)
   by (metis cell.distinct(1) empty_replicate hd_append hd_replicate list.sel(3) self_append_conv2)
 
 lemma wadjust_on_left_moving_B_drop[simp]: "wadjust_on_left_moving  m rs (c, Bk # list) \<Longrightarrow>  
                   wadjust_on_left_moving m rs (tl c, hd c # Bk # list)"
   by(cases "hd c", auto simp:wadjust_on_left_moving.simps wadjust_on_left_moving_B_Bk_drop_one
       wadjust_on_left_moving_B_Bk_drop_Oc)
 
 lemma wadjust_goon_left_moving_O_no_Bk[simp]: "wadjust_goon_left_moving_O m rs (c, Bk # list) = False"
   by (auto simp add: wadjust_goon_left_moving_O.simps)
 
 lemma wadjust_backto_standard_pos_via_left_Bk[simp]:
   "wadjust_goon_left_moving m rs (c, Bk # list) \<Longrightarrow>
   wadjust_backto_standard_pos m rs (tl c, hd c # Bk # list)"
   by(case_tac "hd c", simp_all add: wadjust_backto_standard_pos.simps wadjust_goon_left_moving.simps
       wadjust_goon_left_moving_B.simps wadjust_backto_standard_pos_O.simps)
 
 lemma wadjust_loop_right_move_Oc[simp]:
   "wadjust_loop_start m rs (c, Oc # list) \<Longrightarrow> wadjust_loop_right_move m rs (Oc # c, list)"
   apply(auto simp add: wadjust_loop_start.simps wadjust_loop_right_move.simps
       simp del:split_head_repeat)
   apply(rename_tac ln rn ml mr)
   apply(rule_tac x = ml in exI, rule_tac x = mr in exI, 
       rule_tac x = 0 in exI, simp)
   apply(rule_tac x = "Suc ln" in exI, simp add: exp_ind del: replicate_Suc)
   done
 
 lemma wadjust_loop_check_Oc[simp]:
   assumes "wadjust_loop_right_move m rs (c, Oc # list)" 
   shows "wadjust_loop_check m rs (Oc # c, list)"
 proof -
   from assms obtain ml mr nl nr rn
     where "c = Bk \<up> nl @ Oc # Oc \<up> ml @ Bk # Oc \<up> m @ [Oc]"
       "Oc # list = Bk \<up> nr @ Oc \<up> mr @ Bk \<up> rn"
       "ml + mr = Suc (Suc rs)" "0 < mr" "0 < nl + nr"
     unfolding wadjust_loop_right_move.simps exp_ind 
       wadjust_loop_check.simps by auto
   hence "\<exists>ln. Oc # c = Oc # Bk \<up> ln @ Bk # Oc # Oc \<up> ml @ Bk # Oc \<up> Suc m"
     "\<exists>rn. list = Oc \<up> (mr - 1) @ Bk \<up> rn" "ml + (mr - 1) = Suc rs"
     by(cases nl;cases nr;cases mr;force simp add: wadjust_loop_right_move.simps exp_ind 
         wadjust_loop_check.simps replicate_append_same)+
   thus ?thesis unfolding wadjust_loop_check.simps by auto
 qed
 
 lemma wadjust_loop_erase_move_Oc[simp]: "wadjust_loop_check m rs (c, Oc # list) \<Longrightarrow> 
                wadjust_loop_erase m rs (tl c, hd c # Oc # list)"
   apply(simp only: wadjust_loop_check.simps wadjust_loop_erase.simps)
   apply(erule_tac exE)+
   using Cons_replicate_eq by fastforce
 
 lemma wadjust_loop_on_move_no_Oc[simp]:
   "wadjust_loop_on_left_moving_B m rs (c, Oc # list) = False"
   "wadjust_loop_right_move2 m rs (c, Oc # list) = False"
   "wadjust_loop_on_left_moving m rs (c, Oc # list)
            \<Longrightarrow> wadjust_loop_right_move2 m rs (Oc # c, list)"
   "wadjust_on_left_moving_B m rs (c, Oc # list) = False"
   "wadjust_loop_erase m rs (c, Oc # list) \<Longrightarrow> 
                 wadjust_loop_erase m rs (c, Bk # list)"
   by(auto simp: wadjust_loop_on_left_moving_B.simps wadjust_loop_on_left_moving_O.simps
       wadjust_loop_right_move2.simps replicate_app_Cons_same wadjust_loop_on_left_moving.simps
       wadjust_on_left_moving_B.simps wadjust_loop_erase.simps)
 
 lemma wadjust_goon_left_moving_B_Bk_Oc: "\<lbrakk>wadjust_on_left_moving_O m rs (c, Oc # list); hd c = Bk\<rbrakk> \<Longrightarrow> 
          wadjust_goon_left_moving_B m rs (tl c, Bk # Oc # list)"
   apply(auto simp: wadjust_on_left_moving_O.simps 
       wadjust_goon_left_moving_B.simps )
   done
 
 lemma wadjust_goon_left_moving_O_Oc_Oc: "\<lbrakk>wadjust_on_left_moving_O m rs (c, Oc # list); hd c = Oc\<rbrakk>
     \<Longrightarrow> wadjust_goon_left_moving_O m rs (tl c, Oc # Oc # list)"
   apply(auto simp: wadjust_on_left_moving_O.simps 
       wadjust_goon_left_moving_O.simps )
   apply(auto simp:  numeral_2_eq_2)
   done
 
 
 lemma wadjust_goon_left_moving_Oc[simp]: "wadjust_on_left_moving m rs (c, Oc # list) \<Longrightarrow> 
               wadjust_goon_left_moving m rs (tl c, hd c # Oc # list)"
   by(cases "hd c"; force simp: wadjust_on_left_moving.simps wadjust_goon_left_moving.simps
       wadjust_goon_left_moving_B_Bk_Oc wadjust_goon_left_moving_O_Oc_Oc)+
 
 lemma left_moving_Bk_Oc[simp]: "\<lbrakk>wadjust_goon_left_moving_O m rs (c, Oc # list); hd c = Bk\<rbrakk> 
                \<Longrightarrow> wadjust_goon_left_moving_B m rs (tl c, Bk # Oc # list)"
   apply(auto simp: wadjust_goon_left_moving_O.simps wadjust_goon_left_moving_B.simps hd_append
       dest!: gr0_implies_Suc)
    apply (metis cell.distinct(1) empty_replicate hd_replicate list.sel(3) self_append_conv2)
   by (metis add_cancel_right_left cell.distinct(1) hd_replicate replicate_Suc_iff_anywhere)
 
 lemma  left_moving_Oc_Oc[simp]: "\<lbrakk>wadjust_goon_left_moving_O m rs (c, Oc # list); hd c = Oc\<rbrakk> \<Longrightarrow> 
   wadjust_goon_left_moving_O m rs (tl c, Oc # Oc # list)"
   apply(auto simp: wadjust_goon_left_moving_O.simps wadjust_goon_left_moving_B.simps)
   apply(rename_tac mlx mrx rnx)
   apply(rule_tac x = "mlx - 1" in exI, simp)
   apply(case_tac mlx, simp_all add: )
   apply(rule_tac x = "Suc mrx" in exI, auto simp: )
   done
 
 lemma wadjust_goon_left_moving_B_no_Oc[simp]:
   "wadjust_goon_left_moving_B m rs (c, Oc # list) = False"
   apply(auto simp: wadjust_goon_left_moving_B.simps)
   done
 
 lemma wadjust_goon_left_moving_Oc_move[simp]: "wadjust_goon_left_moving m rs (c, Oc # list) \<Longrightarrow> 
   wadjust_goon_left_moving m rs (tl c, hd c # Oc # list)"
   by(cases "hd c",auto simp: wadjust_goon_left_moving.simps)
 
 lemma wadjust_backto_standard_pos_B_no_Oc[simp]:
   "wadjust_backto_standard_pos_B m rs (c, Oc # list) = False"
   apply(simp add: wadjust_backto_standard_pos_B.simps)
   done
 
 lemma wadjust_backto_standard_pos_O_no_Bk[simp]:
   "wadjust_backto_standard_pos_O m rs (c, Bk # xs) = False"
   by(simp add: wadjust_backto_standard_pos_O.simps)
 
 lemma wadjust_backto_standard_pos_B_Bk_Oc[simp]:
   "wadjust_backto_standard_pos_O m rs ([], Oc # list) \<Longrightarrow> 
   wadjust_backto_standard_pos_B m rs ([], Bk # Oc # list)"
   apply(auto simp: wadjust_backto_standard_pos_O.simps
       wadjust_backto_standard_pos_B.simps)
   done
 
 lemma wadjust_backto_standard_pos_B_Bk_Oc_via_O[simp]: 
   "\<lbrakk>wadjust_backto_standard_pos_O m rs (c, Oc # list); c \<noteq> []; hd c = Bk\<rbrakk>
   \<Longrightarrow> wadjust_backto_standard_pos_B m rs (tl c, Bk # Oc # list)"
   apply(simp add:wadjust_backto_standard_pos_O.simps 
       wadjust_backto_standard_pos_B.simps, auto)
   done 
 
 lemma wadjust_backto_standard_pos_B_Oc_Oc_via_O[simp]: "\<lbrakk>wadjust_backto_standard_pos_O m rs (c, Oc # list); c \<noteq> []; hd c = Oc\<rbrakk>
           \<Longrightarrow>  wadjust_backto_standard_pos_O m rs (tl c, Oc # Oc # list)"
   apply(simp add: wadjust_backto_standard_pos_O.simps, auto)
   by force
 
 lemma wadjust_backto_standard_pos_cases[simp]: "wadjust_backto_standard_pos m rs (c, Oc # list)
   \<Longrightarrow> (c = [] \<longrightarrow> wadjust_backto_standard_pos m rs ([], Bk # Oc # list)) \<and> 
  (c \<noteq> [] \<longrightarrow> wadjust_backto_standard_pos m rs (tl c, hd c # Oc # list))"
   apply(auto simp: wadjust_backto_standard_pos.simps)
   apply(case_tac "hd c", simp_all)
   done
 
 lemma wadjust_loop_right_move_nonempty_snd[simp]: "wadjust_loop_right_move m rs (c, []) = False"
 proof -
   {fix nl ml mr rn nr
     have "(c = Bk \<up> nl @ Oc # Oc \<up> ml @ Bk # Oc \<up> Suc m \<and>
         [] = Bk \<up> nr @ Oc \<up> mr @ Bk \<up> rn \<and> ml + mr = Suc (Suc rs) \<and> 0 < mr \<and> 0 < nl + nr) =
     False" by auto
   } note t=this
   thus ?thesis unfolding wadjust_loop_right_move.simps t by blast
 qed
 
 lemma wadjust_loop_erase_nonempty_snd[simp]: "wadjust_loop_erase m rs (c, []) = False"
   apply(simp only: wadjust_loop_erase.simps, auto)
   done
 
 lemma wadjust_loop_erase_cases2[simp]: "\<lbrakk>Suc (Suc rs) = a;  wadjust_loop_erase m rs (c, Bk # list)\<rbrakk>
   \<Longrightarrow> a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev (tl c) @ hd c # Bk # list))))
   < a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Bk # list)))) \<or>
   a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev (tl c) @ hd c # Bk # list)))) =
   a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Bk # list))))"
   apply(simp only: wadjust_loop_erase.simps)
   apply(rule_tac disjI2)
   apply(case_tac c, simp, simp)
   done
 
 lemma dropWhile_exp1: "dropWhile (\<lambda>a. a = Oc) (Oc\<up>(n) @ xs) = dropWhile (\<lambda>a. a = Oc) xs"
   apply(induct n, simp_all add: )
   done
 lemma takeWhile_exp1: "takeWhile (\<lambda>a. a = Oc) (Oc\<up>(n) @ xs) = Oc\<up>(n) @ takeWhile (\<lambda>a. a = Oc) xs"
   apply(induct n, simp_all add: )
   done
 
 lemma wadjust_correctness_helper_1:
   assumes "Suc (Suc rs) = a" " wadjust_loop_right_move2 m rs (c, Bk # list)"
   shows "a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Oc # list))))
                  < a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Bk # list))))"
 proof -
   have "ml + mr = Suc rs \<Longrightarrow> 0 < mr \<Longrightarrow>
        rs - (ml + length (takeWhile (\<lambda>a. a = Oc) list))
        < Suc rs -
          (ml +
           length
            (takeWhile (\<lambda>a. a = Oc)
              (Bk \<up> ln @ Bk # Bk # Oc \<up> mr @ Bk \<up> rn))) "
     for ml mr ln rn
     by(cases ln, auto)
   thus ?thesis using assms
     by (auto simp: wadjust_loop_right_move2.simps dropWhile_exp1 takeWhile_exp1)
 qed
 
 lemma wadjust_correctness_helper_2:
   "\<lbrakk>Suc (Suc rs) = a;  wadjust_loop_on_left_moving m rs (c, Bk # list)\<rbrakk>
   \<Longrightarrow> a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev (tl c) @ hd c # Bk # list))))
   < a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Bk # list)))) \<or>
   a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev (tl c) @ hd c # Bk # list)))) =
   a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Bk # list))))"
   apply(subgoal_tac "c \<noteq> []")
    apply(case_tac c, simp_all)
   done
 
 lemma wadjust_loop_check_empty_false[simp]: "wadjust_loop_check m rs ([], b) = False"
   apply(simp add: wadjust_loop_check.simps)
   done
 
 lemma wadjust_loop_check_cases: "\<lbrakk>Suc (Suc rs) = a;  wadjust_loop_check m rs (c, Oc # list)\<rbrakk>
   \<Longrightarrow> a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev (tl c) @ hd c # Oc # list))))
   < a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Oc # list)))) \<or>
   a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev (tl c) @ hd c # Oc # list)))) =
   a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Oc # list))))"
   apply(case_tac "c", simp_all)
   done
 
 lemma wadjust_loop_erase_cases_or: 
   "\<lbrakk>Suc (Suc rs) = a;  wadjust_loop_erase m rs (c, Oc # list)\<rbrakk>
   \<Longrightarrow> a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Bk # list))))
   < a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Oc # list)))) \<or>
   a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Bk # list)))) =
   a - length (takeWhile (\<lambda>a. a = Oc) (tl (dropWhile (\<lambda>a. a = Oc) (rev c @ Oc # list))))"
   apply(simp add: wadjust_loop_erase.simps)
   apply(rule_tac disjI2)
   apply(auto)
   apply(simp add: dropWhile_exp1 takeWhile_exp1)
   done
 
 lemmas wadjust_correctness_helpers = wadjust_correctness_helper_2 wadjust_correctness_helper_1 wadjust_loop_erase_cases_or wadjust_loop_check_cases
 
 declare numeral_2_eq_2[simp del]
 
 lemma wadjust_start_Oc[simp]: "wadjust_start m rs (c, Bk # list)
        \<Longrightarrow> wadjust_start m rs (c, Oc # list)"
   apply(auto simp: wadjust_start.simps)
   done
 
 lemma wadjust_stop_Bk[simp]: "wadjust_backto_standard_pos m rs (c, Bk # list)
        \<Longrightarrow> wadjust_stop m rs (Bk # c, list)"
   apply(auto simp: wadjust_backto_standard_pos.simps 
       wadjust_stop.simps wadjust_backto_standard_pos_B.simps)
   done
 
 lemma wadjust_loop_start_Oc[simp]:
   assumes "wadjust_start m rs (c, Oc # list)"
   shows "wadjust_loop_start m rs (Oc # c, list)"
 proof -
   from assms[unfolded wadjust_start.simps] obtain ln rn where
     "c = Bk # Oc # Oc \<up> m" "list = Oc # Bk \<up> ln @ Bk # Oc # Oc \<up> rs @ Bk \<up> rn"
     by(auto)
   hence "Oc # c = Oc \<up> 1 @ Bk # Oc \<up> Suc m \<and>
        list = Oc # Bk \<up> ln @ Bk # Oc \<up>Suc rs @ Bk \<up> rn \<and> 1 + (Suc rs) = Suc (Suc rs) \<and> 0 < Suc rs"
     by auto
   thus ?thesis unfolding wadjust_loop_start.simps by blast
 qed
 
 lemma erase2_Bk_if_Oc[simp]:" wadjust_erase2 m rs (c, Oc # list)
        \<Longrightarrow> wadjust_erase2 m rs (c, Bk # list)"
   apply(auto simp: wadjust_erase2.simps)
   done
 
 lemma wadjust_loop_right_move_Bk[simp]: "wadjust_loop_right_move m rs (c, Bk # list)
     \<Longrightarrow> wadjust_loop_right_move m rs (Bk # c, list)"
   apply(simp only: wadjust_loop_right_move.simps)
   apply(erule_tac exE)+
   apply auto
    apply (metis cell.distinct(1) empty_replicate hd_append hd_replicate less_SucI
       list.sel(1) list.sel(3) neq0_conv replicate_Suc_iff_anywhere tl_append2 tl_replicate)+
   done
 
 lemma wadjust_correctness:
   shows "let P = (\<lambda> (len, st, l, r). st = 0) in 
   let Q = (\<lambda> (len, st, l, r). wadjust_inv st m rs (l, r)) in 
   let f = (\<lambda> stp. (Suc (Suc rs),  steps0 (Suc 0, Bk # Oc\<up>(Suc m), 
-                Bk # Oc # Bk\<up>(ln) @ Bk #  Oc\<up>(Suc rs) @ Bk\<up>(rn)) t_wcode_adjust stp)) in
+                Bk # Oc # Bk\<up>(ln) @ Bk #  Oc\<up>(Suc rs) @ Bk\<up>(rn)) wcode_adjust_tm stp)) in
     \<exists> n .P (f n) \<and> Q (f n)"
 proof -
   let ?P = "(\<lambda> (len, st, l, r). st = 0)"
   let ?Q = "\<lambda> (len, st, l, r). wadjust_inv st m rs (l, r)"
   let ?f = "\<lambda> stp. (Suc (Suc rs),  steps0 (Suc 0, Bk # Oc\<up>(Suc m), 
-                Bk # Oc # Bk\<up>(ln) @ Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn)) t_wcode_adjust stp)"
+                Bk # Oc # Bk\<up>(ln) @ Bk # Oc\<up>(Suc rs) @ Bk\<up>(rn)) wcode_adjust_tm stp)"
   have "\<exists> n. ?P (?f n) \<and> ?Q (?f n)"
   proof(rule_tac halt_lemma2)
     show "wf wadjust_le" by auto
   next
     { fix n assume a:"\<not> ?P (?f n) \<and> ?Q (?f n)"
       have "?Q (?f (Suc n)) \<and> (?f (Suc n), ?f n) \<in> wadjust_le"
       proof(cases "?f n")
         case (fields a b c d)
         then show ?thesis proof(cases d)
           case Nil
           then show ?thesis using a fields apply(simp add: step.simps)
             apply(simp_all only: wadjust_inv.simps split: if_splits)
                         apply(simp_all add: wadjust_inv.simps wadjust_le_def
                 wadjust_correctness_helpers
                 Abacus.lex_triple_def Abacus.lex_pair_def lex_square_def  split: if_splits).
         next
           case (Cons aa list)
           then show ?thesis using a fields Nil Cons
             apply((case_tac aa); simp add: step.simps)
              apply(simp_all only: wadjust_inv.simps split: if_splits)
                                 apply(simp_all)
                                apply(simp_all add: wadjust_inv.simps wadjust_le_def
                 wadjust_correctness_helpers
                 Abacus.lex_triple_def Abacus.lex_pair_def lex_square_def  split: if_splits).
         qed
       qed
     }
     thus "\<forall> n. \<not> ?P (?f n) \<and> ?Q (?f n) \<longrightarrow> 
                  ?Q (?f (Suc n)) \<and> (?f (Suc n), ?f n) \<in> wadjust_le" by auto
   next
     show "?Q (?f 0)" by(auto simp add: steps.simps wadjust_inv.simps wadjust_start.simps)
   next
     show "\<not> ?P (?f 0)" by (simp add: steps.simps)
   qed
   thus"?thesis" by simp
 qed
 
-lemma tm_wf_t_wcode_adjust[intro]: "tm_wf (t_wcode_adjust, 0)"
-  by(auto simp: t_wcode_adjust_def tm_wf.simps)
+lemma composable_tm_wcode_adjust_tm[intro]: "composable_tm (wcode_adjust_tm, 0)"
+  by(auto simp: wcode_adjust_tm_def composable_tm.simps)
 
 lemma bl_bin_nonzero[simp]: "args \<noteq> [] \<Longrightarrow> bl_bin (<args::nat list>) > 0"
   by(cases args)
     (auto simp: tape_of_nl_cons bl_bin.simps)
 
 lemma wcode_lemma_pre':
   "args \<noteq> [] \<Longrightarrow> 
   \<exists> stp rn. steps0 (Suc 0, [], <m # args>) 
-              ((t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust) stp
+              ((wcode_prepare_tm |+| wcode_main_tm) |+| wcode_adjust_tm) stp
   = (0,  [Bk],  Oc\<up>(Suc m) @ Bk # Oc\<up>(Suc (bl_bin (<args>))) @ Bk\<up>(rn))" 
 proof -
   let ?P1 = "\<lambda> (l, r). l = [] \<and> r = <m # args>"
   let ?Q1 = "\<lambda>(l, r). l = Bk # Oc\<up>(Suc m) \<and>
     (\<exists>ln rn. r = Bk # Oc # Bk\<up>(ln) @ Bk # Bk # Oc\<up>(bl_bin (<args>)) @ Bk\<up>(rn))"
   let ?P2 = ?Q1
   let ?Q2 = "\<lambda> (l, r). (wadjust_stop m (bl_bin (<args>) - 1) (l, r))"
   let ?P3 = "\<lambda> tp. False"
   assume h: "args \<noteq> []"
   hence a: "bl_bin (<args>) > 0"
     using h by simp
-  hence "{?P1} (t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust {?Q2}"
+  hence "\<lbrace>?P1\<rbrace> (wcode_prepare_tm |+| wcode_main_tm) |+| wcode_adjust_tm \<lbrace>?Q2\<rbrace>"
   proof(rule_tac Hoare_plus_halt)
   next
-    show "tm_wf (t_wcode_prepare |+| t_wcode_main, 0)"
-      by(rule_tac tm_comp_wf, auto)
+    show "composable_tm (wcode_prepare_tm |+| wcode_main_tm, 0)"
+      by(rule_tac seq_tm_composable, auto)
   next
-    show "{?P1} t_wcode_prepare |+| t_wcode_main {?Q1}"
+    show "\<lbrace>?P1\<rbrace> wcode_prepare_tm |+| wcode_main_tm \<lbrace>?Q1\<rbrace>"
     proof(rule_tac Hoare_haltI, auto)
       show 
-        "\<exists>n. is_final (steps0 (Suc 0, [], <m # args>) (t_wcode_prepare |+| t_wcode_main) n) \<and>
+        "\<exists>n. is_final (steps0 (Suc 0, [], <m # args>) (wcode_prepare_tm |+| wcode_main_tm) n) \<and>
         (\<lambda>(l, r). l = Bk # Oc # Oc \<up> m \<and>
         (\<exists>ln rn. r = Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> bl_bin (<args>) @ Bk \<up> rn))
-        holds_for steps0 (Suc 0, [], <m # args>) (t_wcode_prepare |+| t_wcode_main) n"
+        holds_for steps0 (Suc 0, [], <m # args>) (wcode_prepare_tm |+| wcode_main_tm) n"
         using h prepare_mainpart_lemma[of args m]
         apply(auto) apply(rename_tac stp ln rn)
         apply(rule_tac x = stp in exI, simp)
         apply(rule_tac x = ln in exI, auto)
         done
     qed
   next
-    show "{?P2} t_wcode_adjust {?Q2}"
+    show "\<lbrace>?P2\<rbrace> wcode_adjust_tm \<lbrace>?Q2\<rbrace>"
     proof(rule_tac Hoare_haltI, auto del: replicate_Suc)
       fix ln rn
       obtain n a b where "steps0
         (Suc 0, Bk # Oc \<up> m @ [Oc],
          Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> (bl_bin (<args>) - Suc 0) @ Oc # Bk \<up> rn)
-        t_wcode_adjust n = (0, a, b)"
+        wcode_adjust_tm n = (0, a, b)"
         "wadjust_inv 0 m (bl_bin (<args>) - Suc 0) (a, b)"
         using wadjust_correctness[of m "bl_bin (<args>) - 1" "Suc ln" rn,unfolded Let_def]
         by(simp del: replicate_Suc add: replicate_Suc[THEN sym] exp_ind, auto)
       thus "\<exists>n. is_final (steps0 (Suc 0, Bk # Oc # Oc \<up> m, 
-        Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> bl_bin (<args>) @ Bk \<up> rn) t_wcode_adjust n) \<and>
+        Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> bl_bin (<args>) @ Bk \<up> rn) wcode_adjust_tm n) \<and>
         wadjust_stop m (bl_bin (<args>) - Suc 0) holds_for steps0
-        (Suc 0, Bk # Oc # Oc \<up> m, Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> bl_bin (<args>) @ Bk \<up> rn) t_wcode_adjust n"
+        (Suc 0, Bk # Oc # Oc \<up> m, Bk # Oc # Bk \<up> ln @ Bk # Bk # Oc \<up> bl_bin (<args>) @ Bk \<up> rn) wcode_adjust_tm n"
         apply(rule_tac x = n in exI)
         using a
         apply(case_tac "bl_bin (<args>)", simp, simp del: replicate_Suc add: exp_ind wadjust_inv.simps)
         by (simp add: replicate_append_same)
     qed
   qed
   thus "?thesis"
     apply(simp add: Hoare_halt_def, auto)
     apply(rename_tac n)
     apply(case_tac "(steps0 (Suc 0, [], <(m::nat) # args>) 
-      ((t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust) n)")
+      ((wcode_prepare_tm |+| wcode_main_tm) |+| wcode_adjust_tm) n)")
     apply(rule_tac x = n in exI, auto simp: wadjust_stop.simps)
     using a
     apply(case_tac "bl_bin (<args>)", simp_all)
     done
 qed
 
 text \<open>
-  The initialization TM \<open>t_wcode\<close>.
+  The initialization TM \<open>wcode_tm\<close>.
 \<close>
-definition t_wcode :: "instr list"
+definition wcode_tm :: "instr list"
   where
-    "t_wcode = (t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust        "
+    "wcode_tm = (wcode_prepare_tm |+| wcode_main_tm) |+| wcode_adjust_tm"
 
 text \<open>
-  The correctness of \<open>t_wcode\<close>.
+  The correctness of \<open>wcode_tm\<close>.
 \<close>
 
 lemma wcode_lemma_1:
   "args \<noteq> [] \<Longrightarrow> 
-  \<exists> stp ln rn. steps0 (Suc 0, [], <m # args>)  (t_wcode) stp = 
+  \<exists> stp ln rn. steps0 (Suc 0, [], <m # args>)  (wcode_tm) stp = 
               (0,  [Bk],  Oc\<up>(Suc m) @ Bk # Oc\<up>(Suc (bl_bin (<args>))) @ Bk\<up>(rn))"
-  apply(simp add: wcode_lemma_pre' t_wcode_def del: replicate_Suc)
+  apply(simp add: wcode_lemma_pre' wcode_tm_def del: replicate_Suc)
   done
 
 lemma wcode_lemma: 
   "args \<noteq> [] \<Longrightarrow> 
-  \<exists> stp ln rn. steps0 (Suc 0, [], <m # args>)  (t_wcode) stp = 
+  \<exists> stp ln rn. steps0 (Suc 0, [], <m # args>)  (wcode_tm) stp = 
               (0,  [Bk],  <[m ,bl_bin (<args>)]> @ Bk\<up>(rn))"
   using wcode_lemma_1[of args m]
-  apply(simp add: t_wcode_def tape_of_list_def tape_of_nat_def)
+  apply(simp add: wcode_tm_def tape_of_list_def tape_of_nat_def)
   done
 
-section \<open>The universal TM\<close>
+section \<open>The Universal TM\<close>
 
 text \<open>
-  This section gives the explicit construction of {\em Universal Turing Machine}, defined as \<open>UTM\<close> and proves its 
+  This section gives the explicit construction of {\em Universal Turing Machine}, defined as \<open>utm\<close> and proves its 
   correctness. It is pretty easy by composing the partial results we have got so far.
 \<close>
 
-
-definition UTM :: "instr list"
+subsection \<open>Definition of the machine utm\<close>
+
+definition utm :: "instr list"
   where
-    "UTM = (let (aprog, rs_pos, a_md) = rec_ci rec_F in 
+    "utm = (let (aprog, rs_pos, a_md) = rec_ci rec_F in 
           let abc_F = aprog [+] dummy_abc (Suc (Suc 0)) in 
-          (t_wcode |+| (tm_of abc_F @ shift (mopup (Suc (Suc 0))) (length (tm_of abc_F) div 2))))"
-
-definition F_aprog :: "abc_prog"
+          (wcode_tm |+| (tm_of abc_F @ shift (mopup_n_tm (Suc (Suc 0))) (length (tm_of abc_F) div 2))))"
+
+definition f_aprog :: "abc_prog"
   where
-    "F_aprog \<equiv> (let (aprog, rs_pos, a_md) = rec_ci rec_F in 
+    "f_aprog \<equiv> (let (aprog, rs_pos, a_md) = rec_ci rec_F in 
                        aprog [+] dummy_abc (Suc (Suc 0)))"
 
-definition F_tprog :: "instr list"
-  where
-    "F_tprog = tm_of (F_aprog)"
-
-definition t_utm :: "instr list"
+definition f_tprog_tm :: "instr list"
   where
-    "t_utm \<equiv>
-     F_tprog @ shift (mopup (Suc (Suc 0))) (length F_tprog div 2)"
-
-definition UTM_pre :: "instr list"
+    "f_tprog_tm = tm_of (f_aprog)"
+
+definition utm_with_two_args :: "instr list"
   where
-    "UTM_pre = t_wcode |+| t_utm"
+    "utm_with_two_args \<equiv>
+     f_tprog_tm @ shift (mopup_n_tm (Suc (Suc 0))) (length f_tprog_tm div 2)"
+
+definition utm_pre_tm :: "instr list"
+  where
+    "utm_pre_tm = wcode_tm |+| utm_with_two_args"
+
+(* SPIKE FABR: some lemmas for clarification *)
+
+lemma fabr_spike_1:
+  "utm_with_two_args = tm_of (fst (rec_ci rec_F) [+] dummy_abc (Suc (Suc 0))) @ shift (mopup_n_tm (Suc (Suc 0)))
+                  (length (tm_of (fst (rec_ci rec_F) [+] dummy_abc (Suc (Suc 0)))) div 2)"
+proof (cases "rec_ci rec_F")
+  case (fields a b c)
+  then show ?thesis
+    by (simp add: fields f_aprog_def f_tprog_tm_def utm_with_two_args_def)
+qed
+
+lemma fabr_spike_2:
+  "utm = wcode_tm |+| 
+              tm_of (fst (rec_ci rec_F) [+] dummy_abc (Suc (Suc 0))) @ shift (mopup_n_tm (Suc (Suc 0)))
+                    (length (tm_of (fst (rec_ci rec_F) [+] dummy_abc (Suc (Suc 0)))) div 2)"   
+proof (cases "rec_ci rec_F")
+  case (fields a b c)
+  then show ?thesis
+    by (simp add: fields f_aprog_def f_tprog_tm_def utm_def)
+qed
+
+theorem fabr_spike_3: "utm = wcode_tm |+| utm_with_two_args"
+  using fabr_spike_1 fabr_spike_2
+  by auto
+
+corollary fabr_spike_4: "utm = utm_pre_tm"
+  using fabr_spike_3 utm_pre_tm_def
+  by auto
+
+(* END SPIKE *)
 
 lemma tinres_step1: 
   assumes "tinres l l'" "step (ss, l, r) (t, 0) = (sa, la, ra)" 
     "step (ss, l', r) (t, 0) = (sb, lb, rb)"
   shows "tinres la lb \<and> ra = rb \<and> sa = sb"
 proof(cases "r")
   case Nil
   then show ?thesis using assms
     by (cases "(fetch t ss Bk)";cases "fst (fetch t ss Bk)";auto simp:step.simps split:if_splits)
 next
   case (Cons a list)
   then show ?thesis using assms
     by (cases "(fetch t ss a)";cases "fst (fetch t ss a)";auto simp:step.simps split:if_splits)
 qed
 
 lemma tinres_steps1: 
   "\<lbrakk>tinres l l'; steps (ss, l, r) (t, 0) stp = (sa, la, ra); 
                  steps (ss, l', r) (t, 0) stp = (sb, lb, rb)\<rbrakk>
     \<Longrightarrow> tinres la lb \<and> ra = rb \<and> sa = sb"
 proof (induct stp arbitrary: sa la ra sb lb rb)
   case (Suc stp)
   then show ?case apply simp 
     apply(case_tac "(steps (ss, l, r) (t, 0) stp)")
     apply(case_tac "(steps (ss, l', r) (t, 0) stp)")
   proof -
     fix stp sa la ra sb lb rb a b c aa ba ca
     assume ind: "\<And>sa la ra sb lb rb. \<lbrakk>steps (ss, l, r) (t, 0) stp = (sa, (la::cell list), ra); 
           steps (ss, l', r) (t, 0) stp = (sb, lb, rb)\<rbrakk> \<Longrightarrow> tinres la lb \<and> ra = rb \<and> sa = sb"
       and h: " tinres l l'" "step (steps (ss, l, r) (t, 0) stp) (t, 0) = (sa, la, ra)"
       "step (steps (ss, l', r) (t, 0) stp) (t, 0) = (sb, lb, rb)" "steps (ss, l, r) (t, 0) stp = (a, b, c)" 
       "steps (ss, l', r) (t, 0) stp = (aa, ba, ca)"
     have "tinres b ba \<and> c = ca \<and> a = aa"
       using ind h by metis
     thus "tinres la lb \<and> ra = rb \<and> sa = sb"
       using tinres_step1 h by metis
   qed
 qed (simp add: steps.simps)
 
 lemma tinres_some_exp[simp]: 
   "tinres (Bk \<up> m @ [Bk, Bk]) la \<Longrightarrow> \<exists>m. la = Bk \<up> m" unfolding tinres_def
 proof -
   let ?c1 = "\<lambda> n. Bk \<up> m @ [Bk, Bk] = la @ Bk \<up> n"
   let ?c2 = "\<lambda> n. la = (Bk \<up> m @ [Bk, Bk]) @ Bk \<up> n"
   assume "\<exists>n. ?c1 n \<or> ?c2 n"
   then obtain n where "?c1 n \<or> ?c2 n" by auto
   then consider "?c1 n" | "?c2 n" by blast
   thus ?thesis proof(cases)
     case 1
     hence "Bk \<up> Suc (Suc m) = la @ Bk \<up> n"
       by (metis exp_ind append_Cons append_eq_append_conv2 self_append_conv2)
     hence "la = Bk \<up> (Suc (Suc m) - n)"
       by (metis replicate_add append_eq_append_conv diff_add_inverse2 length_append length_replicate)
     then show ?thesis by auto
   next
     case 2
     hence "la = Bk \<up> (m + Suc (Suc n))"
       by (metis append_Cons append_eq_append_conv2 replicate_Suc replicate_add self_append_conv2)
     then show ?thesis by blast
   qed
 qed
 
-lemma t_utm_halt_eq: 
-  assumes tm_wf: "tm_wf (tp, 0)"
+lemma utm_with_two_args_halt_eq: 
+  assumes composable_tm: "composable_tm (tp, 0)"
     and exec: "steps0 (Suc 0, Bk\<up>(l), <lm::nat list>) tp stp = (0, Bk\<up>(m), Oc\<up>(rs)@Bk\<up>(n))"
     and resutl: "0 < rs"
-  shows "\<exists>stp m n. steps0 (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<up>(i)) t_utm stp = 
+  shows "\<exists>stp m n. steps0 (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<up>(i)) utm_with_two_args stp = 
                                                 (0, Bk\<up>(m), Oc\<up>(rs) @ Bk\<up>(n))"
 proof -
   obtain ap arity fp where a: "rec_ci rec_F = (ap, arity, fp)"
     by (metis prod_cases3) 
   moreover have b: "rec_exec rec_F [code tp, (bl2wc (<lm>))] = (rs - Suc 0)"
     using assms
     apply(rule_tac F_correct, simp_all)
     done 
   have "\<exists> stp m l. steps0 (Suc 0, Bk # Bk # [], <[code tp, bl2wc (<lm>)]> @ Bk\<up>i)
-    (F_tprog @ shift (mopup (length [code tp, bl2wc (<lm>)])) (length F_tprog div 2)) stp
+    (f_tprog_tm @ shift (mopup_n_tm (length [code tp, bl2wc (<lm>)])) (length f_tprog_tm div 2)) stp
     = (0, Bk\<up>m @ Bk # Bk # [], Oc\<up>Suc (rec_exec rec_F [code tp, (bl2wc (<lm>))]) @ Bk\<up>l)"  
   proof(rule_tac recursive_compile_to_tm_correct1)
     show "rec_ci rec_F = (ap, arity, fp)" using a by simp
   next
     show "terminate rec_F [code tp, bl2wc (<lm>)]"
       using assms
       by(rule_tac terminate_F, simp_all)
   next
-    show "F_tprog = tm_of (ap [+] dummy_abc (length [code tp, bl2wc (<lm>)]))"
+    show "f_tprog_tm = tm_of (ap [+] dummy_abc (length [code tp, bl2wc (<lm>)]))"
       using a
-      apply(simp add: F_tprog_def F_aprog_def numeral_2_eq_2)
+      apply(simp add: f_tprog_tm_def f_aprog_def numeral_2_eq_2)
       done
   qed
   then obtain stp m l where 
     "steps0 (Suc 0, Bk # Bk # [], <[code tp, bl2wc (<lm>)]> @ Bk\<up>i)
-    (F_tprog @ shift (mopup (length [code tp, (bl2wc (<lm>))])) (length F_tprog div 2)) stp
+    (f_tprog_tm @ shift (mopup_n_tm (length [code tp, (bl2wc (<lm>))])) (length f_tprog_tm div 2)) stp
     = (0, Bk\<up>m @ Bk # Bk # [], Oc\<up>Suc (rec_exec rec_F [code tp, (bl2wc (<lm>))]) @ Bk\<up>l)" by blast
   hence "\<exists> m. steps0 (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<up>i)
-    (F_tprog @ shift (mopup 2) (length F_tprog div 2)) stp
+    (f_tprog_tm @ shift (mopup_n_tm 2) (length f_tprog_tm div 2)) stp
     = (0, Bk\<up>m, Oc\<up>Suc (rs - 1) @ Bk\<up>l)"
   proof -
     assume g: "steps0 (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]> @ Bk \<up> i)
-      (F_tprog @ shift (mopup (length [code tp, bl2wc (<lm>)])) (length F_tprog div 2)) stp =
+      (f_tprog_tm @ shift (mopup_n_tm (length [code tp, bl2wc (<lm>)])) (length f_tprog_tm div 2)) stp =
       (0, Bk \<up> m @ [Bk, Bk], Oc \<up> Suc ((rec_exec rec_F [code tp, bl2wc (<lm>)])) @ Bk \<up> l)"
     moreover have "tinres [Bk, Bk] [Bk]"
       apply(auto simp: tinres_def)
       done
     moreover obtain sa la ra where "steps0 (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<up>i)
-    (F_tprog @ shift (mopup 2) (length F_tprog div 2)) stp = (sa, la, ra)"
+    (f_tprog_tm @ shift (mopup_n_tm 2) (length f_tprog_tm div 2)) stp = (sa, la, ra)"
       apply(case_tac "steps0 (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<up>i)
-    (F_tprog @ shift (mopup 2) (length F_tprog div 2)) stp", auto)
+    (f_tprog_tm @ shift (mopup_n_tm 2) (length f_tprog_tm div 2)) stp", auto)
       done
     ultimately show "?thesis"
       using b
       apply(drule_tac la = "Bk\<up>m @ [Bk, Bk]" in tinres_steps1, auto simp: numeral_2_eq_2)
       done
   qed
   thus "?thesis"
     apply(auto)
-    apply(rule_tac x = stp in exI, simp add: t_utm_def)
+    apply(rule_tac x = stp in exI, simp add: utm_with_two_args_def)
     using assms
     apply(case_tac rs, simp_all add: numeral_2_eq_2)
     done
 qed
 
-lemma tm_wf_t_wcode[intro]: "tm_wf (t_wcode, 0)"
-  apply(simp add: t_wcode_def)
-  apply(rule_tac tm_comp_wf)
-   apply(rule_tac tm_comp_wf, auto)
+lemma composable_tm_wcode_tm[intro]: "composable_tm (wcode_tm, 0)"
+  apply(simp add: wcode_tm_def)
+  apply(rule_tac seq_tm_composable)
+   apply(rule_tac seq_tm_composable, auto)
   done
 
-lemma UTM_halt_lemma_pre: 
-  assumes wf_tm: "tm_wf (tp, 0)"
+lemma utm_halt_lemma_pre: 
+  assumes "composable_tm (tp, 0)"
     and result: "0 < rs"
     and args: "args \<noteq> []"
     and exec: "steps0 (Suc 0, Bk\<up>(i), <args::nat list>) tp stp = (0, Bk\<up>(m), Oc\<up>(rs)@Bk\<up>(k))"
-  shows "\<exists>stp m n. steps0 (Suc 0, [], <code tp # args>) UTM_pre stp = 
+  shows "\<exists>stp m n. steps0 (Suc 0, [], <code tp # args>) utm_pre_tm stp = 
                                                 (0, Bk\<up>(m), Oc\<up>(rs) @ Bk\<up>(n))"
 proof -
   let ?Q2 = "\<lambda> (l, r). (\<exists> ln rn. l = Bk\<up>(ln) \<and> r = Oc\<up>(rs) @ Bk\<up>(rn))"
   let ?P1 = "\<lambda> (l, r). l = [] \<and> r = <code tp # args>"
   let ?Q1 = "\<lambda> (l, r). (l = [Bk] \<and>
     (\<exists> rn. r = Oc\<up>(Suc (code tp)) @ Bk # Oc\<up>(Suc (bl_bin (<args>))) @ Bk\<up>(rn)))"
   let ?P2 = ?Q1
   let ?P3 = "\<lambda> (l, r). False"
-  have "{?P1} (t_wcode |+| t_utm) {?Q2}"
+  have "\<lbrace>?P1\<rbrace> (wcode_tm |+| utm_with_two_args) \<lbrace>?Q2\<rbrace>"
   proof(rule_tac Hoare_plus_halt)
-    show "tm_wf (t_wcode, 0)" by auto
+    show "composable_tm (wcode_tm, 0)" by auto
   next
-    show "{?P1} t_wcode {?Q1}"
+    show "\<lbrace>?P1\<rbrace> wcode_tm \<lbrace>?Q1\<rbrace>"
       apply(rule_tac Hoare_haltI, auto)
       using wcode_lemma_1[of args "code tp"] args
       apply(auto)
       by (metis (mono_tags, lifting) holds_for.simps is_finalI old.prod.case)
   next
-    show "{?P2} t_utm {?Q2}"
+    show "\<lbrace>?P2\<rbrace> utm_with_two_args \<lbrace>?Q2\<rbrace>"
     proof(rule_tac Hoare_haltI, auto)
       fix rn
-      show "\<exists>n. is_final (steps0 (Suc 0, [Bk], Oc # Oc \<up> code tp @ Bk # Oc # Oc \<up> bl_bin (<args>) @ Bk \<up> rn) t_utm n) \<and>
+      show "\<exists>n. is_final (steps0 (Suc 0, [Bk], Oc # Oc \<up> code tp @ Bk # Oc # Oc \<up> bl_bin (<args>) @ Bk \<up> rn) utm_with_two_args n) \<and>
         (\<lambda>(l, r). (\<exists>ln. l = Bk \<up> ln) \<and>
         (\<exists>rn. r = Oc \<up> rs @ Bk \<up> rn)) holds_for steps0 (Suc 0, [Bk],
-        Oc # Oc \<up> code tp @ Bk # Oc # Oc \<up> bl_bin (<args>) @ Bk \<up> rn) t_utm n"
-        using t_utm_halt_eq[of tp i "args" stp m rs k rn] assms
+        Oc # Oc \<up> code tp @ Bk # Oc # Oc \<up> bl_bin (<args>) @ Bk \<up> rn) utm_with_two_args n"
+        using utm_with_two_args_halt_eq[of tp i "args" stp m rs k rn] assms
         apply(auto simp: bin_wc_eq tape_of_list_def tape_of_nat_def)
         apply(rename_tac stpa) apply(rule_tac x = stpa in exI, simp)
         done
     qed
   qed
   thus "?thesis"
-    apply(auto simp: Hoare_halt_def UTM_pre_def)
-    apply(case_tac "steps0 (Suc 0, [], <code tp # args>) (t_wcode |+| t_utm) n",simp)
+    apply(auto simp: Hoare_halt_def utm_pre_tm_def)
+    apply(case_tac "steps0 (Suc 0, [], <code tp # args>) (wcode_tm |+| utm_with_two_args) n",simp)
     by auto
 qed
 
-text \<open>
-  The correctness of \<open>UTM\<close>, the halt case.
-\<close>
-lemma UTM_halt_lemma': 
-  assumes tm_wf: "tm_wf (tp, 0)"
+subsection \<open>The correctness of utm, the halt case\<close>
+
+lemma utm_halt_lemma': 
+  assumes composable_tm: "composable_tm (tp, 0)"
     and result: "0 < rs"
     and args: "args \<noteq> []"
     and exec: "steps0 (Suc 0, Bk\<up>(i), <args::nat list>) tp stp = (0, Bk\<up>(m), Oc\<up>(rs)@Bk\<up>(k))"
-  shows "\<exists>stp m n. steps0 (Suc 0, [], <code tp # args>) UTM stp = 
+  shows "\<exists>stp m n. steps0 (Suc 0, [], <code tp # args>) utm stp = 
                                                 (0, Bk\<up>(m), Oc\<up>(rs) @ Bk\<up>(n))"
-  using UTM_halt_lemma_pre[of tp rs args i stp m k] assms
-  apply(simp add: UTM_pre_def t_utm_def UTM_def F_aprog_def F_tprog_def)
+  using utm_halt_lemma_pre[of tp rs args i stp m k] assms
+  apply(simp add: utm_pre_tm_def utm_with_two_args_def utm_def f_aprog_def f_tprog_tm_def)
   apply(case_tac "rec_ci rec_F", simp)
   done
 
 definition TSTD:: "config \<Rightarrow> bool"
   where
     "TSTD c = (let (st, l, r) = c in 
              st = 0 \<and> (\<exists> m. l = Bk\<up>(m)) \<and> (\<exists> rs n. r = Oc\<up>(Suc rs) @ Bk\<up>(n)))"
 
 lemma nstd_case1: "0 < a \<Longrightarrow> NSTD (trpl_code (a, b, c))"
   by(simp add: NSTD.simps trpl_code.simps)
 
 lemma nonzero_bl2wc[simp]: "\<forall>m. b \<noteq> Bk\<up>(m) \<Longrightarrow> 0 < bl2wc b"
 proof -
   have "\<forall>m. b \<noteq> Bk \<up> m \<Longrightarrow> bl2wc b = 0 \<Longrightarrow> False" proof(induct b)
     case (Cons a b)
     then show ?case
       apply(simp add: bl2wc.simps, case_tac a, simp_all 
           add: bl2nat.simps bl2nat_double)
       apply(case_tac "\<exists> m. b = Bk\<up>(m)", erule exE)
        apply(metis append_Nil2 replicate_Suc_iff_anywhere) 
       by simp
   qed auto
   thus "\<forall>m. b \<noteq> Bk\<up>(m) \<Longrightarrow> 0 < bl2wc b" by auto
 qed
 
 lemma nstd_case2: "\<forall>m. b \<noteq> Bk\<up>(m) \<Longrightarrow> NSTD (trpl_code (a, b, c))"
   apply(simp add: NSTD.simps trpl_code.simps)
   done
 
 lemma even_not_odd[elim]: "Suc (2 * x) = 2 * y \<Longrightarrow> RR"
 proof(induct x arbitrary: y)
   case (Suc x) thus ?case by(cases y;auto)
 qed auto
 
 declare replicate_Suc[simp del]
 
 lemma bl2nat_zero_eq[simp]: "(bl2nat c 0 = 0) = (\<exists>n. c = Bk\<up>(n))"
 proof(induct c)
   case (Cons a c)
   then show ?case by (cases a;auto simp: bl2nat.simps bl2nat_double Cons_replicate_eq)
 qed (auto simp: bl2nat.simps)
 
 lemma bl2wc_exp_ex: 
   "\<lbrakk>Suc (bl2wc c) = 2 ^  m\<rbrakk> \<Longrightarrow> \<exists> rs n. c = Oc\<up>(rs) @ Bk\<up>(n)"
 proof(induct c arbitrary: m)
   case (Cons a c m)
   { fix n
     have "Bk # Bk \<up> n = Oc \<up> 0 @ Bk \<up> Suc n" by (auto simp:replicate_Suc)
     hence "\<exists>rs na. Bk # Bk \<up> n = Oc \<up> rs @ Bk \<up> na" by blast
   }
   with Cons show ?case apply(cases a, auto)
      apply(case_tac m, simp_all add: bl2wc.simps, auto)
     apply(simp add: bl2wc.simps bl2nat.simps bl2nat_double Cons)
     apply(case_tac m, simp, simp add: bin_wc_eq bl2wc.simps twice_power )
     by (metis Cons.hyps Suc_pred bl2wc.simps neq0_conv power_not_zero
         replicate_Suc_iff_anywhere zero_neq_numeral)
 qed (simp add: bl2wc.simps bl2nat.simps)
 
 lemma lg_bin: 
   assumes "\<forall>rs n. c \<noteq> Oc\<up>(Suc rs) @ Bk\<up>(n)" 
     "bl2wc c = 2 ^ lg (Suc (bl2wc c)) 2 - Suc 0"
   shows "bl2wc c = 0"
 proof -
   from assms obtain rs nat n where *:"2 ^ rs - Suc 0 = nat"
     "c = Oc \<up> rs @ Bk \<up> n" 
     using bl2wc_exp_ex[of c "lg (Suc (bl2wc c)) 2"]
     by(case_tac "(2::nat) ^ lg (Suc (bl2wc c)) 2", 
         simp, simp, erule_tac exE, erule_tac exE, simp)
   have r:"bl2wc (Oc \<up> rs) = nat" 
     by (metis "*"(1) bl2nat_exp_zero bl2wc.elims)
   hence "Suc (bl2wc c) = 2^rs" using *
     by(case_tac "(2::nat)^rs", auto)
   thus ?thesis using * assms(1)
     apply(drule_tac bl2wc_exp_ex, simp, erule_tac exE, erule_tac exE)
     by(case_tac rs, simp, simp)
 qed
 
 lemma nstd_case3: 
   "\<forall>rs n. c \<noteq> Oc\<up>(Suc rs) @ Bk\<up>(n) \<Longrightarrow>  NSTD (trpl_code (a, b, c))"
   apply(simp add: NSTD.simps trpl_code.simps)
   apply(auto)
   apply(drule_tac lg_bin, simp_all)
   done
 
 lemma NSTD_1: "\<not> TSTD (a, b, c)
     \<Longrightarrow> rec_exec rec_NSTD [trpl_code (a, b, c)] = Suc 0"
   using NSTD_lemma1[of "trpl_code (a, b, c)"]
     NSTD_lemma2[of "trpl_code (a, b, c)"]
   apply(simp add: TSTD_def)
   apply(erule_tac disjE, erule_tac nstd_case1)
   apply(erule_tac disjE, erule_tac nstd_case2)
   apply(erule_tac nstd_case3)
   done
 
 lemma nonstop_t_uhalt_eq:
-  "\<lbrakk>tm_wf (tp, 0);
+  "\<lbrakk>composable_tm (tp, 0);
   steps0 (Suc 0, Bk\<up>(l), <lm>) tp stp = (a, b, c);
   \<not> TSTD (a, b, c)\<rbrakk>
   \<Longrightarrow> rec_exec rec_nonstop [code tp, bl2wc (<lm>), stp] = Suc 0"
   apply(simp add: rec_nonstop_def rec_exec.simps)
   apply(subgoal_tac 
       "rec_exec rec_conf [code tp, bl2wc (<lm>), stp] =
   trpl_code (a, b, c)", simp)
    apply(erule_tac NSTD_1)
   using rec_t_eq_steps[of tp l lm stp]
   apply(simp)
   done
 
 lemma nonstop_true:
-  "\<lbrakk>tm_wf (tp, 0);
+  "\<lbrakk>composable_tm (tp, 0);
   \<forall> stp. (\<not> TSTD (steps0 (Suc 0, Bk\<up>(l), <lm>) tp stp))\<rbrakk>
   \<Longrightarrow> \<forall>y. rec_exec rec_nonstop ([code tp, bl2wc (<lm>), y]) = (Suc 0)"
 proof fix y
-  assume a:"tm_wf0 tp" "\<forall>stp. \<not> TSTD (steps0 (Suc 0, Bk \<up> l, <lm>) tp stp)"
+  assume a:"composable_tm0 tp" "\<forall>stp. \<not> TSTD (steps0 (Suc 0, Bk \<up> l, <lm>) tp stp)"
   hence "\<not> TSTD (steps0 (Suc 0, Bk \<up> l, <lm>) tp y)" by auto
   thus "rec_exec rec_nonstop [code tp, bl2wc (<lm>), y] = Suc 0"
     by (cases "steps0 (Suc 0, Bk\<up>(l), <lm>) tp y")
       (auto intro: nonstop_t_uhalt_eq[OF a(1)])
 qed
 
 lemma cn_arity:  "rec_ci (Cn n f gs) = (a, b, c) \<Longrightarrow> b = n"
   by(case_tac "rec_ci f", simp add: rec_ci.simps)
 
 lemma mn_arity: "rec_ci (Mn n f) = (a, b, c) \<Longrightarrow> b = n"
   by(case_tac "rec_ci f", simp add: rec_ci.simps)
 
-lemma F_aprog_uhalt: 
-  assumes wf_tm: "tm_wf (tp,0)"
+lemma f_aprog_uhalt: 
+  assumes "composable_tm (tp,0)"
     and unhalt:  "\<forall> stp. (\<not> TSTD (steps0 (Suc 0, Bk\<up>(l), <lm>) tp stp))"
     and compile: "rec_ci rec_F = (F_ap, rs_pos, a_md)"
-  shows "{\<lambda> nl. nl = [code tp, bl2wc (<lm>)] @ 0\<up>(a_md - rs_pos ) @ suflm} (F_ap) \<up>"
+  shows "\<lbrace>\<lambda> nl. nl = [code tp, bl2wc (<lm>)] @ 0\<up>(a_md - rs_pos ) @ suflm\<rbrace> (F_ap) \<up>"
   using compile
 proof(simp only: rec_F_def)
   assume h: "rec_ci (Cn (Suc (Suc 0)) rec_valu [Cn (Suc (Suc 0)) rec_right [Cn (Suc (Suc 0)) 
     rec_conf [recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), rec_halt]]]) =
     (F_ap, rs_pos, a_md)"
   moreover hence "rs_pos = Suc (Suc 0)"
     using cn_arity 
     by simp
   moreover obtain ap1 ar1 ft1 where a: "rec_ci 
     (Cn (Suc (Suc 0)) rec_right 
     [Cn (Suc (Suc 0)) rec_conf [recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), rec_halt]]) = (ap1, ar1, ft1)"
     by(case_tac "rec_ci (Cn (Suc (Suc 0)) rec_right [Cn (Suc (Suc 0)) 
       rec_conf [recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), rec_halt]])", auto)
   moreover hence b: "ar1 = Suc (Suc 0)"
     using cn_arity by simp
   ultimately show "?thesis"
   proof(rule_tac i = 0 in cn_unhalt_case, auto)
     fix anything
     obtain ap2 ar2 ft2 where c: 
       "rec_ci (Cn (Suc (Suc 0)) rec_conf [recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), rec_halt])
       = (ap2, ar2, ft2)" 
       by(case_tac "rec_ci (Cn (Suc (Suc 0)) rec_conf
         [recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), rec_halt])", auto)
     moreover hence d:"ar2 = Suc (Suc 0)"
       using cn_arity by simp
-    ultimately have "{\<lambda>nl. nl = [code tp, bl2wc (<lm>)] @ 0 \<up> (ft1 - Suc (Suc 0)) @ anything} ap1 \<up>"
+    ultimately have "\<lbrace>\<lambda>nl. nl = [code tp, bl2wc (<lm>)] @ 0 \<up> (ft1 - Suc (Suc 0)) @ anything\<rbrace> ap1 \<up>"
       using a b c d
     proof(rule_tac i = 0 in cn_unhalt_case, auto)
       fix anything
       obtain ap3 ar3 ft3 where e: "rec_ci rec_halt = (ap3, ar3, ft3)"
         by(case_tac "rec_ci rec_halt", auto)
       hence f: "ar3 = Suc (Suc 0)"
         using mn_arity
         by(simp add: rec_halt_def)
-      have "{\<lambda>nl. nl = [code tp, bl2wc (<lm>)] @ 0 \<up> (ft2 - Suc (Suc 0)) @ anything} ap2 \<up>"
+      have "\<lbrace>\<lambda>nl. nl = [code tp, bl2wc (<lm>)] @ 0 \<up> (ft2 - Suc (Suc 0)) @ anything\<rbrace> ap2 \<up>"
         using c d e f
       proof(rule_tac i = 2 in cn_unhalt_case, auto simp: rec_halt_def)
         fix anything
-        have "{\<lambda>nl. nl = [code tp, bl2wc (<lm>)] @ 0 \<up> (ft3 - Suc (Suc 0)) @ anything} ap3 \<up>"
+        have "\<lbrace>\<lambda>nl. nl = [code tp, bl2wc (<lm>)] @ 0 \<up> (ft3 - Suc (Suc 0)) @ anything\<rbrace> ap3 \<up>"
           using e f
         proof(rule_tac mn_unhalt_case, auto simp: rec_halt_def)
           fix i
           show "terminate rec_nonstop [code tp, bl2wc (<lm>), i]"
             by(rule_tac primerec_terminate, auto)
         next
           fix i
           show "0 < rec_exec rec_nonstop [code tp, bl2wc (<lm>), i]"
             using assms
             by(drule_tac nonstop_true, auto)
         qed
-        thus "{\<lambda>nl. nl = code tp # bl2wc (<lm>) # 0 \<up> (ft3 - Suc (Suc 0)) @ anything} ap3 \<up>" by simp
+        thus "\<lbrace>\<lambda>nl. nl = code tp # bl2wc (<lm>) # 0 \<up> (ft3 - Suc (Suc 0)) @ anything\<rbrace> ap3 \<up>" by simp
       next
         fix apj arj ftj j  anything
         assume "j<2" "rec_ci ([recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), Mn (Suc (Suc 0)) rec_nonstop] ! j) = (apj, arj, ftj)"
-        hence "{\<lambda>nl. nl = [code tp, bl2wc (<lm>)] @ 0 \<up> (ftj - arj) @ anything} apj
-          {\<lambda>nl. nl = [code tp, bl2wc (<lm>)] @
+        hence "\<lbrace>\<lambda>nl. nl = [code tp, bl2wc (<lm>)] @ 0 \<up> (ftj - arj) @ anything\<rbrace> apj
+          \<lbrace>\<lambda>nl. nl = [code tp, bl2wc (<lm>)] @
             rec_exec ([recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), Mn (Suc (Suc 0)) rec_nonstop] ! j) [code tp, bl2wc (<lm>)] # 
-               0 \<up> (ftj - Suc arj) @ anything}"
+               0 \<up> (ftj - Suc arj) @ anything\<rbrace>"
           apply(rule_tac recursive_compile_correct)
            apply(case_tac j, auto)
            apply(rule_tac [!] primerec_terminate)
           by(auto)
-        thus "{\<lambda>nl. nl = code tp # bl2wc (<lm>) # 0 \<up> (ftj - arj) @ anything} apj
-          {\<lambda>nl. nl = code tp # bl2wc (<lm>) # rec_exec ([recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0))
-          (Suc 0), Mn (Suc (Suc 0)) rec_nonstop] ! j) [code tp, bl2wc (<lm>)] # 0 \<up> (ftj - Suc arj) @ anything}"
+        thus "\<lbrace>\<lambda>nl. nl = code tp # bl2wc (<lm>) # 0 \<up> (ftj - arj) @ anything\<rbrace> apj
+          \<lbrace>\<lambda>nl. nl = code tp # bl2wc (<lm>) # rec_exec ([recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0))
+          (Suc 0), Mn (Suc (Suc 0)) rec_nonstop] ! j) [code tp, bl2wc (<lm>)] # 0 \<up> (ftj - Suc arj) @ anything\<rbrace>"
           by simp
       next
         fix j
         assume "(j::nat) < 2"
         thus "terminate ([recf.id (Suc (Suc 0)) 0, recf.id (Suc (Suc 0)) (Suc 0), Mn (Suc (Suc 0)) rec_nonstop] ! j)
           [code tp, bl2wc (<lm>)]"
           by(case_tac j, auto intro!: primerec_terminate)
       qed
-      thus "{\<lambda>nl. nl = code tp # bl2wc (<lm>) # 0 \<up> (ft2 - Suc (Suc 0)) @ anything} ap2 \<up>"
+      thus "\<lbrace>\<lambda>nl. nl = code tp # bl2wc (<lm>) # 0 \<up> (ft2 - Suc (Suc 0)) @ anything\<rbrace> ap2 \<up>"
         by simp
     qed
-    thus "{\<lambda>nl. nl = code tp # bl2wc (<lm>) # 0 \<up> (ft1 - Suc (Suc 0)) @ anything} ap1 \<up>" by simp
+    thus "\<lbrace>\<lambda>nl. nl = code tp # bl2wc (<lm>) # 0 \<up> (ft1 - Suc (Suc 0)) @ anything\<rbrace> ap1 \<up>" by simp
   qed
 qed
 
+
 lemma uabc_uhalt': 
-  "\<lbrakk>tm_wf (tp, 0);
+  "\<lbrakk>composable_tm (tp, 0);
   \<forall> stp. (\<not> TSTD (steps0 (Suc 0, Bk\<up>(l), <lm>) tp stp));
   rec_ci rec_F = (ap, pos, md)\<rbrakk>
-  \<Longrightarrow> {\<lambda> nl. nl = [code tp, bl2wc (<lm>)]} ap \<up>"
+  \<Longrightarrow> \<lbrace>\<lambda> nl. nl = [code tp, bl2wc (<lm>)]\<rbrace> ap \<up>"
 proof(frule_tac F_ap = ap and rs_pos = pos and a_md = md
-    and suflm = "[]" in F_aprog_uhalt, auto simp: abc_Hoare_unhalt_def, 
+    and suflm = "[]" in f_aprog_uhalt, auto simp: abc_Hoare_unhalt_def, 
     case_tac "abc_steps_l (0, [code tp, bl2wc (<lm>)]) ap n", simp)
   fix n a b
   assume h: 
     "\<forall>n. abc_notfinal (abc_steps_l (0, code tp # bl2wc (<lm>) # 0 \<up> (md - pos)) ap n) ap"
     "abc_steps_l (0, [code tp, bl2wc (<lm>)]) ap n = (a, b)" 
-    "tm_wf (tp, 0)" 
+    "composable_tm (tp, 0)" 
     "rec_ci rec_F = (ap, pos, md)"
   moreover have a: "ap \<noteq> []"
     using h rec_ci_not_null[of "rec_F" pos md] by auto
   ultimately show "a < length ap"
   proof(erule_tac x = n in allE)
     assume g: "abc_notfinal (abc_steps_l (0, code tp # bl2wc (<lm>) # 0 \<up> (md - pos)) ap n) ap"
     obtain ss nl where b : "abc_steps_l (0, code tp # bl2wc (<lm>) # 0 \<up> (md - pos)) ap n = (ss, nl)"
       by (metis prod.exhaust)
     then have c: "ss < length ap"
       using g by simp
     thus "?thesis"
       using a b c
       using abc_list_crsp_steps[of "[code tp, bl2wc (<lm>)]"
           "md - pos" ap n ss nl] h
       by(simp)
   qed
 qed
 
 lemma uabc_uhalt: 
-  "\<lbrakk>tm_wf (tp, 0); 
+  "\<lbrakk>composable_tm (tp, 0); 
   \<forall> stp. (\<not> TSTD (steps0 (Suc 0, Bk\<up>(l), <lm>) tp stp))\<rbrakk>
-  \<Longrightarrow> {\<lambda> nl. nl = [code tp, bl2wc (<lm>)]} F_aprog \<up> "
+  \<Longrightarrow> \<lbrace>\<lambda> nl. nl = [code tp, bl2wc (<lm>)]\<rbrace> f_aprog \<up> "
 proof -
   obtain a b c where abc:"rec_ci rec_F = (a,b,c)" by (cases "rec_ci rec_F") force
-  assume a:"tm_wf (tp, 0)" "\<forall> stp. (\<not> TSTD (steps0 (Suc 0, Bk\<up>(l), <lm>) tp stp))"
+  assume a:"composable_tm (tp, 0)" "\<forall> stp. (\<not> TSTD (steps0 (Suc 0, Bk\<up>(l), <lm>) tp stp))"
   from uabc_uhalt'[OF a abc] abc_Hoare_plus_unhalt1
-  show "{\<lambda> nl. nl = [code tp, bl2wc (<lm>)]} F_aprog \<up>"
-    by(simp add: F_aprog_def abc)
+  show "\<lbrace>\<lambda> nl. nl = [code tp, bl2wc (<lm>)]\<rbrace> f_aprog \<up>"
+    by(simp add: f_aprog_def abc)
 qed
 
 lemma tutm_uhalt': 
-  assumes tm_wf:  "tm_wf (tp,0)"
+  assumes composable_tm:  "composable_tm (tp,0)"
     and unhalt: "\<forall> stp. (\<not> TSTD (steps0 (1, Bk\<up>(l), <lm>) tp stp))"
-  shows "\<forall> stp. \<not> is_final (steps0 (1, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm stp)"
-  unfolding t_utm_def
+  shows "\<forall> stp. \<not> is_final (steps0 (1, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) utm_with_two_args stp)"
+  unfolding utm_with_two_args_def
 proof(rule_tac compile_correct_unhalt, auto)
-  show "F_tprog = tm_of F_aprog"
-    by(simp add:  F_tprog_def)
+  show "f_tprog_tm = tm_of f_aprog"
+    by(simp add:  f_tprog_tm_def)
 next
-  show "crsp (layout_of F_aprog) (0, [code tp, bl2wc (<lm>)]) (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>)  []"
+  show "crsp (layout_of f_aprog) (0, [code tp, bl2wc (<lm>)]) (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>)  []"
     by(auto simp: crsp.simps start_of.simps)
 next
   fix stp a b
-  show "abc_steps_l (0, [code tp, bl2wc (<lm>)]) F_aprog stp = (a, b) \<Longrightarrow> a < length F_aprog"
+  show "abc_steps_l (0, [code tp, bl2wc (<lm>)]) f_aprog stp = (a, b) \<Longrightarrow> a < length f_aprog"
     using assms
     apply(drule_tac uabc_uhalt, auto simp: abc_Hoare_unhalt_def)
     by(erule_tac x = stp in allE, erule_tac x = stp in allE, simp) 
 qed
 
 lemma tinres_commute: "tinres r r' \<Longrightarrow> tinres r' r"
   apply(auto simp: tinres_def)
   done
 
 lemma inres_tape:
   "\<lbrakk>steps0 (st, l, r) tp stp = (a, b, c); steps0 (st, l', r') tp stp = (a', b', c'); 
   tinres l l'; tinres r r'\<rbrakk>
   \<Longrightarrow> a = a' \<and> tinres b b' \<and> tinres c c'"
 proof(case_tac "steps0 (st, l', r) tp stp")
   fix aa ba ca
   assume h: "steps0 (st, l, r) tp stp = (a, b, c)" 
     "steps0 (st, l', r') tp stp = (a', b', c')"
     "tinres l l'" "tinres r r'"
     "steps0 (st, l', r) tp stp = (aa, ba, ca)"
   have "tinres b ba \<and> c = ca \<and> a = aa"
     using h
     apply(rule_tac tinres_steps1, auto)
     done
   moreover have "b' = ba \<and> tinres c' ca \<and> a' =  aa"
     using h
     apply(rule_tac tinres_steps2, auto intro: tinres_commute)
     done
   ultimately show "?thesis"
     apply(auto intro: tinres_commute)
     done
 qed
 
 lemma tape_normalize:
-  assumes "\<forall> stp. \<not> is_final(steps0 (Suc 0, [Bk,Bk], <[code tp, bl2wc (<lm>)]>) t_utm stp)"
-  shows   "\<forall> stp. \<not> is_final (steps0 (Suc 0, Bk\<up>(m), <[code tp, bl2wc (<lm>)]> @ Bk\<up>(n)) t_utm stp)"
+  assumes "\<forall> stp. \<not> is_final(steps0 (Suc 0, [Bk,Bk], <[code tp, bl2wc (<lm>)]>) utm_with_two_args stp)"
+  shows   "\<forall> stp. \<not> is_final (steps0 (Suc 0, Bk\<up>(m), <[code tp, bl2wc (<lm>)]> @ Bk\<up>(n)) utm_with_two_args stp)"
     (is "\<forall> stp. ?P stp")
 proof
   fix stp
   from assms[rule_format,of stp] show "?P stp"
-    apply(case_tac "steps0 (Suc 0, Bk\<up>(m), <[code tp, bl2wc (<lm>)]> @ Bk\<up>(n)) t_utm stp", simp)
-    apply(case_tac "steps0 (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm stp", simp)
+    apply(case_tac "steps0 (Suc 0, Bk\<up>(m), <[code tp, bl2wc (<lm>)]> @ Bk\<up>(n)) utm_with_two_args stp", simp)
+    apply(case_tac "steps0 (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) utm_with_two_args stp", simp)
     apply(drule_tac inres_tape, auto)
      apply(auto simp: tinres_def)
     apply(case_tac "m > Suc (Suc 0)")
      apply(rule_tac x = "m - Suc (Suc 0)" in exI) 
      apply(case_tac m, simp_all)
      apply(metis Suc_lessD Suc_pred replicate_Suc)
     apply(rule_tac x = "2 - m" in exI, simp add: replicate_add[THEN sym])
     apply(simp only: numeral_2_eq_2, simp add: replicate_Suc)
     done
 qed
 
 lemma tutm_uhalt: 
-  "\<lbrakk>tm_wf (tp,0);
+  "\<lbrakk>composable_tm (tp,0);
     \<forall> stp. (\<not> TSTD (steps0 (Suc 0, Bk\<up>(l), <args>) tp stp))\<rbrakk>
-  \<Longrightarrow> \<forall> stp. \<not> is_final (steps0 (Suc 0, Bk\<up>(m), <[code tp, bl2wc (<args>)]> @ Bk\<up>(n)) t_utm stp)"
+  \<Longrightarrow> \<forall> stp. \<not> is_final (steps0 (Suc 0, Bk\<up>(m), <[code tp, bl2wc (<args>)]> @ Bk\<up>(n)) utm_with_two_args stp)"
   apply(rule_tac tape_normalize)
   apply(rule_tac tutm_uhalt'[simplified], simp_all)
   done
 
-lemma UTM_uhalt_lemma_pre:
-  assumes tm_wf: "tm_wf (tp, 0)"
+lemma utm_uhalt_lemma_pre:
+  assumes composable_tm: "composable_tm (tp, 0)"
     and exec: "\<forall> stp. (\<not> TSTD (steps0 (Suc 0, Bk\<up>(l), <args>) tp stp))"
     and args: "args \<noteq> []"
-  shows "\<forall> stp. \<not> is_final (steps0 (Suc 0, [], <code tp # args>)  UTM_pre stp)"
+  shows "\<forall> stp. \<not> is_final (steps0 (Suc 0, [], <code tp # args>)  utm_pre_tm stp)"
 proof -
   let ?P1 = "\<lambda> (l, r). l = [] \<and> r = <code tp # args>"
   let ?Q1 = "\<lambda> (l, r). (l = [Bk] \<and>
              (\<exists> rn. r = Oc\<up>(Suc (code tp)) @ Bk # Oc\<up>(Suc (bl_bin (<args>))) @ Bk\<up>(rn)))"
   let ?P2 = ?Q1
-  have "{?P1} (t_wcode |+| t_utm) \<up>"
+  have "\<lbrace>?P1\<rbrace> (wcode_tm |+| utm_with_two_args) \<up>"
   proof(rule_tac Hoare_plus_unhalt)
-    show "tm_wf (t_wcode, 0)" by auto
+    show "composable_tm (wcode_tm, 0)" by auto
   next
-    show "{?P1} t_wcode {?Q1}"
+    show "\<lbrace>?P1\<rbrace> wcode_tm \<lbrace>?Q1\<rbrace>"
       apply(rule_tac Hoare_haltI, auto)
       using wcode_lemma_1[of args "code tp"] args
       apply(auto)
       by (metis (mono_tags, lifting) holds_for.simps is_finalI old.prod.case)
   next
-    show "{?P2} t_utm \<up>"
+    show "\<lbrace>?P2\<rbrace> utm_with_two_args \<up>"
     proof(rule_tac Hoare_unhaltI, auto)
       fix n rn
-      assume h: "is_final (steps0 (Suc 0, [Bk], Oc \<up> Suc (code tp) @ Bk # Oc \<up> Suc (bl_bin (<args>)) @ Bk \<up> rn) t_utm n)"
-      have "\<forall> stp. \<not> is_final (steps0 (Suc 0, Bk\<up>(Suc 0), <[code tp, bl2wc (<args>)]> @ Bk\<up>(rn)) t_utm stp)"
+      assume h: "is_final (steps0 (Suc 0, [Bk], Oc \<up> Suc (code tp) @ Bk # Oc \<up> Suc (bl_bin (<args>)) @ Bk \<up> rn) utm_with_two_args n)"
+      have "\<forall> stp. \<not> is_final (steps0 (Suc 0, Bk\<up>(Suc 0), <[code tp, bl2wc (<args>)]> @ Bk\<up>(rn)) utm_with_two_args stp)"
         using assms
         apply(rule_tac tutm_uhalt, simp_all)
         done
       thus "False"
         using h
         apply(erule_tac x = n in allE)
         apply(simp add: tape_of_list_def bin_wc_eq tape_of_nat_def)
         done
     qed
   qed
   thus "?thesis"
-    apply(simp add: Hoare_unhalt_def UTM_pre_def)
+    apply(simp add: Hoare_unhalt_def utm_pre_tm_def)
     done
 qed
 
-text \<open>
-  The correctness of \<open>UTM\<close>, the unhalt case.
-\<close>
-
-lemma UTM_uhalt_lemma':
-  assumes tm_wf: "tm_wf (tp, 0)"
+subsection \<open>The correctness of utm, the unhalt case.\<close>
+
+lemma utm_uhalt_lemma':
+  assumes composable_tm: "composable_tm (tp, 0)"
     and unhalt: "\<forall> stp. (\<not> TSTD (steps0 (Suc 0, Bk\<up>(l), <args>) tp stp))"
     and args: "args \<noteq> []"
-  shows " \<forall> stp. \<not> is_final (steps0 (Suc 0, [], <code tp # args>)  UTM stp)"
-  using UTM_uhalt_lemma_pre[of tp l args] assms
-  apply(simp add: UTM_pre_def t_utm_def UTM_def F_aprog_def F_tprog_def)
+  shows " \<forall> stp. \<not> is_final (steps0 (Suc 0, [], <code tp # args>)  utm stp)"
+  using utm_uhalt_lemma_pre[of tp l args] assms
+  apply(simp add: utm_pre_tm_def utm_with_two_args_def utm_def f_aprog_def f_tprog_tm_def)
   apply(case_tac "rec_ci rec_F", simp)
   done
 
-lemma UTM_halt_lemma:
-  assumes tm_wf: "tm_wf (p, 0)"
-    and resut: "rs > 0"
+lemma utm_halt_lemma:
+  assumes composable_tm: "composable_tm (p, 0)"
+    and result: "rs > 0"
     and args: "(args::nat list) \<noteq> []"
-    and exec: "{(\<lambda>tp. tp = (Bk\<up>i, <args>))} p {(\<lambda>tp. tp = (Bk\<up>m, Oc\<up>rs @ Bk\<up>k))}" 
-  shows "{(\<lambda>tp. tp = ([], <code p # args>))} UTM {(\<lambda>tp. (\<exists> m n. tp = (Bk\<up>m, Oc\<up>rs @ Bk\<up>n)))}"
+    and exec: "\<lbrace>(\<lambda>tp. tp = (Bk\<up>i, <args>))\<rbrace> p \<lbrace>(\<lambda>tp. tp = (Bk\<up>m, Oc\<up>rs @ Bk\<up>k))\<rbrace>" 
+  shows "\<lbrace>(\<lambda>tp. tp = ([], <code p # args>))\<rbrace> utm \<lbrace>(\<lambda>tp. (\<exists> m n. tp = (Bk\<up>m, Oc\<up>rs @ Bk\<up>n)))\<rbrace>"
 proof -
   let ?steps0 = "steps0 (Suc 0, [], <code p # args>)"
   let ?stepsBk = "steps0 (Suc 0, Bk\<up>i, <args>) p"
   from wcode_lemma_1[OF args,of "code p"] obtain stp ln rn where
-    wcl1:"?steps0 t_wcode stp =
+    wcl1:"?steps0 wcode_tm stp =
      (0, [Bk], Oc \<up> Suc (code p) @ Bk # Oc \<up> Suc (bl_bin (<args>)) @ Bk \<up> rn)" by fast
   from exec Hoare_halt_def obtain n where
-    n:"{\<lambda>tp. tp = (Bk \<up> i, <args>)} p {\<lambda>tp. tp = (Bk \<up> m, Oc \<up> rs @ Bk \<up> k)}"
+    n:"\<lbrace>\<lambda>tp. tp = (Bk \<up> i, <args>)\<rbrace> p \<lbrace>\<lambda>tp. tp = (Bk \<up> m, Oc \<up> rs @ Bk \<up> k)\<rbrace>"
     "is_final (?stepsBk n)"
     "(\<lambda>tp. tp = (Bk \<up> m, Oc \<up> rs @ Bk \<up> k)) holds_for steps0 (Suc 0, Bk \<up> i, <args>) p n"
     by auto
   obtain a where a:"a = fst (rec_ci rec_F)" by blast
-  have "{(\<lambda> (l, r). l = [] \<and> r = <code p # args>)} (t_wcode |+| t_utm)
-          {(\<lambda> (l, r). (\<exists> m. l = Bk\<up>m) \<and> (\<exists> n. r = Oc\<up>rs @ Bk\<up>n))}"
+  have "\<lbrace>(\<lambda> (l, r). l = [] \<and> r = <code p # args>) \<rbrace> (wcode_tm |+| utm_with_two_args)
+          \<lbrace>(\<lambda> (l, r). (\<exists> m. l = Bk\<up>m) \<and> (\<exists> n. r = Oc\<up>rs @ Bk\<up>n))\<rbrace>"
   proof(rule_tac Hoare_plus_halt)
-    show "{\<lambda>(l, r). l = [] \<and> r = <code p # args>} t_wcode {\<lambda> (l, r). (l = [Bk] \<and>
-    (\<exists> rn. r = Oc\<up>(Suc (code p)) @ Bk # Oc\<up>(Suc (bl_bin (<args>))) @ Bk\<up>(rn)))}"
+    show "\<lbrace>\<lambda>(l, r). l = [] \<and> r = <code p # args>\<rbrace> wcode_tm \<lbrace>\<lambda> (l, r). (l = [Bk] \<and>
+    (\<exists> rn. r = Oc\<up>(Suc (code p)) @ Bk # Oc\<up>(Suc (bl_bin (<args>))) @ Bk\<up>(rn)))\<rbrace>"
       using wcl1 by (auto intro!:Hoare_haltI exI[of _ stp])
   next
     have "\<exists> stp. (?stepsBk stp = (0, Bk\<up>m, Oc\<up>rs @ Bk\<up>k))"
       using n by (case_tac "?stepsBk n", auto)
     then obtain stp where k: "steps0 (Suc 0, Bk\<up>i, <args>) p stp = (0, Bk\<up>m, Oc\<up>rs @ Bk\<up>k)"
       ..
-    thus "{\<lambda>(l, r). l = [Bk] \<and> (\<exists>rn. r = Oc \<up> Suc (code p) @ Bk # Oc \<up> Suc (bl_bin (<args>)) @ Bk \<up> rn)}
-      t_utm {\<lambda>(l, r). (\<exists>m. l = Bk \<up> m) \<and> (\<exists>n. r = Oc \<up> rs @ Bk \<up> n)}"
+    thus "\<lbrace>\<lambda>(l, r). l = [Bk] \<and> (\<exists>rn. r = Oc \<up> Suc (code p) @ Bk # Oc \<up> Suc (bl_bin (<args>)) @ Bk \<up> rn)\<rbrace>
+      utm_with_two_args \<lbrace>\<lambda>(l, r). (\<exists>m. l = Bk \<up> m) \<and> (\<exists>n. r = Oc \<up> rs @ Bk \<up> n)\<rbrace>"
     proof(rule_tac Hoare_haltI, auto)
       fix rn
-      from t_utm_halt_eq[OF assms(1) k assms(2),of rn] assms k
-      have "\<exists> ma n stp. steps0 (Suc 0, [Bk], <[code p, bl2wc (<args>)]> @ Bk \<up> rn) t_utm stp =
+      from utm_with_two_args_halt_eq[OF assms(1) k assms(2),of rn] assms k
+      have "\<exists> ma n stp. steps0 (Suc 0, [Bk], <[code p, bl2wc (<args>)]> @ Bk \<up> rn) utm_with_two_args stp =
        (0, Bk \<up> ma, Oc \<up> rs @ Bk \<up> n)" by (auto simp add: bin_wc_eq)
       then obtain stpx m' n' where
-        t:"steps0 (Suc 0, [Bk], <[code p, bl2wc (<args>)]> @ Bk \<up> rn) t_utm stpx =
+        t:"steps0 (Suc 0, [Bk], <[code p, bl2wc (<args>)]> @ Bk \<up> rn) utm_with_two_args stpx =
        (0, Bk \<up> m', Oc \<up> rs @ Bk \<up> n')" by auto
-      show "\<exists>n. is_final (steps0 (Suc 0, [Bk], Oc \<up> Suc (code p) @ Bk # Oc \<up> Suc (bl_bin (<args>)) @ Bk \<up> rn) t_utm n) \<and>
+      show "\<exists>n. is_final (steps0 (Suc 0, [Bk], Oc \<up> Suc (code p) @ Bk # Oc \<up> Suc (bl_bin (<args>)) @ Bk \<up> rn) utm_with_two_args n) \<and>
              (\<lambda>(l, r). (\<exists>m. l = Bk \<up> m) \<and> (\<exists>n. r = Oc \<up> rs @ Bk \<up> n)) holds_for steps0 
-         (Suc 0, [Bk], Oc \<up> Suc (code p) @ Bk # Oc \<up> Suc (bl_bin (<args>)) @ Bk \<up> rn) t_utm n"      
+         (Suc 0, [Bk], Oc \<up> Suc (code p) @ Bk # Oc \<up> Suc (bl_bin (<args>)) @ Bk \<up> rn) utm_with_two_args n"      
         using t
         by(auto simp: bin_wc_eq tape_of_list_def tape_of_nat_def intro:exI[of _ stpx])
     qed
   next
-    show "tm_wf0 t_wcode" by auto
+    show "composable_tm0 wcode_tm" by auto
   qed
   then obtain n where
-    "is_final (?steps0 (t_wcode |+| t_utm) n)" 
+    "is_final (?steps0 (wcode_tm |+| utm_with_two_args) n)" 
     "(\<lambda>(l, r). (\<exists>m. l = Bk \<up> m) \<and>
-           (\<exists>n. r = Oc \<up> rs @ Bk \<up> n)) holds_for ?steps0 (t_wcode |+| t_utm) n"
+           (\<exists>n. r = Oc \<up> rs @ Bk \<up> n)) holds_for ?steps0 (wcode_tm |+| utm_with_two_args) n"
     by(auto simp add: Hoare_halt_def a)
   thus "?thesis"
     apply(case_tac "rec_ci rec_F")
-    apply(auto simp add: UTM_def Hoare_halt_def)
-    apply(case_tac "(?steps0 (t_wcode |+| t_utm) n)")
+    apply(auto simp add: utm_def Hoare_halt_def)
+    apply(case_tac "(?steps0 (wcode_tm |+| utm_with_two_args) n)")
     apply(rule_tac x="n" in exI)
-    apply(auto simp add:a t_utm_def F_aprog_def F_tprog_def)
+    apply(auto simp add:a utm_with_two_args_def f_aprog_def f_tprog_tm_def)
     done
 qed
 
-lemma UTM_halt_lemma2:
-  assumes tm_wf: "tm_wf (p, 0)"
+lemma utm_halt_lemma2:
+  assumes composable_tm: "composable_tm (p, 0)"
     and args: "(args::nat list) \<noteq> []"
-    and exec: "{(\<lambda>tp. tp = ([], <args>))} p {(\<lambda>tp. tp = (Bk\<up>m, <(n::nat)> @ Bk\<up>k))}" 
-  shows "{(\<lambda>tp. tp = ([], <code p # args>))} UTM {(\<lambda>tp. (\<exists> m k. tp = (Bk\<up>m, <n> @ Bk\<up>k)))}"
-  using UTM_halt_lemma[OF assms(1) _ assms(2), where i="0"]
+    and exec: "\<lbrace>(\<lambda>tp. tp = ([], <args>))\<rbrace> p \<lbrace>(\<lambda>tp. tp = (Bk\<up>m, <(n::nat)> @ Bk\<up>k))\<rbrace>" 
+  shows "\<lbrace>(\<lambda>tp. tp = ([], <code p # args>))\<rbrace> utm \<lbrace>(\<lambda>tp. (\<exists> m k. tp = (Bk\<up>m, <n> @ Bk\<up>k)))\<rbrace>"
+  using utm_halt_lemma[OF assms(1) _ assms(2), where i="0"]
   using assms(3)
   by(simp add: tape_of_nat_def)
 
-lemma UTM_unhalt_lemma: 
-  assumes tm_wf: "tm_wf (p, 0)"
-    and unhalt: "{(\<lambda>tp. tp = (Bk\<up>i, <args>))} p \<up>"
+lemma utm_unhalt_lemma: 
+  assumes composable_tm: "composable_tm (p, 0)"
+    and unhalt: "\<lbrace>(\<lambda>tp. tp = (Bk\<up>i, <args>))\<rbrace> p \<up>"
     and args: "args \<noteq> []"
-  shows "{(\<lambda>tp. tp = ([], <code p # args>))} UTM \<up>"
+  shows "\<lbrace>(\<lambda>tp. tp = ([], <code p # args>))\<rbrace> utm \<up>"
 proof -
   have "(\<not> TSTD (steps0 (Suc 0, Bk\<up>(i), <args>) p stp))" for stp
     (* in unhalt, we substitute inner 'forall' n\<rightarrow>stp *)
     using unhalt[unfolded Hoare_unhalt_def,rule_format,OF refl,of stp]
     by(cases "steps0 (Suc 0, Bk \<up> i, <args>) p stp",auto simp: Hoare_unhalt_def TSTD_def)
-  then have "\<forall> stp. \<not> is_final (steps0 (Suc 0, [], <code p # args>)  UTM stp)"
-    using assms by(intro UTM_uhalt_lemma', auto)
+  then have "\<forall> stp. \<not> is_final (steps0 (Suc 0, [], <code p # args>)  utm stp)"
+    using assms by(intro utm_uhalt_lemma', auto)
   thus "?thesis" by(simp add: Hoare_unhalt_def)
 qed
 
-lemma UTM_unhalt_lemma2: 
-  assumes tm_wf: "tm_wf (p, 0)"
-    and unhalt: "{(\<lambda>tp. tp = ([], <args>))} p \<up>"
-    and args: "args \<noteq> []"
-  shows "{(\<lambda>tp. tp = ([], <code p # args>))} UTM \<up>"
-  using UTM_unhalt_lemma[OF assms(1), where i="0"]
+lemma utm_unhalt_lemma2: 
+  assumes "composable_tm (p, 0)"
+    and "\<lbrace>(\<lambda>tp. tp = ([], <args>))\<rbrace> p \<up>"
+    and "args \<noteq> []"
+  shows "\<lbrace>(\<lambda>tp. tp = ([], <code p # args>))\<rbrace> utm \<up>"
+  using utm_unhalt_lemma[OF assms(1), where i="0"]
   using assms(2-3)
   by(simp add: tape_of_nat_def)
 
-end
\ No newline at end of file
+end
diff --git a/thys/Universal_Turing_Machine/WeakCopyTM.thy b/thys/Universal_Turing_Machine/WeakCopyTM.thy
new file mode 100644
--- /dev/null
+++ b/thys/Universal_Turing_Machine/WeakCopyTM.thy
@@ -0,0 +1,1179 @@
+(* Title: thys/WeakCopyTM.thy
+   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
+   Modifications: Sebastiaan Joosten
+
+   Cleanup of proofs
+   Author: Franz Regensburger (FABR) 02/2022
+ *)
+
+subsection \<open>Machines that duplicate a single Numeral\<close>
+
+subsubsection \<open>A Turing machine that duplicates its input if the input is a single numeral\<close>
+
+text\<open>The Machine WeakCopyTM does not check the number of its arguments on the initial tape.
+If it is provided a single numeral it does a perfect job. However, if it gets no or more than
+ one argument, it does not complain but produces some result.\<close>
+
+theory WeakCopyTM
+  imports
+    Turing_HaltingConditions
+begin
+
+declare adjust.simps[simp del]
+
+(* ---------- tm_copy_begin_orig ---------- *)
+
+(*
+let
+tm_copy_begin_orig = from_raw [
+    (WB,0),(R,2),
+    (R,3),(R,2),
+    (WO,3),(L,4),
+    (L,4),(L,0) ]
+*)
+
+definition 
+  tm_copy_begin_orig :: "instr list"
+  where
+    "tm_copy_begin_orig \<equiv>
+       [(WB,0),(R,2), (R,3),(R,2), (WO,3),(L,4), (L,4),(L,0)]"
+
+fun 
+  inv_begin0 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_begin1 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_begin2 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_begin3 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_begin4 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_begin0 n (l, r) = ((n > 1 \<and> (l, r) = (Oc \<up> (n - 2), [Oc, Oc, Bk, Oc])) \<or>   
+                          (n = 1 \<and> (l, r) = ([], [Bk, Oc, Bk, Oc])))"
+  | "inv_begin1 n (l, r) = ((l, r) = ([], Oc \<up> n))"
+  | "inv_begin2 n (l, r) = (\<exists> i j. i > 0 \<and> i + j = n \<and> (l, r) = (Oc \<up> i, Oc \<up> j))"
+  | "inv_begin3 n (l, r) = (n > 0 \<and> (l, tl r) = (Bk # Oc \<up> n, []))"
+  | "inv_begin4 n (l, r) = (n > 0 \<and> (l, r) = (Oc \<up> n, [Bk, Oc]) \<or> (l, r) = (Oc \<up> (n - 1), [Oc, Bk, Oc]))"
+
+fun inv_begin :: "nat \<Rightarrow> config \<Rightarrow> bool"
+  where
+    "inv_begin n (s, tap) = 
+        (if s = 0 then inv_begin0 n tap else
+         if s = 1 then inv_begin1 n tap else
+         if s = 2 then inv_begin2 n tap else
+         if s = 3 then inv_begin3 n tap else
+         if s = 4 then inv_begin4 n tap 
+         else False)"
+
+lemma inv_begin_step_E: "\<lbrakk>0 < i; 0 < j\<rbrakk> \<Longrightarrow> 
+  \<exists>ia>0. ia + j - Suc 0 = i + j \<and> Oc # Oc \<up> i = Oc \<up> ia"
+  by (rule_tac x = "Suc i" in exI, simp)
+
+lemma inv_begin_step: 
+  assumes "inv_begin n cf"
+    and "n > 0"
+  shows "inv_begin n (step0 cf tm_copy_begin_orig)"
+  using assms
+  unfolding tm_copy_begin_orig_def
+  apply(cases cf)
+  apply(auto simp: numeral_eqs_upto_12 split: if_splits elim:inv_begin_step_E)
+  apply(cases "hd (snd (snd cf))";cases "(snd (snd cf))",auto)
+  done
+
+lemma inv_begin_steps: 
+  assumes "inv_begin n cf"
+    and "n > 0"
+  shows "inv_begin n (steps0 cf tm_copy_begin_orig stp)"
+  apply(induct stp)
+   apply(simp add: assms)
+  apply(auto simp del: steps.simps)
+  apply(rule_tac inv_begin_step)
+   apply(simp_all add: assms)
+  done
+
+lemma begin_partial_correctness:
+  assumes "is_final (steps0 (1, [], Oc \<up> n) tm_copy_begin_orig stp)"
+  shows "0 < n \<Longrightarrow> \<lbrace>inv_begin1 n\<rbrace> tm_copy_begin_orig \<lbrace>inv_begin0 n\<rbrace>"
+proof(rule_tac Hoare_haltI)
+  fix l r
+  assume h: "0 < n" "inv_begin1 n (l, r)"
+  have "inv_begin n (steps0 (1, [], Oc \<up> n) tm_copy_begin_orig stp)"
+    using h by (rule_tac inv_begin_steps) (simp_all)
+  then show
+    "\<exists>stp. is_final (steps0 (1, l, r) tm_copy_begin_orig stp) \<and> 
+    inv_begin0 n holds_for steps (1, l, r) (tm_copy_begin_orig, 0) stp"
+    using h assms
+    apply(rule_tac x = stp in exI)
+    apply(case_tac "(steps0 (1, [], Oc \<up> n) tm_copy_begin_orig stp)", simp)
+    done
+qed
+
+fun measure_begin_state :: "config \<Rightarrow> nat"
+  where
+    "measure_begin_state (s, l, r) = (if s = 0 then 0 else 5 - s)"
+
+fun measure_begin_step :: "config \<Rightarrow> nat"
+  where
+    "measure_begin_step (s, l, r) = 
+        (if s = 2 then length r else
+         if s = 3 then (if r = [] \<or> r = [Bk] then 1 else 0) else
+         if s = 4 then length l 
+         else 0)"
+
+definition
+  "measure_begin = measures [measure_begin_state, measure_begin_step]"
+
+lemma wf_measure_begin:
+  shows "wf measure_begin" 
+  unfolding measure_begin_def 
+  by auto
+
+lemma measure_begin_induct [case_names Step]: 
+  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_begin\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
+  using wf_measure_begin
+  by (metis wf_iff_no_infinite_down_chain)
+
+lemma begin_halts: 
+  assumes h: "x > 0"
+  shows "\<exists> stp. is_final (steps0 (1, [], Oc \<up> x) tm_copy_begin_orig stp)"
+proof (induct rule: measure_begin_induct) 
+  case (Step n)
+  have "\<not> is_final (steps0 (1, [], Oc \<up> x) tm_copy_begin_orig n)" by fact
+  moreover
+  have "inv_begin x (steps0 (1, [], Oc \<up> x) tm_copy_begin_orig n)"
+    by (rule_tac inv_begin_steps) (simp_all add:  h)
+  moreover
+  obtain s l r where eq: "(steps0 (1, [], Oc \<up> x) tm_copy_begin_orig n) = (s, l, r)"
+    by (metis measure_begin_state.cases)
+  ultimately 
+  have "(step0 (s, l, r) tm_copy_begin_orig, s, l, r) \<in> measure_begin"
+    apply(auto simp: measure_begin_def tm_copy_begin_orig_def numeral_eqs_upto_12 split: if_splits)
+    apply(subgoal_tac "r = [Oc]")
+     apply(auto)
+    by (metis cell.exhaust list.exhaust list.sel(3))
+  then 
+  show "(steps0 (1, [], Oc \<up> x) tm_copy_begin_orig (Suc n), steps0 (1, [], Oc \<up> x) tm_copy_begin_orig n) \<in> measure_begin"
+    using eq by (simp only: step_red)
+qed
+
+
+lemma begin_correct:
+  shows "0 < n \<Longrightarrow> \<lbrace>inv_begin1 n\<rbrace> tm_copy_begin_orig \<lbrace>inv_begin0 n\<rbrace>"
+  using begin_partial_correctness begin_halts by blast
+
+lemma begin_correct2:
+  assumes "0 < (n::nat)"
+  shows "\<lbrace>\<lambda>tap. tap = ([]::cell list, Oc \<up> n)\<rbrace>
+         tm_copy_begin_orig
+         \<lbrace>\<lambda>tap. (n > 1 \<and> tap = (Oc \<up> (n - 2), [Oc, Oc, Bk, Oc])) \<or>   
+                (n = 1 \<and> tap = ([]::cell list, [Bk, Oc, Bk, Oc])) \<rbrace>"
+proof -
+  from assms have "\<lbrace>inv_begin1 n\<rbrace> tm_copy_begin_orig \<lbrace>inv_begin0 n\<rbrace>"
+    using begin_partial_correctness begin_halts by blast
+  with assms have "\<lbrace>\<lambda>tap. tap = ([]::cell list, Oc \<up> n)\<rbrace> tm_copy_begin_orig \<lbrace>inv_begin0 n\<rbrace>"
+    using Hoare_haltE Hoare_haltI inv_begin1.simps by presburger    
+  with assms show ?thesis
+    by (smt Hoare_haltI Hoare_halt_def Pair_inject
+        holds_for.elims(2) holds_for.simps inv_begin0.simps is_final.elims(2))
+qed
+
+(* ---------- tm_copy_loop_orig ---------- *)
+
+(* Delete some theorems from the simpset *)
+
+declare seq_tm.simps [simp del] 
+declare shift.simps[simp del]
+declare composable_tm.simps[simp del]
+declare step.simps[simp del]
+declare steps.simps[simp del]
+
+
+(*
+let
+tm_copy_loop_orig = from_raw [
+    (R,0),(R,2),
+    (R,3),(WB,2),
+    (R,3),(R,4),
+    (WO,5),(R,4),
+    (L,6),(L,5),
+    (L,6),(L,1) ]
+
+*)
+
+definition 
+  tm_copy_loop_orig :: "instr list"
+  where
+    "tm_copy_loop_orig \<equiv>
+    [ (R, 0),(R, 2), (R, 3),(WB, 2), (R, 3),(R, 4), (WO, 5),(R, 4), (L, 6),(L, 5), (L, 6),(L, 1) ]"
+
+fun 
+  inv_loop1_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop1_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop5_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop5_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop6_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop6_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_loop1_loop n (l, r) = (\<exists> i j. i + j + 1 = n \<and> (l, r) = (Oc\<up>i, Oc#Oc#Bk\<up>j @ Oc\<up>j) \<and> j > 0)"
+  | "inv_loop1_exit n (l, r) = (0 < n \<and> (l, r) = ([], Bk#Oc#Bk\<up>n @ Oc\<up>n))"
+  | "inv_loop5_loop x (l, r) = 
+     (\<exists> i j k t. i + j = Suc x \<and> i > 0 \<and> j > 0 \<and> k + t = j \<and> t > 0 \<and> (l, r) = (Oc\<up>k@Bk\<up>j@Oc\<up>i, Oc\<up>t))"
+  | "inv_loop5_exit x (l, r) = 
+     (\<exists> i j. i + j = Suc x \<and> i > 0 \<and> j > 0 \<and> (l, r) = (Bk\<up>(j - 1)@Oc\<up>i, Bk # Oc\<up>j))"
+  | "inv_loop6_loop x (l, r) = 
+     (\<exists> i j k t. i + j = Suc x \<and> i > 0 \<and> k + t + 1 = j \<and> (l, r) = (Bk\<up>k @ Oc\<up>i, Bk\<up>(Suc t) @ Oc\<up>j))"
+  | "inv_loop6_exit x (l, r) = 
+     (\<exists> i j. i + j = x \<and> j > 0 \<and> (l, r) = (Oc\<up>i, Oc#Bk\<up>j @ Oc\<up>j))"
+
+fun 
+  inv_loop0 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop1 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop2 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop3 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop4 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop5 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_loop6 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+  where
+    "inv_loop0 n (l, r) =  (0 < n \<and> (l, r) = ([Bk], Oc # Bk\<up>n @ Oc\<up>n))"
+  | "inv_loop1 n (l, r) = (inv_loop1_loop n (l, r) \<or> inv_loop1_exit n (l, r))"
+  | "inv_loop2 n (l, r) = (\<exists> i j any. i + j = n \<and> n > 0 \<and> i > 0 \<and> j > 0 \<and> (l, r) = (Oc\<up>i, any#Bk\<up>j@Oc\<up>j))"
+  | "inv_loop3 n (l, r) = 
+     (\<exists> i j k t. i + j = n \<and> i > 0 \<and> j > 0 \<and>  k + t = Suc j \<and> (l, r) = (Bk\<up>k@Oc\<up>i, Bk\<up>t@Oc\<up>j))"
+  | "inv_loop4 n (l, r) = 
+     (\<exists> i j k t. i + j = n \<and> i > 0 \<and> j > 0 \<and>  k + t = j \<and> (l, r) = (Oc\<up>k @ Bk\<up>(Suc j)@Oc\<up>i, Oc\<up>t))"
+  | "inv_loop5 n (l, r) = (inv_loop5_loop n (l, r) \<or> inv_loop5_exit n (l, r))"
+  | "inv_loop6 n (l, r) = (inv_loop6_loop n (l, r) \<or> inv_loop6_exit n (l, r))"
+
+fun inv_loop :: "nat \<Rightarrow> config \<Rightarrow> bool"
+  where
+    "inv_loop x (s, l, r) = 
+         (if s = 0 then inv_loop0 x (l, r)
+          else if s = 1 then inv_loop1 x (l, r)
+          else if s = 2 then inv_loop2 x (l, r)
+          else if s = 3 then inv_loop3 x (l, r)
+          else if s = 4 then inv_loop4 x (l, r)
+          else if s = 5 then inv_loop5 x (l, r)
+          else if s = 6 then inv_loop6 x (l, r)
+          else False)"
+
+declare inv_loop.simps[simp del] inv_loop1.simps[simp del]
+  inv_loop2.simps[simp del] inv_loop3.simps[simp del] 
+  inv_loop4.simps[simp del] inv_loop5.simps[simp del] 
+  inv_loop6.simps[simp del]
+
+lemma inv_loop3_Bk_empty_via_2[elim]: "\<lbrakk>0 < x; inv_loop2 x (b, [])\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, [])"
+  by (auto simp: inv_loop2.simps inv_loop3.simps)
+
+lemma inv_loop3_Bk_empty[elim]: "\<lbrakk>0 < x; inv_loop3 x (b, [])\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, [])"
+  by (auto simp: inv_loop3.simps)
+
+lemma inv_loop5_Oc_empty_via_4[elim]: "\<lbrakk>0 < x; inv_loop4 x (b, [])\<rbrakk> \<Longrightarrow> inv_loop5 x (b, [Oc])"
+  by(auto simp: inv_loop4.simps inv_loop5.simps;force)
+
+lemma inv_loop1_Bk[elim]: "\<lbrakk>0 < x; inv_loop1 x (b, Bk # list)\<rbrakk> \<Longrightarrow> list = Oc # Bk \<up> x @ Oc \<up> x"
+  by (auto simp: inv_loop1.simps)
+
+lemma inv_loop3_Bk_via_2[elim]: "\<lbrakk>0 < x; inv_loop2 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, list)"
+  by(auto simp: inv_loop2.simps inv_loop3.simps;force)
+
+lemma inv_loop3_Bk_move[elim]: "\<lbrakk>0 < x; inv_loop3 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, list)"
+  apply(auto simp: inv_loop3.simps)
+   apply (rename_tac i j k t)
+   apply(rule_tac [!] x = i in exI, 
+      rule_tac [!] x = j in exI, simp_all)
+   apply(case_tac [!] t, auto)
+  done
+
+lemma inv_loop5_Oc_via_4_Bk[elim]: "\<lbrakk>0 < x; inv_loop4 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_loop5 x (b, Oc # list)"
+  by (auto simp: inv_loop4.simps inv_loop5.simps)
+
+lemma inv_loop6_Bk_via_5[elim]: "\<lbrakk>0 < x; inv_loop5 x ([], Bk # list)\<rbrakk> \<Longrightarrow> inv_loop6 x ([], Bk # Bk # list)"
+  by (auto simp: inv_loop6.simps inv_loop5.simps)
+
+lemma inv_loop5_loop_no_Bk[simp]: "inv_loop5_loop x (b, Bk # list) = False"
+  by (auto simp: inv_loop5.simps)
+
+lemma inv_loop6_exit_no_Bk[simp]: "inv_loop6_exit x (b, Bk # list) = False"
+  by (auto simp: inv_loop6.simps)
+
+declare inv_loop5_loop.simps[simp del]  inv_loop5_exit.simps[simp del]
+  inv_loop6_loop.simps[simp del]  inv_loop6_exit.simps[simp del]
+
+lemma inv_loop6_loopBk_via_5[elim]:"\<lbrakk>0 < x; inv_loop5_exit x (b, Bk # list); b \<noteq> []; hd b = Bk\<rbrakk> 
+          \<Longrightarrow> inv_loop6_loop x (tl b, Bk # Bk # list)"
+  apply(simp only: inv_loop5_exit.simps inv_loop6_loop.simps )
+  apply(erule_tac exE)+
+  apply(rename_tac i j)
+  apply(rule_tac x = i in exI, 
+      rule_tac x = j in exI,
+      rule_tac x = "j - Suc (Suc 0)" in exI, 
+      rule_tac x = "Suc 0" in exI, auto)
+   apply(case_tac [!] j, simp_all)
+   apply(case_tac [!] "j-1", simp_all)
+  done
+
+lemma inv_loop6_loop_no_Oc_Bk[simp]: "inv_loop6_loop x (b, Oc # Bk # list) = False"
+  by (auto simp: inv_loop6_loop.simps)
+
+lemma inv_loop6_exit_Oc_Bk_via_5[elim]: "\<lbrakk>x > 0; inv_loop5_exit x (b, Bk # list); b \<noteq> []; hd b = Oc\<rbrakk> \<Longrightarrow> 
+  inv_loop6_exit x (tl b, Oc # Bk # list)"
+  apply(simp only: inv_loop5_exit.simps inv_loop6_exit.simps)
+  apply(erule_tac exE)+
+  apply(rule_tac x = "x - 1" in exI, rule_tac x = 1 in exI, simp)
+  apply(rename_tac i j)
+  apply(case_tac j;case_tac "j-1", auto)
+  done
+
+lemma inv_loop6_Bk_tail_via_5[elim]: "\<lbrakk>0 < x; inv_loop5 x (b, Bk # list); b \<noteq> []\<rbrakk> \<Longrightarrow> inv_loop6 x (tl b, hd b # Bk # list)"
+  apply(simp add: inv_loop5.simps inv_loop6.simps)
+  apply(cases "hd b", simp_all, auto)
+  done
+
+lemma inv_loop6_loop_Bk_Bk_drop[elim]: "\<lbrakk>0 < x; inv_loop6_loop x (b, Bk # list); b \<noteq> []; hd b = Bk\<rbrakk>
+              \<Longrightarrow> inv_loop6_loop x (tl b, Bk # Bk # list)"
+  apply(simp only: inv_loop6_loop.simps)
+  apply(erule_tac exE)+
+  apply(rename_tac i j k t)
+  apply(rule_tac x = i in exI, rule_tac x = j in exI, 
+      rule_tac x = "k - 1" in exI, rule_tac x = "Suc t" in exI, auto)
+   apply(case_tac [!] k, auto)
+  done
+
+lemma inv_loop6_exit_Oc_Bk_via_loop6[elim]: "\<lbrakk>0 < x; inv_loop6_loop x (b, Bk # list); b \<noteq> []; hd b = Oc\<rbrakk> 
+        \<Longrightarrow> inv_loop6_exit x (tl b, Oc # Bk # list)"
+  apply(simp only: inv_loop6_loop.simps inv_loop6_exit.simps)
+  apply(erule_tac exE)+
+  apply(rename_tac i j k t)
+  apply(rule_tac x = "i - 1" in exI, rule_tac x = j in exI, auto)
+   apply(case_tac [!] k, auto)
+  done
+
+lemma inv_loop6_Bk_tail[elim]: "\<lbrakk>0 < x; inv_loop6 x (b, Bk # list); b \<noteq> []\<rbrakk> \<Longrightarrow> inv_loop6 x (tl b, hd b # Bk # list)"
+  apply(simp add: inv_loop6.simps)
+  apply(case_tac "hd b", simp_all, auto)
+  done
+
+lemma inv_loop2_Oc_via_1[elim]: "\<lbrakk>0 < x; inv_loop1 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_loop2 x (Oc # b, list)"
+  apply(auto simp: inv_loop1.simps inv_loop2.simps,force)
+  done
+
+lemma inv_loop2_Bk_via_Oc[elim]: "\<lbrakk>0 < x; inv_loop2 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_loop2 x (b, Bk # list)"
+  by (auto simp: inv_loop2.simps)
+
+lemma inv_loop4_Oc_via_3[elim]: "\<lbrakk>0 < x; inv_loop3 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_loop4 x (Oc # b, list)"
+  apply(auto simp: inv_loop3.simps inv_loop4.simps)
+   apply(rename_tac i j)
+   apply(rule_tac [!] x = i in exI, auto)
+   apply(rule_tac [!] x = "Suc 0" in exI, rule_tac [!] x = "j - 1" in exI)
+   apply(case_tac [!] j, auto)
+  done
+
+lemma inv_loop4_Oc_move[elim]:
+  assumes "0 < x" "inv_loop4 x (b, Oc # list)"
+  shows "inv_loop4 x (Oc # b, list)"
+proof -
+  from assms[unfolded inv_loop4.simps] obtain i j k t where
+    "i + j = x"
+    "0 < i" "0 < j" "k + t = j" "(b, Oc # list) = (Oc \<up> k @ Bk \<up> Suc j @ Oc \<up> i, Oc \<up> t)"
+    by auto  
+  thus ?thesis unfolding inv_loop4.simps
+    apply(rule_tac [!] x = "i" in exI,rule_tac [!] x = "j" in exI)
+    apply(rule_tac [!] x = "Suc k" in exI,rule_tac [!] x = "t - 1" in exI)
+    by(cases t,auto)
+qed
+
+lemma inv_loop5_exit_no_Oc[simp]: "inv_loop5_exit x (b, Oc # list) = False"
+  by (auto simp: inv_loop5_exit.simps)
+
+lemma inv_loop5_exit_Bk_Oc_via_loop[elim]: " \<lbrakk>inv_loop5_loop x (b, Oc # list); b \<noteq> []; hd b = Bk\<rbrakk>
+  \<Longrightarrow> inv_loop5_exit x (tl b, Bk # Oc # list)"
+  apply(simp only: inv_loop5_loop.simps inv_loop5_exit.simps)
+  apply(erule_tac exE)+
+  apply(rename_tac i j k t)
+  apply(rule_tac x = i in exI)
+  apply(case_tac k, auto)
+  done
+
+lemma inv_loop5_loop_Oc_Oc_drop[elim]: "\<lbrakk>inv_loop5_loop x (b, Oc # list); b \<noteq> []; hd b = Oc\<rbrakk> 
+           \<Longrightarrow> inv_loop5_loop x (tl b, Oc # Oc # list)"
+  apply(simp only:  inv_loop5_loop.simps)
+  apply(erule_tac exE)+
+  apply(rename_tac i j k t)
+  apply(rule_tac x = i in exI, rule_tac x = j in exI)
+  apply(rule_tac x = "k - 1" in exI, rule_tac x = "Suc t" in exI)
+  apply(case_tac k, auto)
+  done
+
+lemma inv_loop5_Oc_tl[elim]: "\<lbrakk>inv_loop5 x (b, Oc # list); b \<noteq> []\<rbrakk> \<Longrightarrow> inv_loop5 x (tl b, hd b # Oc # list)"
+  apply(simp add: inv_loop5.simps)
+  apply(cases "hd b", simp_all, auto)
+  done
+
+lemma inv_loop1_Bk_Oc_via_6[elim]: "\<lbrakk>0 < x; inv_loop6 x ([], Oc # list)\<rbrakk> \<Longrightarrow> inv_loop1 x ([], Bk # Oc # list)"
+  by(auto simp: inv_loop6.simps inv_loop1.simps inv_loop6_loop.simps inv_loop6_exit.simps)
+
+lemma inv_loop1_Oc_via_6[elim]: "\<lbrakk>0 < x; inv_loop6 x (b, Oc # list); b \<noteq> []\<rbrakk> 
+           \<Longrightarrow> inv_loop1 x (tl b, hd b # Oc # list)"
+  by(auto simp: inv_loop6.simps inv_loop1.simps inv_loop6_loop.simps inv_loop6_exit.simps)
+
+
+lemma inv_loop_nonempty[simp]:
+  "inv_loop1 x (b, []) = False"
+  "inv_loop2 x ([], b) = False"
+  "inv_loop2 x (l', []) = False"
+  "inv_loop3 x (b, []) = False"
+  "inv_loop4 x ([], b) = False"
+  "inv_loop5 x ([], list) = False"
+  "inv_loop6 x ([], Bk # xs) = False"
+  by (auto simp: inv_loop1.simps inv_loop2.simps inv_loop3.simps inv_loop4.simps 
+      inv_loop5.simps inv_loop6.simps inv_loop5_exit.simps inv_loop5_loop.simps
+      inv_loop6_loop.simps)
+
+lemma inv_loop_nonemptyE[elim]:
+  "\<lbrakk>inv_loop5 x (b, [])\<rbrakk> \<Longrightarrow> RR" "inv_loop6 x (b, []) \<Longrightarrow> RR" 
+  "\<lbrakk>inv_loop1 x (b, Bk # list)\<rbrakk> \<Longrightarrow> b = []"
+  by (auto simp: inv_loop4.simps inv_loop5.simps inv_loop5_exit.simps inv_loop5_loop.simps
+      inv_loop6.simps inv_loop6_exit.simps inv_loop6_loop.simps inv_loop1.simps)
+
+lemma inv_loop6_Bk_Bk_drop[elim]: "\<lbrakk>inv_loop6 x ([], Bk # list)\<rbrakk> \<Longrightarrow> inv_loop6 x ([], Bk # Bk # list)"
+  by (simp)
+
+lemma inv_loop_step: 
+  "\<lbrakk>inv_loop x cf; x > 0\<rbrakk> \<Longrightarrow> inv_loop x (step cf (tm_copy_loop_orig, 0))"
+  apply(cases cf, cases "snd (snd cf)"; cases "hd (snd (snd cf))")
+     apply(auto simp: inv_loop.simps step.simps tm_copy_loop_orig_def numeral_eqs_upto_12 split: if_splits)
+  done
+
+lemma inv_loop_steps:
+  "\<lbrakk>inv_loop x cf; x > 0\<rbrakk> \<Longrightarrow> inv_loop x (steps cf (tm_copy_loop_orig, 0) stp)"
+  apply(induct stp, simp add: steps.simps, simp)
+  apply(erule_tac inv_loop_step, simp)
+  done
+
+fun loop_stage :: "config \<Rightarrow> nat"
+  where
+    "loop_stage (s, l, r) = (if s = 0 then 0
+                           else (Suc (length (takeWhile (\<lambda>a. a = Oc) (rev l @ r)))))"
+
+fun loop_state :: "config \<Rightarrow> nat"
+  where
+    "loop_state (s, l, r) = (if s = 2 \<and> hd r = Oc then 0
+                           else if s = 1 then 1
+                           else 10 - s)"
+
+fun loop_step :: "config \<Rightarrow> nat"
+  where
+    "loop_step (s, l, r) = (if s = 3 then length r
+                          else if s = 4 then length r
+                          else if s = 5 then length l 
+                          else if s = 6 then length l
+                          else 0)"
+
+definition measure_loop :: "(config \<times> config) set"
+  where
+    "measure_loop = measures [loop_stage, loop_state, loop_step]"
+
+lemma wf_measure_loop: "wf measure_loop"
+  unfolding measure_loop_def
+  by (auto)
+
+lemma measure_loop_induct [case_names Step]: 
+  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_loop\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
+  using wf_measure_loop
+  by (metis wf_iff_no_infinite_down_chain)
+
+lemma inv_loop4_not_just_Oc[elim]: 
+  "\<lbrakk>inv_loop4 x (l', []);
+  length (takeWhile (\<lambda>a. a = Oc) (rev l' @ [Oc])) \<noteq> 
+  length (takeWhile (\<lambda>a. a = Oc) (rev l'))\<rbrakk>
+  \<Longrightarrow> RR"
+  "\<lbrakk>inv_loop4 x (l', Bk # list);
+   length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Oc # list)) \<noteq> 
+    length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Bk # list))\<rbrakk>
+    \<Longrightarrow> RR"
+   apply(auto simp: inv_loop4.simps)
+  apply(rename_tac i j)
+  apply(case_tac [!] j, simp_all add: List.takeWhile_tail)
+  done
+
+lemma takeWhile_replicate_append: 
+  "P a \<Longrightarrow> takeWhile P (a\<up>x @ ys) = a\<up>x @ takeWhile P ys"
+  by (induct x, auto)
+
+lemma takeWhile_replicate: 
+  "P a \<Longrightarrow> takeWhile P (a\<up>x) = a\<up>x"
+  by (induct x, auto)
+
+lemma inv_loop5_Bk_E[elim]: 
+  "\<lbrakk>inv_loop5 x (l', Bk # list); l' \<noteq> []; 
+   length (takeWhile (\<lambda>a. a = Oc) (rev (tl l') @ hd l' # Bk # list)) \<noteq>
+   length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Bk # list))\<rbrakk>
+   \<Longrightarrow> RR"
+  apply(cases "length list";cases "length list - 1"
+      ,auto simp: inv_loop5.simps inv_loop5_exit.simps
+      takeWhile_replicate_append takeWhile_replicate)
+   apply(cases "length list - 2"; force simp add: List.takeWhile_tail)+
+  done
+
+lemma inv_loop1_hd_Oc[elim]: "\<lbrakk>inv_loop1 x (l', Oc # list)\<rbrakk> \<Longrightarrow> hd list = Oc"
+  by (auto simp: inv_loop1.simps)
+
+lemma inv_loop6_not_just_Bk[dest!]: 
+  "\<lbrakk>length (takeWhile P (rev (tl l') @ hd l' # list)) \<noteq> 
+  length (takeWhile P (rev l' @ list))\<rbrakk>
+  \<Longrightarrow> l' = []"
+  apply(cases l', simp_all)
+  done
+
+lemma inv_loop2_OcE[elim]:
+  "\<lbrakk>inv_loop2 x (l', Oc # list); l' \<noteq> []\<rbrakk> \<Longrightarrow> 
+  length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Bk # list)) <
+  length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Oc # list))"
+  apply(auto simp: inv_loop2.simps takeWhile_tail takeWhile_replicate_append
+      takeWhile_replicate)
+  done
+
+lemma loop_halts: 
+  assumes h: "n > 0" "inv_loop n (1, l, r)"
+  shows "\<exists> stp. is_final (steps0 (1, l, r) tm_copy_loop_orig stp)"
+proof (induct rule: measure_loop_induct) 
+  case (Step stp)
+  have "\<not> is_final (steps0 (1, l, r) tm_copy_loop_orig stp)" by fact
+  moreover
+  have "inv_loop n (steps0 (1, l, r) tm_copy_loop_orig stp)"
+    by (rule_tac inv_loop_steps) (simp_all only: h)
+  moreover
+  obtain s l' r' where eq: "(steps0 (1, l, r) tm_copy_loop_orig stp) = (s, l', r')"
+    by (metis measure_begin_state.cases)
+  ultimately 
+  have "(step0 (s, l', r') tm_copy_loop_orig, s, l', r') \<in> measure_loop"
+    using h(1)
+    apply(cases r';cases "hd r'")
+    apply(auto simp: inv_loop.simps step.simps tm_copy_loop_orig_def numeral_eqs_upto_12 measure_loop_def split: if_splits)
+    done
+  then 
+  show "(steps0 (1, l, r) tm_copy_loop_orig (Suc stp), steps0 (1, l, r) tm_copy_loop_orig stp) \<in> measure_loop"
+    using eq by (simp only: step_red)
+qed
+
+lemma loop_correct:
+  assumes "0 < n"
+  shows "\<lbrace>inv_loop1 n\<rbrace> tm_copy_loop_orig \<lbrace>inv_loop0 n\<rbrace>"
+  using assms
+proof(rule_tac Hoare_haltI)
+  fix l r
+  assume h: "0 < n" "inv_loop1 n (l, r)"
+  then obtain stp where k: "is_final (steps0 (1, l, r) tm_copy_loop_orig stp)" 
+    using loop_halts
+    apply(simp add: inv_loop.simps)
+    apply(blast)
+    done
+  moreover
+  have "inv_loop n (steps0 (1, l, r) tm_copy_loop_orig stp)"
+    using h 
+    by (rule_tac inv_loop_steps) (simp_all add: inv_loop.simps)
+  ultimately show
+    "\<exists>stp. is_final (steps0 (1, l, r) tm_copy_loop_orig stp) \<and> 
+    inv_loop0 n holds_for steps0 (1, l, r) tm_copy_loop_orig stp"
+    using h(1) 
+    apply(rule_tac x = stp in exI)
+    apply(case_tac "(steps0 (1, l, r) tm_copy_loop_orig stp)")
+    apply(simp add: inv_loop.simps)
+    done
+qed
+
+
+(* ---------- tm_copy_end ---------- *)
+
+(*
+let
+tm_copy_end_orig = from_raw [
+  (L,0),(R,2),
+  (WO,3),(L,4),
+  (R,2),(R,2),
+  (L,5),(WB,4),
+  (R,0),(L,5)
+  ]
+
+let
+tm_copy_end_new = from_raw [
+  (R,0),(R,2),    -- changed action for Bk from (L,0) to (R,0)
+  (WO,3),(L,4),
+  (R,2),(R,2),
+  (L,5),(WB,4),
+  (R,0),(L,5)
+  ]
+*)
+
+definition 
+  tm_copy_end_orig :: "instr list"
+  where
+    "tm_copy_end_orig \<equiv>
+    [ (L, 0),(R, 2), (WO, 3),(L, 4), (R, 2),(R, 2), (L, 5),(WB, 4), (R, 0),(L, 5) ]"
+
+definition 
+  tm_copy_end_new :: "instr list"
+  where
+    "tm_copy_end_new \<equiv>
+    [ (R, 0),(R, 2), (WO, 3),(L, 4), (R, 2),(R, 2), (L, 5),(WB, 4), (R, 0),(L, 5) ]"
+
+fun
+  inv_end5_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_end5_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool" 
+  where  
+    "inv_end5_loop x (l, r) = 
+     (\<exists> i j. i + j = x \<and> x > 0 \<and> j > 0 \<and> l = Oc\<up>i @ [Bk] \<and> r = Oc\<up>j @ Bk # Oc\<up>x)"
+  | "inv_end5_exit x (l, r) = (x > 0 \<and> l = [] \<and> r = Bk # Oc\<up>x @ Bk # Oc\<up>x)"
+
+fun 
+  inv_end0 :: "nat \<Rightarrow> tape \<Rightarrow>  bool" and
+  inv_end1 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_end2 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_end3 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
+  inv_end4 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and 
+  inv_end5 :: "nat \<Rightarrow> tape \<Rightarrow> bool" 
+  where
+    "inv_end0 n (l, r) = (n > 0 \<and> (l, r) = ([Bk], Oc\<up>n @ Bk # Oc\<up>n))"
+  | "inv_end1 n (l, r) = (n > 0 \<and> (l, r) = ([Bk], Oc # Bk\<up>n @ Oc\<up>n))"
+  | "inv_end2 n (l, r) = (\<exists> i j. i + j = Suc n \<and> n > 0 \<and> l = Oc\<up>i @ [Bk] \<and> r = Bk\<up>j @ Oc\<up>n)"
+  | "inv_end3 n (l, r) =
+     (\<exists> i j. n > 0 \<and> i + j = n \<and> l = Oc\<up>i @ [Bk] \<and> r = Oc # Bk\<up>j@ Oc\<up>n)"
+  | "inv_end4 n (l, r) = (\<exists> any. n > 0 \<and> l = Oc\<up>n @ [Bk] \<and> r = any#Oc\<up>n)"
+  | "inv_end5 n (l, r) = (inv_end5_loop n (l, r) \<or> inv_end5_exit n (l, r))"
+
+fun 
+  inv_end :: "nat \<Rightarrow> config \<Rightarrow> bool"
+  where
+    "inv_end n (s, l, r) = (if s = 0 then inv_end0 n (l, r)
+                          else if s = 1 then inv_end1 n (l, r)
+                          else if s = 2 then inv_end2 n (l, r)
+                          else if s = 3 then inv_end3 n (l, r)
+                          else if s = 4 then inv_end4 n (l, r)
+                          else if s = 5 then inv_end5 n (l, r)
+                          else False)"
+
+declare inv_end.simps[simp del] inv_end1.simps[simp del]
+  inv_end0.simps[simp del] inv_end2.simps[simp del]
+  inv_end3.simps[simp del] inv_end4.simps[simp del]
+  inv_end5.simps[simp del]
+
+lemma inv_end_nonempty[simp]:
+  "inv_end1 x (b, []) = False"
+  "inv_end1 x ([], list) = False"
+  "inv_end2 x (b, []) = False"
+  "inv_end3 x (b, []) = False"
+  "inv_end4 x (b, []) = False"
+  "inv_end5 x (b, []) = False"
+  "inv_end5 x ([], Oc # list) = False"
+  by (auto simp: inv_end1.simps inv_end2.simps inv_end3.simps inv_end4.simps inv_end5.simps)
+
+lemma inv_end0_Bk_via_1[elim]: "\<lbrakk>0 < x; inv_end1 x (b, Bk # list); b \<noteq> []\<rbrakk>
+  \<Longrightarrow> inv_end0 x (tl b, hd b # Bk # list)"
+  by (auto simp: inv_end1.simps inv_end0.simps)
+
+lemma inv_end3_Oc_via_2[elim]: "\<lbrakk>0 < x; inv_end2 x (b, Bk # list)\<rbrakk> 
+  \<Longrightarrow> inv_end3 x (b, Oc # list)"
+  apply(auto simp: inv_end2.simps inv_end3.simps)
+  by (metis Cons_replicate_eq One_nat_def Suc_inject Suc_pred add_Suc_right cell.distinct(1)
+      empty_replicate list.sel(3) neq0_conv self_append_conv2 tl_append2 tl_replicate)
+
+lemma inv_end2_Bk_via_3[elim]: "\<lbrakk>0 < x; inv_end3 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_end2 x (Bk # b, list)"
+  by (auto simp: inv_end2.simps inv_end3.simps)
+
+lemma inv_end5_Bk_via_4[elim]: "\<lbrakk>0 < x; inv_end4 x ([], Bk # list)\<rbrakk> \<Longrightarrow> 
+  inv_end5 x ([], Bk # Bk # list)"
+  by (auto simp: inv_end4.simps inv_end5.simps)
+
+lemma inv_end5_Bk_tail_via_4[elim]: "\<lbrakk>0 < x; inv_end4 x (b, Bk # list); b \<noteq> []\<rbrakk> \<Longrightarrow> 
+  inv_end5 x (tl b, hd b # Bk # list)"
+  apply(auto simp: inv_end4.simps inv_end5.simps)
+  apply(rule_tac x = 1 in exI, simp)
+  done
+
+lemma inv_end0_Bk_via_5[elim]: "\<lbrakk>0 < x; inv_end5 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_end0 x (Bk # b, list)"
+  by(auto simp: inv_end5.simps inv_end0.simps gr0_conv_Suc)
+
+lemma inv_end2_Oc_via_1[elim]: "\<lbrakk>0 < x; inv_end1 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_end2 x (Oc # b, list)"
+  by (auto simp: inv_end1.simps inv_end2.simps)
+
+lemma inv_end4_Bk_Oc_via_2[elim]: "\<lbrakk>0 < x; inv_end2 x ([], Oc # list)\<rbrakk> \<Longrightarrow>
+               inv_end4 x ([], Bk # Oc # list)"
+  by (auto simp: inv_end2.simps inv_end4.simps)
+
+lemma inv_end4_Oc_via_2[elim]:  "\<lbrakk>0 < x; inv_end2 x (b, Oc # list); b \<noteq> []\<rbrakk> \<Longrightarrow>
+  inv_end4 x (tl b, hd b # Oc # list)"
+  by(auto simp: inv_end2.simps inv_end4.simps gr0_conv_Suc)
+
+lemma inv_end2_Oc_via_3[elim]: "\<lbrakk>0 < x; inv_end3 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_end2 x (Oc # b, list)"
+  by (auto simp: inv_end2.simps inv_end3.simps)
+
+lemma inv_end4_Bk_via_Oc[elim]: "\<lbrakk>0 < x; inv_end4 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_end4 x (b, Bk # list)"
+  by (auto simp: inv_end2.simps inv_end4.simps)
+
+lemma inv_end5_Bk_drop_Oc[elim]: "\<lbrakk>0 < x; inv_end5 x ([], Oc # list)\<rbrakk> \<Longrightarrow> inv_end5 x ([], Bk # Oc # list)"
+  by (auto simp: inv_end2.simps inv_end5.simps)
+
+declare inv_end5_loop.simps[simp del]
+  inv_end5_exit.simps[simp del]
+
+lemma inv_end5_exit_no_Oc[simp]: "inv_end5_exit x (b, Oc # list) = False"
+  by (auto simp: inv_end5_exit.simps)
+
+lemma inv_end5_loop_no_Bk_Oc[simp]: "inv_end5_loop x (tl b, Bk # Oc # list) = False"
+  by (auto simp: inv_end5_loop.simps)
+
+lemma inv_end5_exit_Bk_Oc_via_loop[elim]:
+  "\<lbrakk>0 < x; inv_end5_loop x (b, Oc # list); b \<noteq> []; hd b = Bk\<rbrakk> \<Longrightarrow>
+  inv_end5_exit x (tl b, Bk # Oc # list)"
+  apply(auto simp: inv_end5_loop.simps inv_end5_exit.simps)
+  using hd_replicate apply fastforce
+  by (metis cell.distinct(1) hd_append2 hd_replicate list.sel(3) self_append_conv2
+      split_head_repeat(2))
+
+lemma inv_end5_loop_Oc_Oc_drop[elim]: 
+  "\<lbrakk>0 < x; inv_end5_loop x (b, Oc # list); b \<noteq> []; hd b = Oc\<rbrakk> \<Longrightarrow>
+  inv_end5_loop x (tl b, Oc # Oc # list)"
+  apply(simp only: inv_end5_loop.simps inv_end5_exit.simps)
+  apply(erule_tac exE)+
+  apply(rename_tac i j)
+  apply(rule_tac x = "i - 1" in exI, 
+      rule_tac x = "Suc j" in exI, auto)
+   apply(case_tac [!] i, simp_all)
+  done
+
+lemma inv_end5_Oc_tail[elim]: "\<lbrakk>0 < x; inv_end5 x (b, Oc # list); b \<noteq> []\<rbrakk> \<Longrightarrow> 
+  inv_end5 x (tl b, hd b # Oc # list)"
+  apply(simp add: inv_end2.simps inv_end5.simps)
+  apply(case_tac "hd b", simp_all, auto)
+  done
+
+lemma inv_end_step:
+  "\<lbrakk>x > 0; inv_end x cf\<rbrakk> \<Longrightarrow> inv_end x (step cf (tm_copy_end_new, 0))"
+  apply(cases cf, cases "snd (snd cf)"; cases "hd (snd (snd cf))")
+  apply(auto simp: inv_end.simps step.simps tm_copy_end_new_def numeral_eqs_upto_12 split: if_splits)
+  apply (simp add: inv_end1.simps)
+  done
+
+lemma inv_end_steps:
+  "\<lbrakk>x > 0; inv_end x cf\<rbrakk> \<Longrightarrow> inv_end x (steps cf (tm_copy_end_new, 0) stp)"
+  apply(induct stp, simp add:steps.simps, simp)
+  apply(erule_tac inv_end_step, simp)
+  done
+
+fun end_state :: "config \<Rightarrow> nat"
+  where
+    "end_state (s, l, r) = 
+       (if s = 0 then 0
+        else if s = 1 then 5
+        else if s = 2 \<or> s = 3 then 4
+        else if s = 4 then 3 
+        else if s = 5 then 2
+        else 0)"
+
+fun end_stage :: "config \<Rightarrow> nat"
+  where
+    "end_stage (s, l, r) = 
+          (if s = 2 \<or> s = 3 then (length r) else 0)"
+
+fun end_step :: "config \<Rightarrow> nat"
+  where
+    "end_step (s, l, r) = 
+         (if s = 4 then (if hd r = Oc then 1 else 0)
+          else if s = 5 then length l
+          else if s = 2 then 1
+          else if s = 3 then 0
+          else 0)"
+
+definition end_LE :: "(config \<times> config) set"
+  where
+    "end_LE = measures [end_state, end_stage, end_step]"
+
+lemma wf_end_le: "wf end_LE"
+  unfolding end_LE_def by auto
+
+lemma end_halt: 
+  "\<lbrakk>x > 0; inv_end x (Suc 0, l, r)\<rbrakk> \<Longrightarrow> 
+      \<exists> stp. is_final (steps (Suc 0, l, r) (tm_copy_end_new, 0) stp)"
+proof(rule halt_lemma[OF wf_end_le])
+  assume great: "0 < x"
+    and inv_start: "inv_end x (Suc 0, l, r)"
+  show "\<forall>n. \<not> is_final (steps (Suc 0, l, r) (tm_copy_end_new, 0) n) \<longrightarrow> 
+    (steps (Suc 0, l, r) (tm_copy_end_new, 0) (Suc n), steps (Suc 0, l, r) (tm_copy_end_new, 0) n) \<in> end_LE"
+  proof(rule_tac allI, rule_tac impI)
+    fix n
+    assume notfinal: "\<not> is_final (steps (Suc 0, l, r) (tm_copy_end_new, 0) n)"
+    obtain s' l' r' where d: "steps (Suc 0, l, r) (tm_copy_end_new, 0) n = (s', l', r')"
+      apply(case_tac "steps (Suc 0, l, r) (tm_copy_end_new, 0) n", auto)
+      done
+    hence "inv_end x (s', l', r') \<and> s' \<noteq> 0"
+      using great inv_start notfinal
+      apply(drule_tac stp = n in inv_end_steps, auto)
+      done
+    hence "(step (s', l', r') (tm_copy_end_new, 0), s', l', r') \<in> end_LE"
+      apply(cases r'; cases "hd r'")
+         apply(auto simp: inv_end.simps step.simps tm_copy_end_new_def numeral_eqs_upto_12 end_LE_def split: if_splits)
+      done
+    thus "(steps (Suc 0, l, r) (tm_copy_end_new, 0) (Suc n), 
+      steps (Suc 0, l, r) (tm_copy_end_new, 0) n) \<in> end_LE"
+      using d
+      by simp
+  qed
+qed
+
+lemma end_correct:
+  "n > 0 \<Longrightarrow> \<lbrace>inv_end1 n\<rbrace> tm_copy_end_new \<lbrace>inv_end0 n\<rbrace>"
+proof(rule_tac Hoare_haltI)
+  fix l r
+  assume h: "0 < n"
+    "inv_end1 n (l, r)"
+  then have "\<exists> stp. is_final (steps0 (1, l, r) tm_copy_end_new stp)"
+    by (simp add: end_halt inv_end.simps)
+  then obtain stp where "is_final (steps0 (1, l, r) tm_copy_end_new stp)" ..
+  moreover have "inv_end n (steps0 (1, l, r) tm_copy_end_new stp)"
+    apply(rule_tac inv_end_steps)
+    using h by(simp_all add: inv_end.simps)
+  ultimately show
+    "\<exists>stp. is_final (steps (1, l, r) (tm_copy_end_new, 0) stp) \<and> 
+    inv_end0 n holds_for steps (1, l, r) (tm_copy_end_new, 0) stp"        
+    using h
+    apply(rule_tac x = stp in exI)
+    apply(cases "(steps0 (1, l, r) tm_copy_end_new stp)") 
+    apply(simp add: inv_end.simps)
+    done
+qed
+
+(* ---------- tm_weak_copy ---------------------------------------- *)
+(* This is the original weak variant, with a slightly modified end *)
+(* --------------------------------------------------------------- *)
+
+definition 
+  tm_weak_copy :: "instr list"
+  where
+    "tm_weak_copy \<equiv> (tm_copy_begin_orig |+| tm_copy_loop_orig) |+| tm_copy_end_new"
+
+(* The tm_weak_copy machine and all of its parts are composable
+ * (in the old terminologies: well-formed)
+ *)
+
+lemma [intro]:
+  "composable_tm (tm_copy_begin_orig, 0)"
+  "composable_tm (tm_copy_loop_orig, 0)"
+  "composable_tm (tm_copy_end_new, 0)"
+  by (auto simp: composable_tm.simps tm_copy_end_new_def tm_copy_loop_orig_def tm_copy_begin_orig_def)
+
+lemma composable_tm0_tm_weak_copy[intro, simp]: "composable_tm0 tm_weak_copy"
+  by (auto simp: tm_weak_copy_def)
+
+lemma tm_weak_copy_correct_pre: 
+  assumes "0 < x"
+  shows "\<lbrace>inv_begin1 x\<rbrace> tm_weak_copy \<lbrace>inv_end0 x\<rbrace>"
+proof -
+  have "\<lbrace>inv_begin1 x\<rbrace> tm_copy_begin_orig \<lbrace>inv_begin0 x\<rbrace>"
+    by (metis assms begin_correct) 
+  moreover 
+  have "inv_begin0 x \<mapsto> inv_loop1 x"
+    unfolding assert_imp_def
+    unfolding inv_begin0.simps inv_loop1.simps
+    unfolding inv_loop1_loop.simps inv_loop1_exit.simps
+    apply(auto simp add: numeral_eqs_upto_12 Cons_eq_append_conv)
+    by (rule_tac x = "Suc 0" in exI, auto)
+  ultimately have "\<lbrace>inv_begin1 x\<rbrace> tm_copy_begin_orig \<lbrace>inv_loop1 x\<rbrace>"
+    by (rule_tac Hoare_consequence) (auto)
+  moreover
+  have "\<lbrace>inv_loop1 x\<rbrace> tm_copy_loop_orig \<lbrace>inv_loop0 x\<rbrace>"
+    by (metis assms loop_correct) 
+  ultimately 
+  have "\<lbrace>inv_begin1 x\<rbrace> (tm_copy_begin_orig |+| tm_copy_loop_orig) \<lbrace>inv_loop0 x\<rbrace>"
+    by (rule_tac Hoare_plus_halt) (auto)
+  moreover 
+  have "\<lbrace>inv_end1 x\<rbrace> tm_copy_end_new \<lbrace>inv_end0 x\<rbrace>"
+    by (metis assms end_correct) 
+  moreover 
+  have "inv_loop0 x = inv_end1 x"
+    by(auto simp: inv_end1.simps inv_loop1.simps assert_imp_def)
+  ultimately 
+  show "\<lbrace>inv_begin1 x\<rbrace> tm_weak_copy \<lbrace>inv_end0 x\<rbrace>"
+    unfolding tm_weak_copy_def
+    by (rule_tac Hoare_plus_halt) (auto)
+qed
+
+lemma tm_weak_copy_correct:
+  shows "\<lbrace>\<lambda>tap. tap = ([]::cell list, Oc \<up> (Suc n))\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap= ([Bk], <(n, n::nat)>)\<rbrace>"
+proof -
+  have "\<lbrace>inv_begin1 (Suc n)\<rbrace> tm_weak_copy \<lbrace>inv_end0 (Suc n)\<rbrace>"
+    by (rule tm_weak_copy_correct_pre) (simp)
+  moreover
+  have "(\<lambda>tap. tap = ([]::cell list, Oc \<up> (Suc n))) = inv_begin1 (Suc n)"
+    by (auto)
+  moreover
+  have "inv_end0 (Suc n) = (\<lambda>tap. tap= ([Bk], <(n, n::nat)>))"
+    unfolding fun_eq_iff
+    by (auto simp add: inv_end0.simps tape_of_nat_def tape_of_prod_def)
+  ultimately
+  show "\<lbrace>\<lambda>tap. tap = ([]::cell list, Oc \<up> (Suc n))\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap= ([Bk], <(n, n::nat)>)\<rbrace>" 
+    by simp
+qed
+
+(* additional variants of tm_weak_copy_correct *)
+
+lemma tm_weak_copy_correct5: "\<lbrace>\<lambda>tap. tap = ([], <[n::nat]>)\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[n, n]> @ Bk \<up> l) \<rbrace>"
+proof -
+  have "\<lbrace>\<lambda>tap. tap = ([], <n::nat>)\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk], <(n, n)>)\<rbrace>"
+    using tape_of_list_def tape_of_nat_def tape_of_nat_list.simps(2) tm_weak_copy_correct by auto
+  then have "\<lbrace>\<lambda>tap. tap = ([], <n::nat>)\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk], <[n, n]>)\<rbrace>"
+  proof -
+    assume "\<lbrace>\<lambda>tap. tap = ([], <n>)\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk], <(n, n)>)\<rbrace>"
+    moreover have  "<(n, n)> = <[n, n]>"
+      by (simp add:   tape_of_list_def tape_of_nat_list.elims tape_of_prod_def)
+    ultimately show ?thesis
+      by auto
+  qed
+  then have "\<lbrace>\<lambda>tap. tap = ([], <[n::nat]>)\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk], <[n, n]>)\<rbrace>"
+    by (metis tape_of_list_def tape_of_nat_list.simps(2))
+  then show ?thesis
+    by (smt Hoare_haltE Hoare_haltI One_nat_def append.right_neutral
+            holds_for.elims(2) holds_for.simps replicate.simps(1) replicate.simps(2))
+qed
+
+lemma tm_weak_copy_correct6:
+  "\<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <[n::nat]> @[Bk])\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[n::nat, n]> @ Bk \<up> l) \<rbrace>" 
+proof -
+  have "\<lbrace>\<lambda>tap. tap = ([], <[n::nat]>)\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[n::nat, n]> @ Bk \<up> l) \<rbrace>"
+    by (rule tm_weak_copy_correct5)
+  then have "\<lbrace>\<lambda>tap. \<exists>kl ll. tap = (Bk \<up> kl, <[n::nat]> @ Bk \<up> ll)\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, <[n::nat, n]> @ Bk \<up> lr)\<rbrace>"
+    using TMC_has_num_res_list_without_initial_Bks_imp_TMC_has_num_res_list_after_adding_Bks_to_initial_left_and_right_tape by auto
+  then have "\<lbrace>\<lambda>tap. \<exists>z4. tap = (Bk \<up> z4, <[n::nat]> @ Bk \<up> (Suc 0))\<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>kr lr. tap = (Bk \<up> kr, <[n::nat, n]> @ Bk \<up> lr)\<rbrace>"
+    by (smt Hoare_haltE Hoare_haltI)
+  then show ?thesis
+    by auto
+qed
+
+(* ---------------------------------------------------- *)
+(* Properties of tm_weak_copy for lists of length \<noteq> 1   *)
+(* ---------------------------------------------------- *)
+
+(* FABR: Some principle reminder about rewriting/simplification of properties for composed TMs
+ *  value "steps0 (1, [Bk,Bk], [Bk]) tm_weak_copy 3"
+ *  > "(0, [Bk, Bk, Bk, Bk], [])"
+ *
+ *  value "steps0 (1, [Bk,Bk], [Bk]) tm_weak_copy 3 = (0, [Bk, Bk, Bk, Bk], [])"
+ *  > True
+ *
+ * 1) If we define a TM directly by an instruction list, the simplifier is able
+ *    to compute results (as is the 'value' instruction).
+ *
+ * 2) However, if we define TMs by seq_tm, we must add more rules for rewriting
+ *
+ * Examples:
+ *
+ * Machine tm_strong_copy_post is identical to tm_weak_copy
+ * However,
+ *  tm_strong_copy_post is defined as a plain instruction list
+ *  tm_weak_copy is defined by seqeuntial composition
+ *
+ *  "tm_weak_copy \<equiv> (tm_copy_begin_orig |+| tm_copy_loop_orig) |+| tm_copy_end_new"
+ *
+ *)
+
+definition 
+  strong_copy_post :: "instr list"
+  where
+    "strong_copy_post \<equiv> [
+       (WB,5),(R,2), (R,3),(R,2),    (WO,3),(L,4),  (L,4),(L,5),    (R,11),(R,6),
+       (R,7),(WB,6), (R,7),(R,8),    (WO,9),(R,8),  (L,10),(L,9),   (L,10),(L,5),
+       (R,0),(R,12), (WO,13),(L,14), (R,12),(R,12), (L,15),(WB,14), (R,0),(L,15)
+     ]"
+
+value "steps0 (1, [Bk,Bk], [Bk]) strong_copy_post 3 = (0::nat, [Bk, Bk, Bk, Bk], [])"
+
+lemma "steps0 (1, [Bk,Bk], [Bk]) strong_copy_post 3 = (0::nat, [Bk, Bk, Bk, Bk], [])"
+  by (simp add: step.simps steps.simps numeral_eqs_upto_12  strong_copy_post_def)
+
+(* now, we try the same proof for tm_weak_copy *)
+
+(* The rewriter is not able to solve the problem like this:
+
+lemma "steps0 (1, [Bk,Bk], [Bk]) tm_weak_copy 3 = (0::nat, [Bk, Bk, Bk, Bk], [])"
+  by (simp add: step.simps steps.simps numeral_eqs_upto_12
+                tm_weak_copy_def strong_copy_post_def
+                tm_copy_begin_orig_def tm_copy_loop_orig_def tm_copy_end_new_def
+                adjust.simps shift.simps seq_tm.simps)
+*)
+
+(* There are at least the following two solutions: *)
+
+(* Solution 1:
+ *   Prove equality "tm_weak_copy = strong_copy_post"
+ *   and rewrite with respect to plain instruction list strong_copy_post
+ *)
+
+lemma tm_weak_copy_eq_strong_copy_post: "tm_weak_copy = strong_copy_post"
+  unfolding tm_weak_copy_def strong_copy_post_def
+            tm_copy_begin_orig_def tm_copy_loop_orig_def tm_copy_end_new_def
+  by (simp add: adjust.simps shift.simps seq_tm.simps)
+
+lemma tm_weak_copy_correct11:
+  "\<lbrace>\<lambda>tap. tap = ([Bk,Bk], [Bk]) \<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk,Bk,Bk,Bk],[]) \<rbrace>"
+proof -
+  have "steps0 (1, [Bk,Bk], [Bk]) strong_copy_post 3 = (0::nat, [Bk, Bk, Bk, Bk], [])"
+    by (simp add: step.simps steps.simps numeral_eqs_upto_12  strong_copy_post_def)
+  then show ?thesis
+    by (smt Hoare_haltI holds_for.simps is_final_eq tm_weak_copy_eq_strong_copy_post)
+qed
+
+lemma tm_weak_copy_correct12: (* this lemma is not used anywhere *)
+  "\<lbrace>\<lambda>tap. tap = ([Bk,Bk], [Bk]) \<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = ( Bk \<up> k, Bk \<up> l) \<rbrace>"
+proof -
+  have "Bk \<up> 4 = [Bk, Bk, Bk, Bk]"
+    by (simp add: numeral_eqs_upto_12)
+  moreover have "Bk \<up> 0 = []"
+    by (simp add: numeral_eqs_upto_12)
+  ultimately
+  have "\<lbrace>\<lambda>tap. tap = ([Bk,Bk], [Bk]) \<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ( Bk \<up> 4, Bk \<up> 0) \<rbrace>"
+    using tm_weak_copy_correct11
+    by auto
+  then show ?thesis
+    by (metis (no_types, lifting)  Hoare_halt_def holds_for.elims(2) holds_for.simps)
+qed
+
+lemma tm_weak_copy_correct13:
+  "\<lbrace>\<lambda>tap. tap = ([], [Bk,Bk]@r) \<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk,Bk], r) \<rbrace>" 
+proof -
+  have "steps0 (1, [], [Bk,Bk]@r) strong_copy_post 3 = (0::nat, [Bk,Bk], r)"
+    by (simp add: step.simps steps.simps numeral_eqs_upto_12  strong_copy_post_def)
+  then show ?thesis
+    by (smt Hoare_haltI holds_for.simps is_final_eq tm_weak_copy_eq_strong_copy_post)
+qed
+
+(* Solution 2: (pays off for more complicated cases)
+ *
+ *   Use compositional reasoning on components of tm_weak_copy using our Hoare rules."
+ *
+ *   "tm_weak_copy \<equiv> (tm_copy_begin_orig |+| tm_copy_loop_orig) |+| tm_copy_end_new"
+ *
+ * See our exploration in file HaskellCode/EngineeringOf_StrongCopy.hs
+ * These yield the concrete steps and results to compute for the intermediate
+ * steps in the following proofs.
+ *
+ *)
+
+(* A compositional proof using Hoare_rules for
+ *
+ *    "\<lbrace>\<lambda>tap. tap = ([Bk,Bk], [Bk]) \<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk,Bk,Bk,Bk],[]) \<rbrace>"
+ *
+ * "steps0 (1, [Bk, Bk],     [Bk]) tm_copy_begin_orig 1 = (0, [Bk, Bk],         [Bk])"
+ * "steps0 (1, [Bk, Bk],     [Bk]) tm_copy_loop_orig  1 = (0, [Bk, Bk, Bk],     []  )"
+ * "steps0 (1, [Bk, Bk, Bk], []  ) tm_copy_end_new    1 = (0, [Bk, Bk, Bk, Bk], []  )"
+ *
+ * See HaskellCode/EngineeringOf_StrongCopy.hs for the exploration.
+ *)
+
+lemma tm_weak_copy_correct11':
+  "\<lbrace>\<lambda>tap. tap = ([Bk,Bk], [Bk]) \<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk,Bk,Bk,Bk],[]) \<rbrace>"
+proof -
+  have "\<lbrace>\<lambda>tap. tap = ([Bk,Bk], [Bk]) \<rbrace>
+        (tm_copy_begin_orig |+| tm_copy_loop_orig) |+| tm_copy_end_new
+        \<lbrace>\<lambda>tap. tap = ([Bk,Bk,Bk,Bk],[]) \<rbrace>"
+  proof (rule Hoare_plus_halt)
+    show "composable_tm0 (tm_copy_begin_orig |+| tm_copy_loop_orig)"
+      by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+          tm_copy_begin_orig_def tm_copy_loop_orig_def)
+  next
+    show "\<lbrace>\<lambda>tap. tap = ([Bk, Bk, Bk], [])\<rbrace> tm_copy_end_new \<lbrace>\<lambda>tap. tap = ([Bk, Bk, Bk, Bk], [])\<rbrace>"
+    proof -
+      have "steps0 (1, [Bk, Bk, Bk], []) tm_copy_end_new 1 = (0, [Bk, Bk, Bk, Bk], [])"
+        by (simp add: step.simps steps.simps numeral_eqs_upto_12  tm_copy_end_new_def)
+      then show ?thesis
+        by (smt Hoare_haltI holds_for.simps is_final_eq tm_weak_copy_eq_strong_copy_post)
+    qed
+  next
+    show " \<lbrace>\<lambda>tap. tap = ([Bk, Bk], [Bk])\<rbrace>
+           tm_copy_begin_orig |+| tm_copy_loop_orig
+           \<lbrace>\<lambda>tap. tap = ([Bk, Bk, Bk], [])\<rbrace>"
+    proof (rule Hoare_plus_halt)
+      show "composable_tm0 tm_copy_begin_orig"
+        by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+            tm_copy_begin_orig_def)
+    next
+      show "\<lbrace>\<lambda>tap. tap = ([Bk, Bk], [Bk])\<rbrace> tm_copy_begin_orig \<lbrace>\<lambda>tap. tap = ([Bk, Bk], [Bk])\<rbrace>"
+      proof -
+        have "steps0 (1, [Bk, Bk], [Bk]) tm_copy_begin_orig 1 = (0, [Bk, Bk], [Bk])"
+          by (simp add: step.simps steps.simps numeral_eqs_upto_12  tm_copy_begin_orig_def)
+        then show ?thesis
+          by (smt Hoare_haltI holds_for.simps is_final_eq tm_weak_copy_eq_strong_copy_post)
+      qed
+    next
+      show "\<lbrace>\<lambda>tap. tap = ([Bk, Bk], [Bk])\<rbrace> tm_copy_loop_orig \<lbrace>\<lambda>tap. tap = ([Bk, Bk, Bk], [])\<rbrace>"
+      proof -
+        have "steps0 (1, [Bk, Bk], [Bk]) tm_copy_loop_orig 1 = (0, [Bk, Bk, Bk], [])"
+          by (simp add: step.simps steps.simps numeral_eqs_upto_12  tm_copy_loop_orig_def)
+        then show ?thesis
+          by (smt Hoare_haltI holds_for.simps is_final_eq tm_weak_copy_eq_strong_copy_post)
+      qed
+    qed
+  qed
+  then show ?thesis
+    unfolding tm_weak_copy_def
+    by auto
+qed
+
+(* -- *)
+
+(* A compositional proof using Hoare_rules for
+ *
+ *    "\<lbrace>\<lambda>tap. tap = ([], [Bk,Bk]@r) \<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. \<exists>k l. tap = ([Bk,Bk], r) \<rbrace>"
+ *
+ * "steps0 (1, [],   [Bk,Bk] @ r) tm_copy_begin_orig 1 = (0, [],       [Bk,Bk] @ r)"
+ * "steps0 (1, [],   [Bk,Bk] @ r) tm_copy_loop_orig  1 = (0, [Bk],     [Bk]    @ r)"
+ * "steps0 (1, [Bk], [Bk]    @ r) tm_copy_end_new    1 = (0, [Bk, Bk],           r)"
+ *
+ * See HaskellCode/EngineeringOf_StrongCopy.hs for the exploration.
+ *)
+
+lemma tm_weak_copy_correct13':
+  "\<lbrace>\<lambda>tap. tap = ([], [Bk,Bk]@r) \<rbrace> tm_weak_copy \<lbrace>\<lambda>tap. tap = ([Bk,Bk], r) \<rbrace>" 
+proof -
+  have "\<lbrace>\<lambda>tap. tap = ([], [Bk,Bk]@r) \<rbrace>
+        (tm_copy_begin_orig |+| tm_copy_loop_orig) |+| tm_copy_end_new
+        \<lbrace>\<lambda>tap. tap = ([Bk,Bk], r) \<rbrace>"
+  proof (rule Hoare_plus_halt)
+    show "composable_tm0 (tm_copy_begin_orig |+| tm_copy_loop_orig)"
+      by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+          tm_copy_begin_orig_def tm_copy_loop_orig_def)
+  next
+    show "\<lbrace>\<lambda>tap. tap = ([Bk], [Bk] @ r)\<rbrace> tm_copy_end_new \<lbrace>\<lambda>tap. tap = ([Bk, Bk], r)\<rbrace>"
+    proof -
+      have "steps0 (1, [Bk], [Bk]  @ r) tm_copy_end_new 1 = (0, [Bk, Bk], r)"
+        by (simp add: step.simps steps.simps numeral_eqs_upto_12  tm_copy_end_new_def)
+      then show ?thesis
+        by (smt Hoare_haltI holds_for.simps is_final_eq tm_weak_copy_eq_strong_copy_post)
+    qed
+  next
+    show " \<lbrace>\<lambda>tap. tap = ([], [Bk, Bk] @ r)\<rbrace>
+           tm_copy_begin_orig |+| tm_copy_loop_orig
+           \<lbrace>\<lambda>tap. tap = ([Bk], [Bk] @ r)\<rbrace>"
+    proof (rule Hoare_plus_halt)
+      show "composable_tm0 tm_copy_begin_orig"
+        by (simp add: composable_tm.simps adjust.simps shift.simps seq_tm.simps 
+            tm_copy_begin_orig_def)
+    next
+      show "\<lbrace>\<lambda>tap. tap = ([], [Bk, Bk] @ r)\<rbrace> tm_copy_begin_orig \<lbrace>\<lambda>tap. tap = ([], [Bk,Bk] @ r)\<rbrace>"
+      proof -
+        have "steps0 (1, [], [Bk, Bk] @ r) tm_copy_begin_orig 1 = (0, [], [Bk,Bk] @ r)"
+          by (simp add: step.simps steps.simps numeral_eqs_upto_12  tm_copy_begin_orig_def)
+        then show ?thesis
+          by (smt Hoare_haltI holds_for.simps is_final_eq tm_weak_copy_eq_strong_copy_post)
+      qed
+    next
+      show "\<lbrace>\<lambda>tap. tap = ([], [Bk, Bk] @ r)\<rbrace> tm_copy_loop_orig \<lbrace>\<lambda>tap. tap = ([Bk], [Bk] @ r)\<rbrace>"
+      proof -
+        have "steps0 (1, [], [Bk,Bk] @ r) tm_copy_loop_orig 1 = (0, [Bk], [Bk] @ r)"
+          by (simp add: step.simps steps.simps numeral_eqs_upto_12  tm_copy_loop_orig_def)
+        then show ?thesis
+          by (smt Hoare_haltI holds_for.simps is_final_eq tm_weak_copy_eq_strong_copy_post)
+      qed
+    qed
+  qed
+  then show ?thesis
+    unfolding tm_weak_copy_def
+    by auto
+qed
+
+end
diff --git a/thys/Universal_Turing_Machine/document/root.bib b/thys/Universal_Turing_Machine/document/root.bib
--- a/thys/Universal_Turing_Machine/document/root.bib
+++ b/thys/Universal_Turing_Machine/document/root.bib
@@ -1,195 +1,195 @@
 %% This BibTeX bibliography file was created using BibDesk.
 %% http://bibdesk.sourceforge.net/
 
 
 %% Created for Sebastiaan Joosten at 2019-01-16 16:58:30 +0100 
 
 
 %% Saved with string encoding Unicode (UTF-8) 
 
 
 
 @article{Recursion-Theory-I-AFP,
 	Author = {Michael Nedzelsky},
 	Date-Added = {2019-01-16 16:46:50 +0100},
 	Date-Modified = {2019-01-16 16:46:50 +0100},
 	Issn = {2150-914x},
 	Journal = {Archive of Formal Proofs},
 	Month = apr,
 	Note = {\url{http://isa-afp.org/entries/Recursion-Theory-I.html}, Formal proof development},
 	Title = {Recursion Theory I},
 	Year = 2008}
 
 @article{Minsky_Machines-AFP,
 	Author = {Bertram Felgenhauer},
 	Date-Added = {2019-01-16 16:41:43 +0100},
 	Date-Modified = {2019-01-16 16:41:43 +0100},
 	Issn = {2150-914x},
 	Journal = {Archive of Formal Proofs},
 	Month = aug,
 	Note = {\url{http://isa-afp.org/entries/Minsky_Machines.html}, Formal proof development},
 	Title = {Minsky Machines},
 	Year = 2018}
 
 @article{Joosten18,
 	Abstract = {We give a procedure that can be used to automatically satisfy invariants of a certain shape. These invariants may be written with the operations intersection, composition and converse over binary relations, and equality over these operations. We call these invariants sentences that we interpret over graphs. For questions stated through sets of these sentences, this paper gives a semi-decision procedure we call graph saturation. It decides entailment over these sentences, inspired on graph rewriting. We prove correctness of the procedure. Moreover, we show the corresponding decision problem to be undecidable. This confirms a conjecture previously stated by the author [7].},
 	Author = {Sebastiaan J.C. Joosten},
 	Date-Added = {2019-01-16 16:38:28 +0100},
 	Date-Modified = {2019-01-16 16:38:28 +0100},
 	Doi = {https://doi.org/10.1016/j.jlamp.2018.06.005},
 	Issn = {2352-2208},
 	Journal = {Journal of Logical and Algebraic Methods in Programming},
 	Pages = {98 - 112},
 	Title = {Finding models through graph saturation},
 	Url = {http://www.sciencedirect.com/science/article/pii/S2352220817301840},
 	Volume = {100},
 	Year = {2018},
 	Bdsk-Url-1 = {http://www.sciencedirect.com/science/article/pii/S2352220817301840},
 	Bdsk-Url-2 = {https://doi.org/10.1016/j.jlamp.2018.06.005}}
 
 @article{Graph_Saturation-AFP,
 	Author = {Sebastiaan J. C. Joosten},
 	Date-Added = {2019-01-16 16:37:15 +0100},
 	Date-Modified = {2019-01-16 16:37:15 +0100},
 	Issn = {2150-914x},
 	Journal = {Archive of Formal Proofs},
 	Month = nov,
 	Note = {\url{http://isa-afp.org/entries/Graph_Saturation.html}, Formal proof development},
 	Title = {Graph Saturation},
 	Year = 2018}
 
 @inproceedings{Xu13,
 	Abstract = {We formalise results from computability theory in the theorem prover Isabelle/HOL. Following the textbook by Boolos et al, we formalise Turing machines and relate them to abacus machines and recursive functions. We ``tie the know'' between these three computational models by formalising a universal function and obtaining from it a universal Turing machine by our verified translation from recursive functions to abacus programs and from abacus programs to Turing machine programs. Hoare-style reasoning techniques allow us to reason about concrete Turing machine and abacus programs.},
 	Address = {Berlin, Heidelberg},
 	Author = {Xu, Jian and Zhang, Xingyuan and Urban, Christian},
 	Booktitle = {Interactive Theorem Proving},
 	Date-Added = {2019-01-15 13:15:48 +0100},
 	Date-Modified = {2019-01-15 13:15:48 +0100},
 	Editor = {Blazy, Sandrine and Paulin-Mohring, Christine and Pichardie, David},
 	Isbn = {978-3-642-39634-2},
 	Pages = {147--162},
 	Publisher = {Springer Berlin Heidelberg},
 	Title = {Mechanising Turing Machines and Computability Theory in Isabelle/HOL},
 	Year = {2013}}
 
 @inproceedings{Krauss10,
 	Author = {A.~Krauss},
 	Booktitle = {Proc.~of the Workshop on Partiality and Recursion in Interactive Theorem Provers},
 	Pages = {1-13},
 	Series = {EPTCS},
 	Title = {{R}ecursive {D}efinitions of {M}onadic {F}unctions},
 	Volume = {43},
 	Year = {2010}}
 
 @phdthesis{Myreen09,
 	Author = {M.~O.~Myreen},
 	School = {University of Cambridge},
 	Title = {{F}ormal {V}erification of {M}achine-{C}ode {P}rograms},
 	Year = 2009}
 
 @article{Nipkow98,
 	Author = {T.~Nipkow},
 	Journal = {Formal Aspects of Computing},
 	Pages = {171--186},
 	Title = {{W}inskel is (almost) {R}ight: {T}owards a {M}echanized {S}emantics {T}extbook},
 	Volume = 10,
 	Year = 1998}
 
 @inproceedings{Jensen13,
 	Author = {J.~Braband Jensen and N.~Benton and A.~Kennedy},
 	Booktitle = {Proc.~of the 40th Symposium on Principles of Programming Languages (POPL)},
 	Pages = {301--314},
 	Title = {{H}igh-{L}evel {S}eparation {L}ogic for {L}ow-{L}evel {C}ode},
 	Year = {2013}}
 
 @article{UrbanCheneyBerghofer11,
 	Author = {C.~Urban and J.~Cheney and S.~Berghofer},
 	Issue = {2},
 	Journal = {ACM Transactions on Computational Logic},
 	Pages = {15:1--15:42},
 	Title = {{M}echanizing the {M}etatheory of {LF}},
 	Volume = {12},
 	Year = {2011}}
 
 @inproceedings{Norrish11,
 	Author = {M.~Norrish},
 	Booktitle = {Proc.~of the 2nd Conference on Interactive Theorem Proving (ITP)},
 	Pages = {297--311},
 	Series = {LNCS},
 	Title = {{M}echanised {C}omputability {T}heory},
 	Volume = {6898},
 	Year = {2011}}
 
 @inproceedings{AspertiRicciotti12,
 	Author = {A.~Asperti and W.~Ricciotti},
 	Booktitle = {Proc.~of the 19th International Workshop on Logic, Language, Information and Computation (WoLLIC)},
 	Pages = {1-25},
 	Series = {LNCS},
 	Title = {{F}ormalizing {T}uring {M}achines},
 	Volume = {7456},
 	Year = {2012}}
 
 @unpublished{WuZhangUrban12,
 	Author = {C.~Wu and X.~Zhang and C.~Urban},
 	Note = {Submitted},
 	Title = {{A} {F}ormal {M}odel and {C}orrectness {P}roof for an {A}ccess {C}ontrol {P}olicy {F}ramework},
 	Year = {2013}}
 
-@book{Boolos87,
+@book{Boolos07,
 	Author = {G.~Boolos and J.~P.~Burgess and R.~C.~Jeffrey},
 	Publisher = {Cambridge University Press},
 	Title = {{C}omputability and {L}ogic (5th~ed.)},
 	Year = {2007}}
 
 @book{BoolosFourth,
 	Author = {G.~Boolos and J.~P.~Burgess and R.~C.~Jeffrey},
 	Publisher = {Cambridge University Press},
 	Title = {{C}omputability and {L}ogic (4th~ed.)},
 	Year = {2002}}
 
 @inproceedings{WuZhangUrban11,
 	Author = {C.~Wu and X.~Zhang and C.~Urban},
 	Booktitle = {Proc.~of the 2nd Conference on Interactive Theorem Proving},
 	Pages = {341--356},
 	Series = {LNCS},
 	Title = {{A} {F}ormalisation of the {M}yhill-{N}erode {T}heorem based on {R}egular {E}xpressions ({P}roof {P}earl)},
 	Volume = {6898},
 	Year = {2011}}
 
 @article{Post36,
 	Author = {E.~Post},
 	Journal = {Journal of Symbolic Logic},
 	Number = {3},
 	Pages = {103--105},
 	Title = {{F}inite {C}ombinatory {P}rocesses-{F}ormulation 1},
 	Volume = {1},
 	Year = {1936}}
 
 @article{Dijkstra68,
 	Author = {E.~W.~Dijkstra},
 	Journal = {Communications of the ACM},
 	Number = {3},
 	Pages = {147-148},
 	Title = {{G}o to {S}tatement {C}onsidered {H}armful},
 	Volume = {11},
 	Year = {1968}}
 
 @book{Berger66,
 	Author = {R.~Berger},
 	Journal = {Memoirs of the American Mathematical Society},
 	Title = {{T}he {U}ndecidability of the {D}omino {P}roblem},
 	Year = {1966}}
 
 @article{Robinson71,
 	Author = {R.~M.~Robinson},
 	Journal = {Inventiones Mathematicae},
 	Pages = {177--209},
 	Title = {{U}ndecidability and {N}onperiodicity for {T}ilings of the {P}lane},
 	Volume = {12},
 	Year = {1971}}
 
 @phdthesis{Zammit99,
 	Author = {V.~Zammit},
 	School = {University of Kent},
 	Title = {{O}n the {R}eadability of {M}achine {C}heckable {F}ormal {P}roofs},
 	Year = {1999}}
diff --git a/thys/Universal_Turing_Machine/document/root.tex b/thys/Universal_Turing_Machine/document/root.tex
--- a/thys/Universal_Turing_Machine/document/root.tex
+++ b/thys/Universal_Turing_Machine/document/root.tex
@@ -1,88 +1,123 @@
-\documentclass{article}
-\usepackage[T1]{fontenc}
+\documentclass{report}
 %\documentclass[runningheads]{llncs}
 \usepackage{isabelle}
 \usepackage{isabellesym}
 \usepackage{times}
 \usepackage{amssymb}
 \usepackage{amsmath}
 \usepackage{stmaryrd}
 \usepackage{mathpartir}
-%\usepackage{pdfsetup}
 \usepackage{tikz}
 \usepackage{pgf}
 \usepackage{color}
 \usetikzlibrary{calc}
 \usetikzlibrary{positioning}
 
 
 %% for testing
 %\usepackage{endnotes}
 %\let\footnote=\endnote
 \def\inst#1{\unskip$^{#1}$}
 
 % urls in roman style, theory text in math-similar italics
 \isabellestyle{it}
 
 % this should be the last package used
 \usepackage{pdfsetup}
 
 
 % gray boxes
 \definecolor{mygrey}{rgb}{.80,.80,.80}
 
 % mathpatir
 \mprset{sep=0.9em}
 \mprset{center=false}
 \mprset{flushleft=true}
 
 % for uniform font size
 %\renewcommand{\isastyle}{\isastyleminor}
 
 \def\dn{\,\stackrel{\mbox{\scriptsize def}}{=}\,}
 \renewcommand{\isasymequiv}{$\dn$}
 \renewcommand{\isasymemptyset}{$\varnothing$}
 \renewcommand{\isacharunderscore}{\mbox{$\_$}}
 \renewcommand{\isasymiota}{}
 \newcommand{\isasymulcorner}{$\ulcorner$}
 \newcommand{\isasymurcorner}{$\urcorner$}
-\newcommand{\chapter}{\section}
+%\newcommand{\chapter}{\section}
+
+\setcounter{tocdepth}{3}
+\setcounter{secnumdepth}{3}
 
 \begin{document}
 
 
 \title{Universal Turing Machine and Computability Theory in Isabelle/HOL}
-\author{Jian Xu\inst{2} \and Xingyuan Zhang\inst{2} \and Christian Urban\inst{1} \and Sebastiaan J. C. Joosten\inst{3} \vspace{3pt} \\
-\inst{1}King's College London, UK \\ \inst{2}PLA University of Science and Technology, China \\ \inst{3}University of Twente, the Netherlands}
+\author{Jian Xu\inst{2} \and Xingyuan Zhang\inst{2} \and Christian Urban\inst{1}
+ \and Sebastiaan J. C. Joosten\inst{3}
+ \and Franz A. B. Regensburger\inst{4} \vspace{3pt} \\
+\inst{1}King's College London, UK \\
+\inst{2}PLA University of Science and Technology, China \\
+\inst{3}University of Twente, the Netherlands \\
+\inst{4}Technische Hochschule Ingolstadt, Germany}
 
 \maketitle
 
-
 \begin{abstract}
-We formalise results from computability theory: recursive functions, undecidability of the halting problem, and the existence of a universal Turing machine. 
-This formalisation is the AFP entry corresponding to: Mechanising Turing Machines and Computability Theory in Isabelle/HOL, ITP 2013
+We formalise results from computability theory: Turing decidability, Turing
+  computability, reduction of decision problems, recursive functions,
+  undecidability of the special and the general halting problem, and the
+  existence of a universal Turing machine.  This formalisation extends the
+  original AFP entry of 2014 that corresponded to: Mechanising Turing Machines
+  and Computability Theory in Isabelle/HOL, ITP 2013
 \end{abstract}
 
-The AFP entry and by extension this document is largely written by Jian Xu, Xingyuan Zhang, and Christian Urban.
-The Universal Turing Machine is well explained in this document, starting at Figure~\ref{prepare_input}.
-Regardless, you may want to read the original ITP article~\cite{Xu13} instead of this pdf document corresponding to the AFP entry.
-If you are just interested in results about Turing Machines and Computability theory: the main book used for this formalisation is by Boolos~\cite{Boolos87}.
+The AFP entry and by extension this document is largely written by Jian Xu,
+Xingyuan Zhang, and Christian Urban.  The Universal Turing Machine is well
+explained in this document, starting at Figure~\ref{prepare_input}.
+Regardless, you may want to read the original ITP article~\cite{Xu13} instead of
+ this pdf document corresponding to the AFP entry.
+If you are just interested in results about Turing Machines and Computability theory:
+the main book used for this formalisation is by Boolos, Burgess, and Jeffrey~\cite{Boolos07}.
 
-Sebastiaan J. C. Joosten contributed mainly by making the files ready for the AFP.
-The need for a good formalisation of Turing Machines arose from realising that the current formalisation of saturation graphs~\cite{Graph_Saturation-AFP} is missing a key undecidability result present in the original paper~\cite{Joosten18}.
-Recently, an undecidability result has been added to the AFP by Bertram Felgenhauer~\cite{Minsky_Machines-AFP}, using a definition of computably enumerable sets formalised by Michael Nedzelsky~\cite{Recursion-Theory-I-AFP}.
-Showing the equivalence of these entirely separate notions of computability and decidability remains future work.
+Sebastiaan J. C. Joosten contributed mainly by making the files ready for the
+AFP.  The need for a good formalisation of Turing Machines arose from realising
+that the current formalisation of saturation graphs~\cite{Graph_Saturation-AFP}
+is missing a key undecidability result present in the original
+paper~\cite{Joosten18}.
+Recently, an undecidability result has been added to the AFP by
+ Bertram Felgenhauer~\cite{Minsky_Machines-AFP}, using a definition of computably enumerable
+ sets formalised by Michael Nedzelsky~\cite{Recursion-Theory-I-AFP}.
+Showing the equivalence of these entirely separate notions of computability
+ and decidability remains future work.
+
+Recently in 2022, Franz Regensburger contributed by adding definitions for
+concepts like Turing Decidability, Turing Computability and Turing Reducibility
+for problem reduction. He also enhanced the result about the
+undecidability of the General Halting Problem given in the original AFP entry
+by first proving the undecidability of the Special Halting Problem and then
+proving its reducibility to the general problem. The original version of this
+AFP entry did only prove a weak form of the undecidability theorem.
+The main motivation behind this contribution is to make the AFP entry
+accessible for bachelor and master students.
+
+As a result, the presentation of the first chapter about Turing
+Machines has been considerably restructured and, in this context some minor
+changes in the naming of concepts were performed as well. In the rest of the theories
+the sectioning of the \LaTeX{} document was improved.
+The overal contribution approximately doubled the size of the code base.
+Please refer to the CHANGELOG in the AFP entry for more details.
 
 % generated text of all theories
 \input{session}
 
 % optional bibliography
 \bibliographystyle{abbrv}
 \bibliography{root}
 
 \end{document}
 
 %%% Local Variables:
 %%% mode: latex
 %%% TeX-master: t
 %%% End: