diff --git a/thys/Universal_Turing_Machine/BlanksDoNotMatter.thy b/thys/Universal_Turing_Machine/BlanksDoNotMatter.thy
--- a/thys/Universal_Turing_Machine/BlanksDoNotMatter.thy
+++ b/thys/Universal_Turing_Machine/BlanksDoNotMatter.thy
@@ -1,1260 +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
+  by (smt (verit) 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/HaltingProblems_K_H.thy b/thys/Universal_Turing_Machine/HaltingProblems_K_H.thy
--- a/thys/Universal_Turing_Machine/HaltingProblems_K_H.thy
+++ b/thys/Universal_Turing_Machine/HaltingProblems_K_H.thy
@@ -1,567 +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)
+      by (smt (verit) 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)
+    by (smt (verit, ccfv_threshold) 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>
+          by (smt (verit) 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/Numerals.thy b/thys/Universal_Turing_Machine/Numerals.thy
--- a/thys/Universal_Turing_Machine/Numerals.thy
+++ b/thys/Universal_Turing_Machine/Numerals.thy
@@ -1,874 +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)
+  by (smt (verit) 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/Recursive.thy b/thys/Universal_Turing_Machine/Recursive.thy
--- a/thys/Universal_Turing_Machine/Recursive.thy
+++ b/thys/Universal_Turing_Machine/Recursive.thy
@@ -1,2869 +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_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 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 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 "\<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':
   "\<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 "\<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 "\<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> 
   \<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
 
 subsubsection \<open>Correctness of compilation for constructor id\<close>
 
 lemma compile_id_correct':
   assumes "n < length args" 
   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 "\<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> \<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> \<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. \<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 
     "\<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 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. \<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. \<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:
     "\<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)
       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 
         "\<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))
         \<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 "\<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 "\<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 "\<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 
               "(\<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 
             "\<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 @ 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 "\<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]\<rbrace>"
               using a c d e h
               apply(rule_tac mv_box_correct)
                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 
                   split: if_splits, auto)
             ultimately show "?thesis"
               by(simp)
           qed
         qed  
       qed
       ultimately show 
         "\<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))
     \<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': 
       "\<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. \<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 
     "\<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 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> \<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> \<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 "\<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 "\<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 "\<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 "\<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 "\<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>\<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>"
 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> \<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 "\<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 "\<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 "\<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 "\<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 "\<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: 
   "\<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)
   \<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 "\<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> \<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)
   \<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 "\<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)
         \<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>  \<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\<rbrace>
     mv_box far (max (Suc (length xs)) (Max (insert ffp ((\<lambda>(aprog, p, n). n) ` rec_ci ` set 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\<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 "\<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:
   "\<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 "\<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))
+    by (smt (verit) 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>
   \<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> \<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 "\<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 "\<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 "\<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>
   \<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\<rbrace>
   empty_boxes (length gs)
   \<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 "\<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:
   "\<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)
   \<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\<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 "\<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:
   "\<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\<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)
   \<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 "\<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)
         \<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>
   \<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. \<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 
     "\<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)))))))
   \<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 "\<lbrace>?P1\<rbrace> (?A [+] (?B [+] (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H))))))) \<lbrace>?S\<rbrace>"
   proof(rule_tac abc_Hoare_plus_halt)
     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 "\<lbrace>?Q1\<rbrace> (?B [+] (?C [+] (?D [+] (?E [+] (?F [+] (?G [+] ?H)))))) \<lbrace>?S\<rbrace>"
     proof(rule_tac abc_Hoare_plus_halt)
       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 "\<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 "\<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 "\<lbrace>?Q3\<rbrace> (?D [+] (?E [+] (?F [+] (?G [+] ?H)))) \<lbrace>?S\<rbrace>"
         proof(rule_tac abc_Hoare_plus_halt)
           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 "\<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 "\<lbrace>?Q4\<rbrace> (?E [+] (?F [+] (?G [+] ?H))) \<lbrace>?S\<rbrace>"
           proof(rule_tac abc_Hoare_plus_halt)
             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 "\<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 "\<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 "\<lbrace>?Q6\<rbrace> (?G [+] ?H) \<lbrace>?S\<rbrace>"
               proof(rule_tac abc_Hoare_plus_halt)
                 show "\<lbrace>?Q6\<rbrace> ?G \<lbrace>?Q7\<rbrace>"
                   by(rule_tac restore_rs)
               next
                 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> \<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. \<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 "\<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 .\<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 "\<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> \<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>  \<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> 
   \<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: "\<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> \<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_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_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_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_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_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>
      \<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)] 
      \<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> \<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 "\<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 "\<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> 
       \<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> \<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. \<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 "\<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)) 
         \<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 "\<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)] 
           \<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 
           "\<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
           \<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 "\<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 
               "\<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 "\<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>
             [Inc n, Dec (Suc n) 3, Goto (Suc 0)]
             \<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_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. \<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)]
    \<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>
          \<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. \<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. \<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 
     "\<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)])))
   \<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 "\<lbrace>?P\<rbrace> (?A [+] (?B [+] (?C [+] (?D [+] ?E @ ?F)))) \<lbrace>?S\<rbrace>"
   proof(rule_tac abc_Hoare_plus_halt)
     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 "\<lbrace>?Q1\<rbrace> (?B [+] (?C [+] (?D [+] ?E @ ?F))) \<lbrace>?S\<rbrace>"
     proof(rule_tac abc_Hoare_plus_halt)
       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 "\<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 "\<lbrace>?Q2\<rbrace> (?C [+] (?D [+] ?E @ ?F)) \<lbrace>?S\<rbrace>"
       proof(rule_tac abc_Hoare_plus_halt)
         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 "\<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. \<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> \<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 "\<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. \<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. \<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. \<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:
   "\<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. (\<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 "\<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_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. (\<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. \<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. \<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. (\<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. \<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 "\<lbrace>\<lambda>nl. nl = xs @ 0 \<up> (max (Suc arity) fft - arity) @ anything\<rbrace>
     fap @ B
     \<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 "\<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_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> 
   \<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. \<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 "\<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. \<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. (\<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> \<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)
   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 )
      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 "\<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 "\<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 "\<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. \<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> \<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 "\<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 "\<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: "\<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 "\<lbrace>?Q\<rbrace> gap \<up>"
       using a by simp
   next
     show "\<lbrace>\<lambda>nl. nl = args @ 0 # 0 \<up> (?ft + length gs) @ anything\<rbrace> 
       cn_merge_gs (map rec_ci (take i gs)) ?ft
        \<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 "\<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 "\<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 "\<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_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_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 "\<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 )
   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_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 "\<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_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), (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 )
 
 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_tm n)"
   apply(simp add: mopup_n_tm.simps)
   done
 
 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_tm n)) div 2"
   by(auto simp: mopup_n_tm.simps)
 
 subsection \<open>A Turing Machine compiled from an Abacus program 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_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] composable_tm.simps 
     by(auto simp: List.list_all_iff shift.simps)
 qed
 
 subsection \<open>A Turing Machine compiled from a recursive function is composable\<close>
 
 lemma composable_tm_from_recf:
   assumes compile: "tp = tm_of_rec recf"
   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 composable_tm_from_abacus[of "tm_of (a [+] dummy_abc b)" "(a [+] dummy_abc b)" b]
     by simp
 qed
 
 end
diff --git a/thys/Universal_Turing_Machine/StrongCopyTM.thy b/thys/Universal_Turing_Machine/StrongCopyTM.thy
--- a/thys/Universal_Turing_Machine/StrongCopyTM.thy
+++ b/thys/Universal_Turing_Machine/StrongCopyTM.thy
@@ -1,5696 +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)
+    by (smt (verit) 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)
+          by (smt (verit) 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)
+          by (smt (verit) 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)
+          by (smt (verit) 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)
+          by (smt (verit) 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)
+          by (smt (verit) 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)
+          by (smt (verit) 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
+    by (smt (verit)
         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))
+      by (smt (verit) 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)
+      by (smt (verit) 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))
+        by (smt (verit) 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
--- a/thys/Universal_Turing_Machine/TM_Playground.thy
+++ b/thys/Universal_Turing_Machine/TM_Playground.thy
@@ -1,97 +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>
+    by (smt (verit) 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/TuringComputable.thy b/thys/Universal_Turing_Machine/TuringComputable.thy
--- a/thys/Universal_Turing_Machine/TuringComputable.thy
+++ b/thys/Universal_Turing_Machine/TuringComputable.thy
@@ -1,699 +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)
+        by (smt (verit) 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)
+      by (smt (verit) 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
--- a/thys/Universal_Turing_Machine/TuringComputable_aux.thy
+++ b/thys/Universal_Turing_Machine/TuringComputable_aux.thy
@@ -1,158 +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)
+    by (smt (verit) 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/Turing_HaltingConditions.thy b/thys/Universal_Turing_Machine/Turing_HaltingConditions.thy
--- a/thys/Universal_Turing_Machine/Turing_HaltingConditions.thy
+++ b/thys/Universal_Turing_Machine/Turing_HaltingConditions.thy
@@ -1,594 +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))
+    using Hoare_halt_E0 is_finalI by force
 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)
+    by (smt (verit, best) Hoare_halt_E0 Hoare_halt_impl_not_Hoare_unhalt Hoare_unhalt_def is_finalI tape_of_list_def tape_of_nat_def)
 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)
+    using Hoare_halt_E0 is_finalI by force
 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)
+    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>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)
+    using F0 Hoare_haltI Hoare_halt_E0 Hoare_halt_iff by fastforce
 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)
+    using Hoare_halt_E0 Hoare_halt_iff by fastforce
 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)
+  by (smt (verit, ccfv_threshold) 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)
+  by (smt (verit, ccfv_threshold) Hoare_halt_E0 Hoare_halt_def 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/UTM.thy b/thys/Universal_Turing_Machine/UTM.thy
--- a/thys/Universal_Turing_Machine/UTM.thy
+++ b/thys/Universal_Turing_Machine/UTM.thy
@@ -1,4749 +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 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, 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>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>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$.
 
 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 \<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
 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 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},
         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 twice_compile_tm :: "instr list"
   where
     "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
     "twice_tm = adjust0 twice_compile_tm"
 
 definition fourtimes_compile_tm :: "instr list"
   where
     "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), (WB, 3), (R, 4), (R, 5),
                     (WO, 6), (R, 5), (R, 13), (L, 6),
                     (R, 0), (R, 8), (R, 9), (Nop, 8),
                     (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
     "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_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  simp:lex_pair_def)
 
 lemma wf_wcode_double_case_le[intro]: "wf wcode_double_case_le"
   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
+    apply (smt (verit) 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]
 
 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)) 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)) 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) wcode_main_tm of (st, x) \<Rightarrow> 
                    wcode_double_case_inv st ires rs x) \<and> 
                 (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)) 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 
 
 lemma twice_lemma: "rec_exec rec_twice [rs] = 2*rs"
   by(auto simp: rec_twice_def rec_exec.simps)
 
 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_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_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 
       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 
       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 "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 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
 
 
 lemma adjust_steps_eq: 
   assumes exec: "steps0 (st,l,r) ap stp = (st', l', r')"
     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)
     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 ) 
     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 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 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.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  , auto)
     apply(simp add: step.simps)
     done
 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 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_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 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_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 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: twice_compile_tm_def, auto)
     done
   then obtain stpb where 
     "steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
     (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: twice_tm_def twice_tm_len_def)
     by metis
 qed
 
 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 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 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 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_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 (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 (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))
      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 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)) 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) 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)) 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)) 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)) wcode_main_tm stpa = 
     (13, Bk # Bk # Bk\<up>(lna) @ Oc # ires, Oc\<up>(Suc (Suc rs)) @ Bk\<up>(rna))" by blast
   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)
                   (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)) 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: 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)) 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 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 + 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: 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 + 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 + 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 = 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 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 = 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)) wcode_main_tm stp) in
   \<exists> n .P (f n) \<and> Q (f (n::nat))"
 proof -
   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)) 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.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 fourtimes_tm_len :: "nat"
   where
     "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 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_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_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 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 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_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 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_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 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: fourtimes_compile_tm_def, auto)
     done
   then obtain stpb where 
     "steps0 (Suc 0, Bk # Bk # ires, Oc\<up>(Suc rs) @ Bk\<up>(n))
     (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: fourtimes_tm_def fourtimes_tm_len_def)
     by metis
 qed
 
 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))
      ((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_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 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 fourtimes_tm_append:
   "\<exists> stp ln rn. 
   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))
   ((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 fourtimes_tm_change_term_state[of ires rs n]
   apply(erule_tac exE)
   apply(erule_tac exE)
   apply(erule_tac exE)
   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: twice_tm_len_def)
   done
 
 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 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_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 wcode_main_tm_def)
    apply(simp add:length_twice_tm_even fourtimes_tm_len_def nth_append)
   by arith
 
 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 wcode_main_tm_def)
    apply(simp add:length_twice_tm_even fourtimes_tm_len_def nth_append)
   by arith
 
 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_wcode_tm_14_Bk fetch_wcode_tm_14_Oc)
   done
 
 lemma wcode_jump2: 
   "\<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)) 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)) 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)) 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: 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 (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 (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 wcode_jump2)
     done
   from this obtain stpc lnc rnc where stp3: 
     "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 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)) 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)) 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))
   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) 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)) 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 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)) 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)) 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)) 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) 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) 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) 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) 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)) 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)) 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)) 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)) 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)) 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, 
         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)) 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)) 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)) 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)) 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)) 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)) 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: 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)) 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)) 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)) 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)) 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)) 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)) 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)) 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: tape_of_nl_cons_app1 replicate_Suc)
           done
       qed
     qed
   qed
 qed
 
 definition wcode_prepare_tm :: "instr list"
   where
     "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),
           (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 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_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, 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>)) 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>)) 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 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 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 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 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: composable_tm.simps List.list_all_length adjust.simps split: if_splits prod.split)
 qed
 
 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: composable_tm.simps List.list_all_length shift.simps)
 qed
 
 declare length_tp'[simp del]
 
 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 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_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 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 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: 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 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: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 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_n_tm (Suc 0)) (length (tm_of abc_fourtimes) div 2))
                (Suc ((length (tm_of abc_fourtimes) + 16) div 2)))
              (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_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_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_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_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_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 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>) (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 " \<lbrace>?P1\<rbrace> wcode_prepare_tm |+| wcode_main_tm \<lbrace>?Q2\<rbrace>"
   proof(rule_tac Hoare_plus_halt)
     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>) 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 " \<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) 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) 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) 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) 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 "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) (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) (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 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 wcode_adjust_tm :: "instr list"
   where
     "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_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 simp: Abacus.lex_pair_def lex_square_def 
       Abacus.lex_triple_def)
 
 lemma wf_wadjust_le[intro]: "wf wadjust_le"
   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)) 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)) 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 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>) 
               ((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 "\<lbrace>?P1\<rbrace> (wcode_prepare_tm |+| wcode_main_tm) |+| wcode_adjust_tm \<lbrace>?Q2\<rbrace>"
   proof(rule_tac Hoare_plus_halt)
   next
     show "composable_tm (wcode_prepare_tm |+| wcode_main_tm, 0)"
       by(rule_tac seq_tm_composable, auto)
   next
     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>) (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>) (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 "\<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)
         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) 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) 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>) 
       ((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>wcode_tm\<close>.
 \<close>
 definition wcode_tm :: "instr list"
   where
     "wcode_tm = (wcode_prepare_tm |+| wcode_main_tm) |+| wcode_adjust_tm"
 
 text \<open>
   The correctness of \<open>wcode_tm\<close>.
 \<close>
 
 lemma wcode_lemma_1:
   "args \<noteq> [] \<Longrightarrow> 
   \<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' wcode_tm_def del: replicate_Suc)
   done
 
 lemma wcode_lemma: 
   "args \<noteq> [] \<Longrightarrow> 
   \<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: wcode_tm_def tape_of_list_def tape_of_nat_def)
   done
 
 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 
   correctness. It is pretty easy by composing the partial results we have got so far.
 \<close>
 
 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 
           let abc_F = aprog [+] dummy_abc (Suc (Suc 0)) in 
           (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 
                        aprog [+] dummy_abc (Suc (Suc 0)))"
 
 definition f_tprog_tm :: "instr list"
   where
     "f_tprog_tm = tm_of (f_aprog)"
 
 definition utm_with_two_args :: "instr list"
   where
     "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 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)) 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_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 = tm_of (ap [+] dummy_abc (length [code tp, bl2wc (<lm>)]))"
       using a
       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_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_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_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_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_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: utm_with_two_args_def)
     using assms
     apply(case_tac rs, simp_all add: numeral_2_eq_2)
     done
 qed
 
 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 "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_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 "\<lbrace>?P1\<rbrace> (wcode_tm |+| utm_with_two_args) \<lbrace>?Q2\<rbrace>"
   proof(rule_tac Hoare_plus_halt)
     show "composable_tm (wcode_tm, 0)" by auto
   next
     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 "\<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) 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) 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_tm_def)
     apply(case_tac "steps0 (Suc 0, [], <code tp # args>) (wcode_tm |+| utm_with_two_args) n",simp)
     by auto
 qed
 
 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 = 
                                                 (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_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>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>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:"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 "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 "\<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 "\<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 "\<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 "\<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 "\<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 "\<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>"
           apply(rule_tac recursive_compile_correct)
            apply(case_tac j, auto)
            apply(rule_tac [!] primerec_terminate)
           by(auto)
         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 "\<lbrace>\<lambda>nl. nl = code tp # bl2wc (<lm>) # 0 \<up> (ft2 - Suc (Suc 0)) @ anything\<rbrace> ap2 \<up>"
         by simp
     qed
     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>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> \<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, 
     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)" 
     "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>composable_tm (tp, 0); 
   \<forall> stp. (\<not> TSTD (steps0 (Suc 0, Bk\<up>(l), <lm>) tp stp))\<rbrakk>
   \<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:"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 "\<lbrace>\<lambda> nl. nl = [code tp, bl2wc (<lm>)]\<rbrace> f_aprog \<up>"
     by(simp add: f_aprog_def abc)
 qed
 
 lemma tutm_uhalt': 
   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>)]>) utm_with_two_args stp)"
   unfolding utm_with_two_args_def
 proof(rule_tac compile_correct_unhalt, auto)
   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>)]>)  []"
     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"
     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>)]>) 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)) 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>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)) 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 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_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 "\<lbrace>?P1\<rbrace> (wcode_tm |+| utm_with_two_args) \<up>"
   proof(rule_tac Hoare_plus_unhalt)
     show "composable_tm (wcode_tm, 0)" by auto
   next
     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 "\<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) 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_tm_def)
     done
 qed
 
 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_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 composable_tm: "composable_tm (p, 0)"
     and result: "rs > 0"
     and args: "(args::nat list) \<noteq> []"
     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 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:"\<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 "\<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 "\<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 "\<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 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) 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) 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) 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 "composable_tm0 wcode_tm" by auto
   qed
   then obtain n where
     "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 (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 (wcode_tm |+| utm_with_two_args) n)")
     apply(rule_tac x="n" in exI)
     apply(auto simp add:a utm_with_two_args_def f_aprog_def f_tprog_tm_def)
     done
 qed
 
 lemma utm_halt_lemma2:
   assumes composable_tm: "composable_tm (p, 0)"
     and args: "(args::nat list) \<noteq> []"
     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 composable_tm: "composable_tm (p, 0)"
     and unhalt: "\<lbrace>(\<lambda>tp. tp = (Bk\<up>i, <args>))\<rbrace> p \<up>"
     and args: "args \<noteq> []"
   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)
   thus "?thesis" by(simp add: Hoare_unhalt_def)
 qed
 
 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
diff --git a/thys/Universal_Turing_Machine/WeakCopyTM.thy b/thys/Universal_Turing_Machine/WeakCopyTM.thy
--- a/thys/Universal_Turing_Machine/WeakCopyTM.thy
+++ b/thys/Universal_Turing_Machine/WeakCopyTM.thy
@@ -1,1179 +1,1178 @@
 (* 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
+    by (smt (verit) 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))
+    by (smt (verit, del_insts) Hoare_halt_iff append_Nil2 empty_replicate replicate_Suc)
 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)
+    by (smt (verit) 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)
+    by (smt (verit) 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)
+    by (smt (verit) 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)
+        by (smt (verit) 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)
+          by (smt (verit) 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)
+          by (smt (verit) 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)
+        by (smt (verit) 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)
+          by (smt (verit) 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)
+          by (smt (verit) 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