Initial upload of the formal construction of Universal Turing Machine.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/utm/IsaMakefile Sat Sep 29 12:38:12 2012 +0000
@@ -0,0 +1,31 @@
+
+## targets
+
+default: utm
+images: utm
+test:
+
+all: images test
+
+
+## global settings
+
+SRC = $(ISABELLE_HOME)/src
+OUT = $(ISABELLE_OUTPUT)
+LOG = $(OUT)/log
+
+USEDIR = $(ISABELLE_TOOL) usedir -v true -i true -d pdf ## -D generated
+
+
+## utm
+
+utm: $(OUT)/utm
+
+$(OUT)/utm: ## ROOT.ML document/root.tex *.thy
+ @$(USEDIR) -b HOL utm
+
+
+## clean
+
+clean:
+ @rm -f $(OUT)/utm
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/utm/ROOT.ML Sat Sep 29 12:38:12 2012 +0000
@@ -0,0 +1,12 @@
+(*
+ turing_basic.thy : The basic definitions of Turing Machine.
+ uncomputable.thy : The existence of Turing uncomputable functions.
+ abacus.thy : The basic definitions of Abacus machine (An intermediate langauge underneath recursive functions) and
+ the compilation of Abacus machines into Turing Machines.
+ recursive.thy : The basic defintions of Recursive Functions and the compilation of Recursive Functions into
+ Abacus machines.
+ UF.thy : The construction of Universal Function, named "rec_F" and the proof of its correctness.
+ UTM.thy: Obtaining Uinversal Turing Machine by scarfolding the Turing Machine compiled from "rec_F" with some
+ initialization and termination processing Turing Machines.
+*)
+ no_document use_thys ["turing_basic", "uncomputable", "abacus", "recursive", "UF", "UTM"]
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/utm/UF.thy Sat Sep 29 12:38:12 2012 +0000
@@ -0,0 +1,4914 @@
+theory UF
+imports Main rec_def turing_basic GCD abacus
+begin
+
+text {*
+ This theory file constructs the Universal Function @{text "rec_F"}, which is the UTM defined
+ in terms of recursive functions. This @{text "rec_F"} is essentially an
+ interpreter of Turing Machines. Once the correctness of @{text "rec_F"} is established,
+ UTM can easil be obtained by compling @{text "rec_F"} into the corresponding Turing Machine.
+*}
+
+
+section {* The construction of component functions *}
+
+text {*
+ This section constructs a set of component functions used to construct @{text "rec_F"}.
+ *}
+
+text {*
+ The recursive function used to do arithmatic addition.
+*}
+definition rec_add :: "recf"
+ where
+ "rec_add \<equiv> Pr 1 (id 1 0) (Cn 3 s [id 3 2])"
+
+text {*
+ The recursive function used to do arithmatic multiplication.
+*}
+definition rec_mult :: "recf"
+ where
+ "rec_mult = Pr 1 z (Cn 3 rec_add [id 3 0, id 3 2])"
+
+text {*
+ The recursive function used to do arithmatic precede.
+*}
+definition rec_pred :: "recf"
+ where
+ "rec_pred = Cn 1 (Pr 1 z (id 3 1)) [id 1 0, id 1 0]"
+
+text {*
+ The recursive function used to do arithmatic subtraction.
+*}
+definition rec_minus :: "recf"
+ where
+ "rec_minus = Pr 1 (id 1 0) (Cn 3 rec_pred [id 3 2])"
+
+text {*
+ @{text "constn n"} is the recursive function which computes
+ nature number @{text "n"}.
+*}
+fun constn :: "nat \<Rightarrow> recf"
+ where
+ "constn 0 = z" |
+ "constn (Suc n) = Cn 1 s [constn n]"
+
+
+text {*
+ Signal function, which returns 1 when the input argument is greater than @{text "0"}.
+*}
+definition rec_sg :: "recf"
+ where
+ "rec_sg = Cn 1 rec_minus [constn 1,
+ Cn 1 rec_minus [constn 1, id 1 0]]"
+
+text {*
+ @{text "rec_less"} compares its two arguments, returns @{text "1"} if
+ the first is less than the second; otherwise returns @{text "0"}.
+ *}
+definition rec_less :: "recf"
+ where
+ "rec_less = Cn 2 rec_sg [Cn 2 rec_minus [id 2 1, id 2 0]]"
+
+text {*
+ @{text "rec_not"} inverse its argument: returns @{text "1"} when the
+ argument is @{text "0"}; returns @{text "0"} otherwise.
+ *}
+definition rec_not :: "recf"
+ where
+ "rec_not = Cn 1 rec_minus [constn 1, id 1 0]"
+
+text {*
+ @{text "rec_eq"} compares its two arguments: returns @{text "1"}
+ if they are equal; return @{text "0"} otherwise.
+ *}
+definition rec_eq :: "recf"
+ where
+ "rec_eq = Cn 2 rec_minus [Cn 2 (constn 1) [id 2 0],
+ Cn 2 rec_add [Cn 2 rec_minus [id 2 0, id 2 1],
+ Cn 2 rec_minus [id 2 1, id 2 0]]]"
+
+text {*
+ @{text "rec_conj"} computes the conjunction of its two arguments,
+ returns @{text "1"} if both of them are non-zero; returns @{text "0"}
+ otherwise.
+ *}
+definition rec_conj :: "recf"
+ where
+ "rec_conj = Cn 2 rec_sg [Cn 2 rec_mult [id 2 0, id 2 1]] "
+
+text {*
+ @{text "rec_disj"} computes the disjunction of its two arguments,
+ returns @{text "0"} if both of them are zero; returns @{text "0"}
+ otherwise.
+ *}
+definition rec_disj :: "recf"
+ where
+ "rec_disj = Cn 2 rec_sg [Cn 2 rec_add [id 2 0, id 2 1]]"
+
+
+text {*
+ Computes the arity of recursive function.
+ *}
+
+fun arity :: "recf \<Rightarrow> nat"
+ where
+ "arity z = 1"
+| "arity s = 1"
+| "arity (id m n) = m"
+| "arity (Cn n f gs) = n"
+| "arity (Pr n f g) = Suc n"
+| "arity (Mn n f) = n"
+
+text {*
+ @{text "get_fstn_args n (Suc k)"} returns
+ @{text "[id n 0, id n 1, id n 2, \<dots>, id n k]"},
+ the effect of which is to take out the first @{text "Suc k"}
+ arguments out of the @{text "n"} input arguments.
+ *}
+(* get_fstn_args *)
+fun get_fstn_args :: "nat \<Rightarrow> nat \<Rightarrow> recf list"
+ where
+ "get_fstn_args n 0 = []"
+| "get_fstn_args n (Suc y) = get_fstn_args n y @ [id n y]"
+
+text {*
+ @{text "rec_sigma f"} returns the recursive functions which
+ sums up the results of @{text "f"}:
+ \[
+ (rec\_sigma f)(x, y) = f(x, 0) + f(x, 1) + \cdots + f(x, y)
+ \]
+*}
+fun rec_sigma :: "recf \<Rightarrow> recf"
+ where
+ "rec_sigma rf =
+ (let vl = arity rf in
+ Pr (vl - 1) (Cn (vl - 1) rf (get_fstn_args (vl - 1) (vl - 1) @
+ [Cn (vl - 1) (constn 0) [id (vl - 1) 0]]))
+ (Cn (Suc vl) rec_add [id (Suc vl) vl,
+ Cn (Suc vl) rf (get_fstn_args (Suc vl) (vl - 1)
+ @ [Cn (Suc vl) s [id (Suc vl) (vl - 1)]])]))"
+
+text {*
+ @{text "rec_exec"} is the interpreter function for
+ reursive functions. The function is defined such that
+ it always returns meaningful results for primitive recursive
+ functions.
+ *}
+function rec_exec :: "recf \<Rightarrow> nat list \<Rightarrow> nat"
+ where
+ "rec_exec z xs = 0" |
+ "rec_exec s xs = (Suc (xs ! 0))" |
+ "rec_exec (id m n) xs = (xs ! n)" |
+ "rec_exec (Cn n f gs) xs =
+ (let ys = (map (\<lambda> a. rec_exec a xs) gs) in
+ rec_exec f ys)" |
+ "rec_exec (Pr n f g) xs =
+ (if last xs = 0 then
+ rec_exec f (butlast xs)
+ else rec_exec g (butlast xs @ [last xs - 1] @
+ [rec_exec (Pr n f g) (butlast xs @ [last xs - 1])]))" |
+ "rec_exec (Mn n f) xs = (LEAST x. rec_exec f (xs @ [x]) = 0)"
+by pat_completeness auto
+termination
+proof
+ show "wf (measures [\<lambda> (r, xs). size r, (\<lambda> (r, xs). last xs)])"
+ by auto
+next
+ fix n f gs xs x
+ assume "(x::recf) \<in> set gs"
+ thus "((x, xs), Cn n f gs, xs) \<in>
+ measures [\<lambda>(r, xs). size r, \<lambda>(r, xs). last xs]"
+ by(induct gs, auto)
+next
+ fix n f gs xs x
+ assume "x = map (\<lambda>a. rec_exec a xs) gs"
+ "\<And>x. x \<in> set gs \<Longrightarrow> rec_exec_dom (x, xs)"
+ thus "((f, x), Cn n f gs, xs) \<in>
+ measures [\<lambda>(r, xs). size r, \<lambda>(r, xs). last xs]"
+ by(auto)
+next
+ fix n f g xs
+ show "((f, butlast xs), Pr n f g, xs) \<in>
+ measures [\<lambda>(r, xs). size r, \<lambda>(r, xs). last xs]"
+ by auto
+next
+ fix n f g xs
+ assume "last xs \<noteq> (0::nat)" thus
+ "((Pr n f g, butlast xs @ [last xs - 1]), Pr n f g, xs)
+ \<in> measures [\<lambda>(r, xs). size r, \<lambda>(r, xs). last xs]"
+ by auto
+next
+ fix n f g xs
+ show "((g, butlast xs @ [last xs - 1] @ [rec_exec (Pr n f g) (butlast xs @ [last xs - 1])]),
+ Pr n f g, xs) \<in> measures [\<lambda>(r, xs). size r, \<lambda>(r, xs). last xs]"
+ by auto
+next
+ fix n f xs x
+ show "((f, xs @ [x]), Mn n f, xs) \<in>
+ measures [\<lambda>(r, xs). size r, \<lambda>(r, xs). last xs]"
+ by auto
+qed
+
+declare rec_exec.simps[simp del] constn.simps[simp del]
+
+text {*
+ Correctness of @{text "rec_add"}.
+ *}
+lemma add_lemma: "\<And> x y. rec_exec rec_add [x, y] = x + y"
+by(induct_tac y, auto simp: rec_add_def rec_exec.simps)
+
+text {*
+ Correctness of @{text "rec_mult"}.
+ *}
+lemma mult_lemma: "\<And> x y. rec_exec rec_mult [x, y] = x * y"
+by(induct_tac y, auto simp: rec_mult_def rec_exec.simps add_lemma)
+
+text {*
+ Correctness of @{text "rec_pred"}.
+ *}
+lemma pred_lemma: "\<And> x. rec_exec rec_pred [x] = x - 1"
+by(induct_tac x, auto simp: rec_pred_def rec_exec.simps)
+
+text {*
+ Correctness of @{text "rec_minus"}.
+ *}
+lemma minus_lemma: "\<And> x y. rec_exec rec_minus [x, y] = x - y"
+by(induct_tac y, auto simp: rec_exec.simps rec_minus_def pred_lemma)
+
+text {*
+ Correctness of @{text "rec_sg"}.
+ *}
+lemma sg_lemma: "\<And> x. rec_exec rec_sg [x] = (if x = 0 then 0 else 1)"
+by(auto simp: rec_sg_def minus_lemma rec_exec.simps constn.simps)
+
+text {*
+ Correctness of @{text "constn"}.
+ *}
+lemma constn_lemma: "rec_exec (constn n) [x] = n"
+by(induct n, auto simp: rec_exec.simps constn.simps)
+
+text {*
+ Correctness of @{text "rec_less"}.
+ *}
+lemma less_lemma: "\<And> x y. rec_exec rec_less [x, y] =
+ (if x < y then 1 else 0)"
+by(induct_tac y, auto simp: rec_exec.simps
+ rec_less_def minus_lemma sg_lemma)
+
+text {*
+ Correctness of @{text "rec_not"}.
+ *}
+lemma not_lemma:
+ "\<And> x. rec_exec rec_not [x] = (if x = 0 then 1 else 0)"
+by(induct_tac x, auto simp: rec_exec.simps rec_not_def
+ constn_lemma minus_lemma)
+
+text {*
+ Correctness of @{text "rec_eq"}.
+ *}
+lemma eq_lemma: "\<And> x y. rec_exec rec_eq [x, y] = (if x = y then 1 else 0)"
+by(induct_tac y, auto simp: rec_exec.simps rec_eq_def constn_lemma add_lemma minus_lemma)
+
+text {*
+ Correctness of @{text "rec_conj"}.
+ *}
+lemma conj_lemma: "\<And> x y. rec_exec rec_conj [x, y] = (if x = 0 \<or> y = 0 then 0
+ else 1)"
+by(induct_tac y, auto simp: rec_exec.simps sg_lemma rec_conj_def mult_lemma)
+
+
+text {*
+ Correctness of @{text "rec_disj"}.
+ *}
+lemma disj_lemma: "\<And> x y. rec_exec rec_disj [x, y] = (if x = 0 \<and> y = 0 then 0
+ else 1)"
+by(induct_tac y, auto simp: rec_disj_def sg_lemma add_lemma rec_exec.simps)
+
+
+text {*
+ @{text "primrec recf n"} is true iff
+ @{text "recf"} is a primitive recursive function
+ with arity @{text "n"}.
+ *}
+inductive primerec :: "recf \<Rightarrow> nat \<Rightarrow> bool"
+ where
+prime_z[intro]: "primerec z (Suc 0)" |
+prime_s[intro]: "primerec s (Suc 0)" |
+prime_id[intro!]: "\<lbrakk>n < m\<rbrakk> \<Longrightarrow> primerec (id m n) m" |
+prime_cn[intro!]: "\<lbrakk>primerec f k; length gs = k;
+ \<forall> i < length gs. primerec (gs ! i) m; m = n\<rbrakk>
+ \<Longrightarrow> primerec (Cn n f gs) m" |
+prime_pr[intro!]: "\<lbrakk>primerec f n;
+ primerec g (Suc (Suc n)); m = Suc n\<rbrakk>
+ \<Longrightarrow> primerec (Pr n f g) m"
+
+inductive_cases prime_cn_reverse'[elim]: "primerec (Cn n f gs) n"
+inductive_cases prime_mn_reverse: "primerec (Mn n f) m"
+inductive_cases prime_z_reverse[elim]: "primerec z n"
+inductive_cases prime_s_reverse[elim]: "primerec s n"
+inductive_cases prime_id_reverse[elim]: "primerec (id m n) k"
+inductive_cases prime_cn_reverse[elim]: "primerec (Cn n f gs) m"
+inductive_cases prime_pr_reverse[elim]: "primerec (Pr n f g) m"
+
+declare mult_lemma[simp] add_lemma[simp] pred_lemma[simp]
+ minus_lemma[simp] sg_lemma[simp] constn_lemma[simp]
+ less_lemma[simp] not_lemma[simp] eq_lemma[simp]
+ conj_lemma[simp] disj_lemma[simp]
+
+text {*
+ @{text "Sigma"} is the logical specification of
+ the recursive function @{text "rec_sigma"}.
+ *}
+function Sigma :: "(nat list \<Rightarrow> nat) \<Rightarrow> nat list \<Rightarrow> nat"
+ where
+ "Sigma g xs = (if last xs = 0 then g xs
+ else (Sigma g (butlast xs @ [last xs - 1]) +
+ g xs)) "
+by pat_completeness auto
+termination
+proof
+ show "wf (measure (\<lambda> (f, xs). last xs))" by auto
+next
+ fix g xs
+ assume "last (xs::nat list) \<noteq> 0"
+ thus "((g, butlast xs @ [last xs - 1]), g, xs)
+ \<in> measure (\<lambda>(f, xs). last xs)"
+ by auto
+qed
+
+declare rec_exec.simps[simp del] get_fstn_args.simps[simp del]
+ arity.simps[simp del] Sigma.simps[simp del]
+ rec_sigma.simps[simp del]
+
+
+section {* Properties of @{text rec_sigma} *}
+
+lemma [simp]: "arity z = 1"
+ by(simp add: arity.simps)
+
+lemma rec_pr_0_simp_rewrite: "
+ rec_exec (Pr n f g) (xs @ [0]) = rec_exec f xs"
+by(simp add: rec_exec.simps)
+
+lemma rec_pr_0_simp_rewrite_single_param: "
+ rec_exec (Pr n f g) [0] = rec_exec f []"
+by(simp add: rec_exec.simps)
+
+lemma rec_pr_Suc_simp_rewrite:
+ "rec_exec (Pr n f g) (xs @ [Suc x]) =
+ rec_exec g (xs @ [x] @
+ [rec_exec (Pr n f g) (xs @ [x])])"
+by(simp add: rec_exec.simps)
+
+lemma rec_pr_Suc_simp_rewrite_single_param:
+ "rec_exec (Pr n f g) ([Suc x]) =
+ rec_exec g ([x] @ [rec_exec (Pr n f g) ([x])])"
+by(simp add: rec_exec.simps)
+
+thm Sigma.simps
+
+lemma Sigma_0_simp_rewrite_single_param:
+ "Sigma f [0] = f [0]"
+by(simp add: Sigma.simps)
+
+lemma Sigma_0_simp_rewrite:
+ "Sigma f (xs @ [0]) = f (xs @ [0])"
+by(simp add: Sigma.simps)
+
+lemma Sigma_Suc_simp_rewrite:
+ "Sigma f (xs @ [Suc x]) = Sigma f (xs @ [x]) + f (xs @ [Suc x])"
+by(simp add: Sigma.simps)
+
+lemma Sigma_Suc_simp_rewrite_single:
+ "Sigma f ([Suc x]) = Sigma f ([x]) + f ([Suc x])"
+by(simp add: Sigma.simps)
+
+lemma [simp]: "(xs @ ys) ! (Suc (length xs)) = ys ! 1"
+by(simp add: nth_append)
+
+lemma get_fstn_args_take: "\<lbrakk>length xs = m; n \<le> m\<rbrakk> \<Longrightarrow>
+ map (\<lambda> f. rec_exec f xs) (get_fstn_args m n)= take n xs"
+proof(induct n)
+ case 0 thus "?case"
+ by(simp add: get_fstn_args.simps)
+next
+ case (Suc n) thus "?case"
+ by(simp add: get_fstn_args.simps rec_exec.simps
+ take_Suc_conv_app_nth)
+qed
+
+lemma [simp]: "primerec f n \<Longrightarrow> arity f = n"
+ apply(case_tac f)
+ apply(auto simp: arity.simps )
+ apply(erule_tac prime_mn_reverse)
+ done
+
+lemma rec_sigma_Suc_simp_rewrite:
+ "primerec f (Suc (length xs))
+ \<Longrightarrow> rec_exec (rec_sigma f) (xs @ [Suc x]) =
+ rec_exec (rec_sigma f) (xs @ [x]) + rec_exec f (xs @ [Suc x])"
+ apply(induct x)
+ apply(auto simp: rec_sigma.simps Let_def rec_pr_Suc_simp_rewrite
+ rec_exec.simps get_fstn_args_take)
+ done
+
+text {*
+ The correctness of @{text "rec_sigma"} with respect to its specification.
+ *}
+lemma sigma_lemma:
+ "primerec rg (Suc (length xs))
+ \<Longrightarrow> rec_exec (rec_sigma rg) (xs @ [x]) = Sigma (rec_exec rg) (xs @ [x])"
+apply(induct x)
+apply(auto simp: rec_exec.simps rec_sigma.simps Let_def
+ get_fstn_args_take Sigma_0_simp_rewrite
+ Sigma_Suc_simp_rewrite)
+done
+
+text {*
+ @{text "rec_accum f (x1, x2, \<dots>, xn, k) =
+ f(x1, x2, \<dots>, xn, 0) *
+ f(x1, x2, \<dots>, xn, 1) *
+ \<dots>
+ f(x1, x2, \<dots>, xn, k)"}
+*}
+fun rec_accum :: "recf \<Rightarrow> recf"
+ where
+ "rec_accum rf =
+ (let vl = arity rf in
+ Pr (vl - 1) (Cn (vl - 1) rf (get_fstn_args (vl - 1) (vl - 1) @
+ [Cn (vl - 1) (constn 0) [id (vl - 1) 0]]))
+ (Cn (Suc vl) rec_mult [id (Suc vl) (vl),
+ Cn (Suc vl) rf (get_fstn_args (Suc vl) (vl - 1)
+ @ [Cn (Suc vl) s [id (Suc vl) (vl - 1)]])]))"
+
+text {*
+ @{text "Accum"} is the formal specification of @{text "rec_accum"}.
+ *}
+function Accum :: "(nat list \<Rightarrow> nat) \<Rightarrow> nat list \<Rightarrow> nat"
+ where
+ "Accum f xs = (if last xs = 0 then f xs
+ else (Accum f (butlast xs @ [last xs - 1]) *
+ f xs))"
+by pat_completeness auto
+termination
+proof
+ show "wf (measure (\<lambda> (f, xs). last xs))"
+ by auto
+next
+ fix f xs
+ assume "last xs \<noteq> (0::nat)"
+ thus "((f, butlast xs @ [last xs - 1]), f, xs) \<in>
+ measure (\<lambda>(f, xs). last xs)"
+ by auto
+qed
+
+lemma rec_accum_Suc_simp_rewrite:
+ "primerec f (Suc (length xs))
+ \<Longrightarrow> rec_exec (rec_accum f) (xs @ [Suc x]) =
+ rec_exec (rec_accum f) (xs @ [x]) * rec_exec f (xs @ [Suc x])"
+ apply(induct x)
+ apply(auto simp: rec_sigma.simps Let_def rec_pr_Suc_simp_rewrite
+ rec_exec.simps get_fstn_args_take)
+ done
+
+text {*
+ The correctness of @{text "rec_accum"} with respect to its specification.
+*}
+lemma accum_lemma :
+ "primerec rg (Suc (length xs))
+ \<Longrightarrow> rec_exec (rec_accum rg) (xs @ [x]) = Accum (rec_exec rg) (xs @ [x])"
+apply(induct x)
+apply(auto simp: rec_exec.simps rec_sigma.simps Let_def
+ get_fstn_args_take)
+done
+
+declare rec_accum.simps [simp del]
+
+text {*
+ @{text "rec_all t f (x1, x2, \<dots>, xn)"}
+ computes the charactrization function of the following FOL formula:
+ @{text "(\<forall> x \<le> t(x1, x2, \<dots>, xn). (f(x1, x2, \<dots>, xn, x) > 0))"}
+*}
+fun rec_all :: "recf \<Rightarrow> recf \<Rightarrow> recf"
+ where
+ "rec_all rt rf =
+ (let vl = arity rf in
+ Cn (vl - 1) rec_sg [Cn (vl - 1) (rec_accum rf)
+ (get_fstn_args (vl - 1) (vl - 1) @ [rt])])"
+
+lemma rec_accum_ex: "primerec rf (Suc (length xs)) \<Longrightarrow>
+ (rec_exec (rec_accum rf) (xs @ [x]) = 0) =
+ (\<exists> t \<le> x. rec_exec rf (xs @ [t]) = 0)"
+apply(induct x, simp_all add: rec_accum_Suc_simp_rewrite)
+apply(simp add: rec_exec.simps rec_accum.simps get_fstn_args_take,
+ auto)
+apply(rule_tac x = ta in exI, simp)
+apply(case_tac "t = Suc x", simp_all)
+apply(rule_tac x = t in exI, simp)
+done
+
+text {*
+ The correctness of @{text "rec_all"}.
+ *}
+lemma all_lemma:
+ "\<lbrakk>primerec rf (Suc (length xs));
+ primerec rt (length xs)\<rbrakk>
+ \<Longrightarrow> rec_exec (rec_all rt rf) xs = (if (\<forall> x \<le> (rec_exec rt xs). 0 < rec_exec rf (xs @ [x])) then 1
+ else 0)"
+apply(auto simp: rec_all.simps)
+apply(simp add: rec_exec.simps map_append get_fstn_args_take split: if_splits)
+apply(drule_tac x = "rec_exec rt xs" in rec_accum_ex)
+apply(case_tac "rec_exec (rec_accum rf) (xs @ [rec_exec rt xs]) = 0", simp_all)
+apply(erule_tac exE, erule_tac x = t in allE, simp)
+apply(simp add: rec_exec.simps map_append get_fstn_args_take)
+apply(drule_tac x = "rec_exec rt xs" in rec_accum_ex)
+apply(case_tac "rec_exec (rec_accum rf) (xs @ [rec_exec rt xs]) = 0", simp, simp)
+apply(erule_tac x = x in allE, simp)
+done
+
+text {*
+ @{text "rec_ex t f (x1, x2, \<dots>, xn)"}
+ computes the charactrization function of the following FOL formula:
+ @{text "(\<exists> x \<le> t(x1, x2, \<dots>, xn). (f(x1, x2, \<dots>, xn, x) > 0))"}
+*}
+fun rec_ex :: "recf \<Rightarrow> recf \<Rightarrow> recf"
+ where
+ "rec_ex rt rf =
+ (let vl = arity rf in
+ Cn (vl - 1) rec_sg [Cn (vl - 1) (rec_sigma rf)
+ (get_fstn_args (vl - 1) (vl - 1) @ [rt])])"
+
+lemma rec_sigma_ex: "primerec rf (Suc (length xs))
+ \<Longrightarrow> (rec_exec (rec_sigma rf) (xs @ [x]) = 0) =
+ (\<forall> t \<le> x. rec_exec rf (xs @ [t]) = 0)"
+apply(induct x, simp_all add: rec_sigma_Suc_simp_rewrite)
+apply(simp add: rec_exec.simps rec_sigma.simps
+ get_fstn_args_take, auto)
+apply(case_tac "t = Suc x", simp_all)
+done
+
+text {*
+ The correctness of @{text "ex_lemma"}.
+ *}
+lemma ex_lemma:"
+ \<lbrakk>primerec rf (Suc (length xs));
+ primerec rt (length xs)\<rbrakk>
+\<Longrightarrow> (rec_exec (rec_ex rt rf) xs =
+ (if (\<exists> x \<le> (rec_exec rt xs). 0 <rec_exec rf (xs @ [x])) then 1
+ else 0))"
+apply(auto simp: rec_ex.simps rec_exec.simps map_append get_fstn_args_take
+ split: if_splits)
+apply(drule_tac x = "rec_exec rt xs" in rec_sigma_ex, simp)
+apply(drule_tac x = "rec_exec rt xs" in rec_sigma_ex, simp)
+done
+
+text {*
+ Defintiion of @{text "Min[R]"} on page 77 of Boolos's book.
+*}
+
+fun Minr :: "(nat list \<Rightarrow> bool) \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat"
+ where "Minr Rr xs w = (let setx = {y | y. (y \<le> w) \<and> Rr (xs @ [y])} in
+ if (setx = {}) then (Suc w)
+ else (Min setx))"
+
+declare Minr.simps[simp del] rec_all.simps[simp del]
+
+text {*
+ The following is a set of auxilliary lemmas about @{text "Minr"}.
+*}
+lemma Minr_range: "Minr Rr xs w \<le> w \<or> Minr Rr xs w = Suc w"
+apply(auto simp: Minr.simps)
+apply(subgoal_tac "Min {x. x \<le> w \<and> Rr (xs @ [x])} \<le> x")
+apply(erule_tac order_trans, simp)
+apply(rule_tac Min_le, auto)
+done
+
+lemma [simp]: "{x. x \<le> Suc w \<and> Rr (xs @ [x])}
+ = (if Rr (xs @ [Suc w]) then insert (Suc w)
+ {x. x \<le> w \<and> Rr (xs @ [x])}
+ else {x. x \<le> w \<and> Rr (xs @ [x])})"
+by(auto, case_tac "x = Suc w", auto)
+
+lemma [simp]: "Minr Rr xs w \<le> w \<Longrightarrow> Minr Rr xs (Suc w) = Minr Rr xs w"
+apply(simp add: Minr.simps, auto)
+apply(case_tac "\<forall>x\<le>w. \<not> Rr (xs @ [x])", auto)
+done
+
+lemma [simp]: "\<forall>x\<le>w. \<not> Rr (xs @ [x]) \<Longrightarrow>
+ {x. x \<le> w \<and> Rr (xs @ [x])} = {} "
+by auto
+
+lemma [simp]: "\<lbrakk>Minr Rr xs w = Suc w; Rr (xs @ [Suc w])\<rbrakk> \<Longrightarrow>
+ Minr Rr xs (Suc w) = Suc w"
+apply(simp add: Minr.simps)
+apply(case_tac "\<forall>x\<le>w. \<not> Rr (xs @ [x])", auto)
+done
+
+lemma [simp]: "\<lbrakk>Minr Rr xs w = Suc w; \<not> Rr (xs @ [Suc w])\<rbrakk> \<Longrightarrow>
+ Minr Rr xs (Suc w) = Suc (Suc w)"
+apply(simp add: Minr.simps)
+apply(case_tac "\<forall>x\<le>w. \<not> Rr (xs @ [x])", auto)
+apply(subgoal_tac "Min {x. x \<le> w \<and> Rr (xs @ [x])} \<in>
+ {x. x \<le> w \<and> Rr (xs @ [x])}", simp)
+apply(rule_tac Min_in, auto)
+done
+
+lemma Minr_Suc_simp:
+ "Minr Rr xs (Suc w) =
+ (if Minr Rr xs w \<le> w then Minr Rr xs w
+ else if (Rr (xs @ [Suc w])) then (Suc w)
+ else Suc (Suc w))"
+by(insert Minr_range[of Rr xs w], auto)
+
+text {*
+ @{text "rec_Minr"} is the recursive function
+ used to implement @{text "Minr"}:
+ if @{text "Rr"} is implemented by a recursive function @{text "recf"},
+ then @{text "rec_Minr recf"} is the recursive function used to
+ implement @{text "Minr Rr"}
+ *}
+fun rec_Minr :: "recf \<Rightarrow> recf"
+ where
+ "rec_Minr rf =
+ (let vl = arity rf
+ in let rq = rec_all (id vl (vl - 1)) (Cn (Suc vl)
+ rec_not [Cn (Suc vl) rf
+ (get_fstn_args (Suc vl) (vl - 1) @
+ [id (Suc vl) (vl)])])
+ in rec_sigma rq)"
+
+lemma length_getpren_params[simp]: "length (get_fstn_args m n) = n"
+by(induct n, auto simp: get_fstn_args.simps)
+
+lemma length_app:
+ "(length (get_fstn_args (arity rf - Suc 0)
+ (arity rf - Suc 0)
+ @ [Cn (arity rf - Suc 0) (constn 0)
+ [recf.id (arity rf - Suc 0) 0]]))
+ = (Suc (arity rf - Suc 0))"
+ apply(simp)
+done
+
+lemma primerec_accum: "primerec (rec_accum rf) n \<Longrightarrow> primerec rf n"
+apply(auto simp: rec_accum.simps Let_def)
+apply(erule_tac prime_pr_reverse, simp)
+apply(erule_tac prime_cn_reverse, simp only: length_app)
+done
+
+lemma primerec_all: "primerec (rec_all rt rf) n \<Longrightarrow>
+ primerec rt n \<and> primerec rf (Suc n)"
+apply(simp add: rec_all.simps Let_def)
+apply(erule_tac prime_cn_reverse, simp)
+apply(erule_tac prime_cn_reverse, simp)
+apply(erule_tac x = n in allE, simp add: nth_append primerec_accum)
+done
+
+lemma min_Suc_Suc[simp]: "min (Suc (Suc x)) x = x"
+ by auto
+
+declare numeral_3_eq_3[simp]
+
+lemma [intro]: "primerec rec_pred (Suc 0)"
+apply(simp add: rec_pred_def)
+apply(rule_tac prime_cn, auto)
+apply(case_tac i, auto intro: prime_id)
+done
+
+lemma [intro]: "primerec rec_minus (Suc (Suc 0))"
+ apply(auto simp: rec_minus_def)
+ done
+
+lemma [intro]: "primerec (constn n) (Suc 0)"
+ apply(induct n)
+ apply(auto simp: constn.simps intro: prime_z prime_cn prime_s)
+ done
+
+lemma [intro]: "primerec rec_sg (Suc 0)"
+ apply(simp add: rec_sg_def)
+ apply(rule_tac k = "Suc (Suc 0)" in prime_cn, auto)
+ apply(case_tac i, auto)
+ apply(case_tac ia, auto intro: prime_id)
+ done
+
+lemma [simp]: "length (get_fstn_args m n) = n"
+ apply(induct n)
+ apply(auto simp: get_fstn_args.simps)
+ done
+
+lemma primerec_getpren[elim]: "\<lbrakk>i < n; n \<le> m\<rbrakk> \<Longrightarrow> primerec (get_fstn_args m n ! i) m"
+apply(induct n, auto simp: get_fstn_args.simps)
+apply(case_tac "i = n", auto simp: nth_append intro: prime_id)
+done
+
+lemma [intro]: "primerec rec_add (Suc (Suc 0))"
+apply(simp add: rec_add_def)
+apply(rule_tac prime_pr, auto)
+done
+
+lemma [intro]:"primerec rec_mult (Suc (Suc 0))"
+apply(simp add: rec_mult_def )
+apply(rule_tac prime_pr, auto intro: prime_z)
+apply(case_tac i, auto intro: prime_id)
+done
+
+lemma [elim]: "\<lbrakk>primerec rf n; n \<ge> Suc (Suc 0)\<rbrakk> \<Longrightarrow>
+ primerec (rec_accum rf) n"
+apply(auto simp: rec_accum.simps)
+apply(simp add: nth_append, auto)
+apply(case_tac i, auto intro: prime_id)
+apply(auto simp: nth_append)
+done
+
+lemma primerec_all_iff:
+ "\<lbrakk>primerec rt n; primerec rf (Suc n); n > 0\<rbrakk> \<Longrightarrow>
+ primerec (rec_all rt rf) n"
+ apply(simp add: rec_all.simps, auto)
+ apply(auto, simp add: nth_append, auto)
+ done
+
+lemma [simp]: "Rr (xs @ [0]) \<Longrightarrow>
+ Min {x. x = (0::nat) \<and> Rr (xs @ [x])} = 0"
+by(rule_tac Min_eqI, simp, simp, simp)
+
+lemma [intro]: "primerec rec_not (Suc 0)"
+apply(simp add: rec_not_def)
+apply(rule prime_cn, auto)
+apply(case_tac i, auto intro: prime_id)
+done
+
+lemma Min_false1[simp]: "\<lbrakk>\<not> Min {uu. uu \<le> w \<and> 0 < rec_exec rf (xs @ [uu])} \<le> w;
+ x \<le> w; 0 < rec_exec rf (xs @ [x])\<rbrakk>
+ \<Longrightarrow> False"
+apply(subgoal_tac "finite {uu. uu \<le> w \<and> 0 < rec_exec rf (xs @ [uu])}")
+apply(subgoal_tac "{uu. uu \<le> w \<and> 0 < rec_exec rf (xs @ [uu])} \<noteq> {}")
+apply(simp add: Min_le_iff, simp)
+apply(rule_tac x = x in exI, simp)
+apply(simp)
+done
+
+lemma sigma_minr_lemma:
+ assumes prrf: "primerec rf (Suc (length xs))"
+ shows "UF.Sigma (rec_exec (rec_all (recf.id (Suc (length xs)) (length xs))
+ (Cn (Suc (Suc (length xs))) rec_not
+ [Cn (Suc (Suc (length xs))) rf (get_fstn_args (Suc (Suc (length xs)))
+ (length xs) @ [recf.id (Suc (Suc (length xs))) (Suc (length xs))])])))
+ (xs @ [w]) =
+ Minr (\<lambda>args. 0 < rec_exec rf args) xs w"
+proof(induct w)
+ let ?rt = "(recf.id (Suc (length xs)) ((length xs)))"
+ let ?rf = "(Cn (Suc (Suc (length xs)))
+ rec_not [Cn (Suc (Suc (length xs))) rf
+ (get_fstn_args (Suc (Suc (length xs))) (length xs) @
+ [recf.id (Suc (Suc (length xs)))
+ (Suc ((length xs)))])])"
+ let ?rq = "(rec_all ?rt ?rf)"
+ have prrf: "primerec ?rf (Suc (length (xs @ [0]))) \<and>
+ primerec ?rt (length (xs @ [0]))"
+ apply(auto simp: prrf nth_append)+
+ done
+ show "Sigma (rec_exec (rec_all ?rt ?rf)) (xs @ [0])
+ = Minr (\<lambda>args. 0 < rec_exec rf args) xs 0"
+ apply(simp add: Sigma.simps)
+ apply(simp only: prrf all_lemma,
+ auto simp: rec_exec.simps get_fstn_args_take Minr.simps)
+ apply(rule_tac Min_eqI, auto)
+ done
+next
+ fix w
+ let ?rt = "(recf.id (Suc (length xs)) ((length xs)))"
+ let ?rf = "(Cn (Suc (Suc (length xs)))
+ rec_not [Cn (Suc (Suc (length xs))) rf
+ (get_fstn_args (Suc (Suc (length xs))) (length xs) @
+ [recf.id (Suc (Suc (length xs)))
+ (Suc ((length xs)))])])"
+ let ?rq = "(rec_all ?rt ?rf)"
+ assume ind:
+ "Sigma (rec_exec (rec_all ?rt ?rf)) (xs @ [w]) = Minr (\<lambda>args. 0 < rec_exec rf args) xs w"
+ have prrf: "primerec ?rf (Suc (length (xs @ [Suc w]))) \<and>
+ primerec ?rt (length (xs @ [Suc w]))"
+ apply(auto simp: prrf nth_append)+
+ done
+ show "UF.Sigma (rec_exec (rec_all ?rt ?rf))
+ (xs @ [Suc w]) =
+ Minr (\<lambda>args. 0 < rec_exec rf args) xs (Suc w)"
+ apply(auto simp: Sigma_Suc_simp_rewrite ind Minr_Suc_simp)
+ apply(simp_all only: prrf all_lemma)
+ apply(auto simp: rec_exec.simps get_fstn_args_take Let_def Minr.simps split: if_splits)
+ apply(drule_tac Min_false1, simp, simp, simp)
+ apply(case_tac "x = Suc w", simp, simp)
+ apply(drule_tac Min_false1, simp, simp, simp)
+ apply(drule_tac Min_false1, simp, simp, simp)
+ done
+qed
+
+text {*
+ The correctness of @{text "rec_Minr"}.
+ *}
+lemma Minr_lemma: "
+ \<lbrakk>primerec rf (Suc (length xs))\<rbrakk>
+ \<Longrightarrow> rec_exec (rec_Minr rf) (xs @ [w]) =
+ Minr (\<lambda> args. (0 < rec_exec rf args)) xs w"
+proof -
+ let ?rt = "(recf.id (Suc (length xs)) ((length xs)))"
+ let ?rf = "(Cn (Suc (Suc (length xs)))
+ rec_not [Cn (Suc (Suc (length xs))) rf
+ (get_fstn_args (Suc (Suc (length xs))) (length xs) @
+ [recf.id (Suc (Suc (length xs)))
+ (Suc ((length xs)))])])"
+ let ?rq = "(rec_all ?rt ?rf)"
+ assume h: "primerec rf (Suc (length xs))"
+ have h1: "primerec ?rq (Suc (length xs))"
+ apply(rule_tac primerec_all_iff)
+ apply(auto simp: h nth_append)+
+ done
+ moreover have "arity rf = Suc (length xs)"
+ using h by auto
+ ultimately show "rec_exec (rec_Minr rf) (xs @ [w]) =
+ Minr (\<lambda> args. (0 < rec_exec rf args)) xs w"
+ apply(simp add: rec_exec.simps rec_Minr.simps arity.simps Let_def
+ sigma_lemma all_lemma)
+ apply(rule_tac sigma_minr_lemma)
+ apply(simp add: h)
+ done
+qed
+
+text {*
+ @{text "rec_le"} is the comparasion function
+ which compares its two arguments, testing whether the
+ first is less or equal to the second.
+ *}
+definition rec_le :: "recf"
+ where
+ "rec_le = Cn (Suc (Suc 0)) rec_disj [rec_less, rec_eq]"
+
+text {*
+ The correctness of @{text "rec_le"}.
+ *}
+lemma le_lemma:
+ "\<And>x y. rec_exec rec_le [x, y] = (if (x \<le> y) then 1 else 0)"
+by(auto simp: rec_le_def rec_exec.simps)
+
+text {*
+ Defintiion of @{text "Max[Rr]"} on page 77 of Boolos's book.
+*}
+
+fun Maxr :: "(nat list \<Rightarrow> bool) \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "Maxr Rr xs w = (let setx = {y. y \<le> w \<and> Rr (xs @[y])} in
+ if setx = {} then 0
+ else Max setx)"
+
+text {*
+ @{text "rec_maxr"} is the recursive function
+ used to implementation @{text "Maxr"}.
+ *}
+fun rec_maxr :: "recf \<Rightarrow> recf"
+ where
+ "rec_maxr rr = (let vl = arity rr in
+ let rt = id (Suc vl) (vl - 1) in
+ let rf1 = Cn (Suc (Suc vl)) rec_le
+ [id (Suc (Suc vl))
+ ((Suc vl)), id (Suc (Suc vl)) (vl)] in
+ let rf2 = Cn (Suc (Suc vl)) rec_not
+ [Cn (Suc (Suc vl))
+ rr (get_fstn_args (Suc (Suc vl))
+ (vl - 1) @
+ [id (Suc (Suc vl)) ((Suc vl))])] in
+ let rf = Cn (Suc (Suc vl)) rec_disj [rf1, rf2] in
+ let rq = rec_all rt rf in
+ let Qf = Cn (Suc vl) rec_not [rec_all rt rf]
+ in Cn vl (rec_sigma Qf) (get_fstn_args vl vl @
+ [id vl (vl - 1)]))"
+
+declare rec_maxr.simps[simp del] Maxr.simps[simp del]
+declare le_lemma[simp]
+lemma [simp]: "(min (Suc (Suc (Suc (x)))) (x)) = x"
+by simp
+
+declare numeral_2_eq_2[simp]
+
+lemma [intro]: "primerec rec_disj (Suc (Suc 0))"
+ apply(simp add: rec_disj_def, auto)
+ apply(auto)
+ apply(case_tac ia, auto intro: prime_id)
+ done
+
+lemma [intro]: "primerec rec_less (Suc (Suc 0))"
+ apply(simp add: rec_less_def, auto)
+ apply(auto)
+ apply(case_tac ia , auto intro: prime_id)
+ done
+
+lemma [intro]: "primerec rec_eq (Suc (Suc 0))"
+ apply(simp add: rec_eq_def)
+ apply(rule_tac prime_cn, auto)
+ apply(case_tac i, auto)
+ apply(case_tac ia, auto)
+ apply(case_tac [!] i, auto intro: prime_id)
+ done
+
+lemma [intro]: "primerec rec_le (Suc (Suc 0))"
+ apply(simp add: rec_le_def)
+ apply(rule_tac prime_cn, auto)
+ apply(case_tac i, auto)
+ done
+
+lemma [simp]:
+ "length ys = Suc n \<Longrightarrow> (take n ys @ [ys ! n, ys ! n]) =
+ ys @ [ys ! n]"
+apply(simp)
+apply(subgoal_tac "\<exists> xs y. ys = xs @ [y]", auto)
+apply(rule_tac x = "butlast ys" in exI, rule_tac x = "last ys" in exI)
+apply(case_tac "ys = []", simp_all)
+done
+
+lemma Maxr_Suc_simp:
+ "Maxr Rr xs (Suc w) =(if Rr (xs @ [Suc w]) then Suc w
+ else Maxr Rr xs w)"
+apply(auto simp: Maxr.simps)
+apply(rule_tac max_absorb1)
+apply(subgoal_tac "(Max {y. y \<le> w \<and> Rr (xs @ [y])} \<le> (Suc w)) =
+ (\<forall>a\<in>{y. y \<le> w \<and> Rr (xs @ [y])}. a \<le> (Suc w))", simp)
+apply(rule_tac Max_le_iff, auto)
+done
+
+
+lemma [simp]: "min (Suc n) n = n" by simp
+
+lemma Sigma_0: "\<forall> i \<le> n. (f (xs @ [i]) = 0) \<Longrightarrow>
+ Sigma f (xs @ [n]) = 0"
+apply(induct n, simp add: Sigma.simps)
+apply(simp add: Sigma_Suc_simp_rewrite)
+done
+
+lemma [elim]: "\<forall>k<Suc w. f (xs @ [k]) = Suc 0
+ \<Longrightarrow> Sigma f (xs @ [w]) = Suc w"
+apply(induct w)
+apply(simp add: Sigma.simps, simp)
+apply(simp add: Sigma.simps)
+done
+
+lemma Sigma_max_point: "\<lbrakk>\<forall> k < ma. f (xs @ [k]) = 1;
+ \<forall> k \<ge> ma. f (xs @ [k]) = 0; ma \<le> w\<rbrakk>
+ \<Longrightarrow> Sigma f (xs @ [w]) = ma"
+apply(induct w, auto)
+apply(rule_tac Sigma_0, simp)
+apply(simp add: Sigma_Suc_simp_rewrite)
+apply(case_tac "ma = Suc w", auto)
+done
+
+lemma Sigma_Max_lemma:
+ assumes prrf: "primerec rf (Suc (length xs))"
+ shows "UF.Sigma (rec_exec (Cn (Suc (Suc (length xs))) rec_not
+ [rec_all (recf.id (Suc (Suc (length xs))) (length xs))
+ (Cn (Suc (Suc (Suc (length xs)))) rec_disj
+ [Cn (Suc (Suc (Suc (length xs)))) rec_le
+ [recf.id (Suc (Suc (Suc (length xs)))) (Suc (Suc (length xs))),
+ recf.id (Suc (Suc (Suc (length xs)))) (Suc (length xs))],
+ Cn (Suc (Suc (Suc (length xs)))) rec_not
+ [Cn (Suc (Suc (Suc (length xs)))) rf
+ (get_fstn_args (Suc (Suc (Suc (length xs)))) (length xs) @
+ [recf.id (Suc (Suc (Suc (length xs)))) (Suc (Suc (length xs)))])]])]))
+ ((xs @ [w]) @ [w]) =
+ Maxr (\<lambda>args. 0 < rec_exec rf args) xs w"
+proof -
+ let ?rt = "(recf.id (Suc (Suc (length xs))) ((length xs)))"
+ let ?rf1 = "Cn (Suc (Suc (Suc (length xs))))
+ rec_le [recf.id (Suc (Suc (Suc (length xs))))
+ ((Suc (Suc (length xs)))), recf.id
+ (Suc (Suc (Suc (length xs)))) ((Suc (length xs)))]"
+ let ?rf2 = "Cn (Suc (Suc (Suc (length xs)))) rf
+ (get_fstn_args (Suc (Suc (Suc (length xs))))
+ (length xs) @
+ [recf.id (Suc (Suc (Suc (length xs))))
+ ((Suc (Suc (length xs))))])"
+ let ?rf3 = "Cn (Suc (Suc (Suc (length xs)))) rec_not [?rf2]"
+ let ?rf = "Cn (Suc (Suc (Suc (length xs)))) rec_disj [?rf1, ?rf3]"
+ let ?rq = "rec_all ?rt ?rf"
+ let ?notrq = "Cn (Suc (Suc (length xs))) rec_not [?rq]"
+ show "?thesis"
+ proof(auto simp: Maxr.simps)
+ assume h: "\<forall>x\<le>w. rec_exec rf (xs @ [x]) = 0"
+ have "primerec ?rf (Suc (length (xs @ [w, i]))) \<and>
+ primerec ?rt (length (xs @ [w, i]))"
+ using prrf
+ apply(auto)
+ apply(case_tac i, auto)
+ apply(case_tac ia, auto simp: h nth_append)
+ done
+ hence "Sigma (rec_exec ?notrq) ((xs@[w])@[w]) = 0"
+ apply(rule_tac Sigma_0)
+ apply(auto simp: rec_exec.simps all_lemma
+ get_fstn_args_take nth_append h)
+ done
+ thus "UF.Sigma (rec_exec ?notrq)
+ (xs @ [w, w]) = 0"
+ by simp
+ next
+ fix x
+ assume h: "x \<le> w" "0 < rec_exec rf (xs @ [x])"
+ hence "\<exists> ma. Max {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])} = ma"
+ by auto
+ from this obtain ma where k1:
+ "Max {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])} = ma" ..
+ hence k2: "ma \<le> w \<and> 0 < rec_exec rf (xs @ [ma])"
+ using h
+ apply(subgoal_tac
+ "Max {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])} \<in> {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])}")
+ apply(erule_tac CollectE, simp)
+ apply(rule_tac Max_in, auto)
+ done
+ hence k3: "\<forall> k < ma. (rec_exec ?notrq (xs @ [w, k]) = 1)"
+ apply(auto simp: nth_append)
+ apply(subgoal_tac "primerec ?rf (Suc (length (xs @ [w, k]))) \<and>
+ primerec ?rt (length (xs @ [w, k]))")
+ apply(auto simp: rec_exec.simps all_lemma get_fstn_args_take nth_append)
+ using prrf
+ apply(case_tac i, auto)
+ apply(case_tac ia, auto simp: h nth_append)
+ done
+ have k4: "\<forall> k \<ge> ma. (rec_exec ?notrq (xs @ [w, k]) = 0)"
+ apply(auto)
+ apply(subgoal_tac "primerec ?rf (Suc (length (xs @ [w, k]))) \<and>
+ primerec ?rt (length (xs @ [w, k]))")
+ apply(auto simp: rec_exec.simps all_lemma get_fstn_args_take nth_append)
+ apply(subgoal_tac "x \<le> Max {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])}",
+ simp add: k1)
+ apply(rule_tac Max_ge, auto)
+ using prrf
+ apply(case_tac i, auto)
+ apply(case_tac ia, auto simp: h nth_append)
+ done
+ from k3 k4 k1 have "Sigma (rec_exec ?notrq) ((xs @ [w]) @ [w]) = ma"
+ apply(rule_tac Sigma_max_point, simp, simp, simp add: k2)
+ done
+ from k1 and this show "Sigma (rec_exec ?notrq) (xs @ [w, w]) =
+ Max {y. y \<le> w \<and> 0 < rec_exec rf (xs @ [y])}"
+ by simp
+ qed
+qed
+
+text {*
+ The correctness of @{text "rec_maxr"}.
+ *}
+lemma Maxr_lemma:
+ assumes h: "primerec rf (Suc (length xs))"
+ shows "rec_exec (rec_maxr rf) (xs @ [w]) =
+ Maxr (\<lambda> args. 0 < rec_exec rf args) xs w"
+proof -
+ from h have "arity rf = Suc (length xs)"
+ by auto
+ thus "?thesis"
+ proof(simp add: rec_exec.simps rec_maxr.simps nth_append get_fstn_args_take)
+ let ?rt = "(recf.id (Suc (Suc (length xs))) ((length xs)))"
+ let ?rf1 = "Cn (Suc (Suc (Suc (length xs))))
+ rec_le [recf.id (Suc (Suc (Suc (length xs))))
+ ((Suc (Suc (length xs)))), recf.id
+ (Suc (Suc (Suc (length xs)))) ((Suc (length xs)))]"
+ let ?rf2 = "Cn (Suc (Suc (Suc (length xs)))) rf
+ (get_fstn_args (Suc (Suc (Suc (length xs))))
+ (length xs) @
+ [recf.id (Suc (Suc (Suc (length xs))))
+ ((Suc (Suc (length xs))))])"
+ let ?rf3 = "Cn (Suc (Suc (Suc (length xs)))) rec_not [?rf2]"
+ let ?rf = "Cn (Suc (Suc (Suc (length xs)))) rec_disj [?rf1, ?rf3]"
+ let ?rq = "rec_all ?rt ?rf"
+ let ?notrq = "Cn (Suc (Suc (length xs))) rec_not [?rq]"
+ have prt: "primerec ?rt (Suc (Suc (length xs)))"
+ by(auto intro: prime_id)
+ have prrf: "primerec ?rf (Suc (Suc (Suc (length xs))))"
+ apply(auto)
+ apply(case_tac i, auto)
+ apply(case_tac ia, auto intro: prime_id)
+ apply(simp add: h)
+ apply(simp add: nth_append, auto intro: prime_id)
+ done
+ from prt and prrf have prrq: "primerec ?rq
+ (Suc (Suc (length xs)))"
+ by(erule_tac primerec_all_iff, auto)
+ hence prnotrp: "primerec ?notrq (Suc (length ((xs @ [w]))))"
+ by(rule_tac prime_cn, auto)
+ have g1: "rec_exec (rec_sigma ?notrq) ((xs @ [w]) @ [w])
+ = Maxr (\<lambda>args. 0 < rec_exec rf args) xs w"
+ using prnotrp
+ using sigma_lemma
+ apply(simp only: sigma_lemma)
+ apply(rule_tac Sigma_Max_lemma)
+ apply(simp add: h)
+ done
+ thus "rec_exec (rec_sigma ?notrq)
+ (xs @ [w, w]) =
+ Maxr (\<lambda>args. 0 < rec_exec rf args) xs w"
+ apply(simp)
+ done
+ qed
+qed
+
+text {*
+ @text "quo"} is the formal specification of division.
+ *}
+fun quo :: "nat list \<Rightarrow> nat"
+ where
+ "quo [x, y] = (let Rr =
+ (\<lambda> zs. ((zs ! (Suc 0) * zs ! (Suc (Suc 0))
+ \<le> zs ! 0) \<and> zs ! Suc 0 \<noteq> (0::nat)))
+ in Maxr Rr [x, y] x)"
+
+declare quo.simps[simp del]
+
+text {*
+ The following lemmas shows more directly the menaing of @{text "quo"}:
+ *}
+lemma [elim!]: "y > 0 \<Longrightarrow> quo [x, y] = x div y"
+proof(simp add: quo.simps Maxr.simps, auto,
+ rule_tac Max_eqI, simp, auto)
+ fix xa ya
+ assume h: "y * ya \<le> x" "y > 0"
+ hence "(y * ya) div y \<le> x div y"
+ by(insert div_le_mono[of "y * ya" x y], simp)
+ from this and h show "ya \<le> x div y" by simp
+next
+ fix xa
+ show "y * (x div y) \<le> x"
+ apply(subgoal_tac "y * (x div y) + x mod y = x")
+ apply(rule_tac k = "x mod y" in add_leD1, simp)
+ apply(simp)
+ done
+qed
+
+lemma [intro]: "quo [x, 0] = 0"
+by(simp add: quo.simps Maxr.simps)
+
+lemma quo_div: "quo [x, y] = x div y"
+by(case_tac "y=0", auto)
+
+text {*
+ @{text "rec_noteq"} is the recursive function testing whether its
+ two arguments are not equal.
+ *}
+definition rec_noteq:: "recf"
+ where
+ "rec_noteq = Cn (Suc (Suc 0)) rec_not [Cn (Suc (Suc 0))
+ rec_eq [id (Suc (Suc 0)) (0), id (Suc (Suc 0))
+ ((Suc 0))]]"
+
+text {*
+ The correctness of @{text "rec_noteq"}.
+ *}
+lemma noteq_lemma:
+ "\<And> x y. rec_exec rec_noteq [x, y] =
+ (if x \<noteq> y then 1 else 0)"
+by(simp add: rec_exec.simps rec_noteq_def)
+
+declare noteq_lemma[simp]
+
+text {*
+ @{text "rec_quo"} is the recursive function used to implement @{text "quo"}
+ *}
+definition rec_quo :: "recf"
+ where
+ "rec_quo = (let rR = Cn (Suc (Suc (Suc 0))) rec_conj
+ [Cn (Suc (Suc (Suc 0))) rec_le
+ [Cn (Suc (Suc (Suc 0))) rec_mult
+ [id (Suc (Suc (Suc 0))) (Suc 0),
+ id (Suc (Suc (Suc 0))) ((Suc (Suc 0)))],
+ id (Suc (Suc (Suc 0))) (0)],
+ Cn (Suc (Suc (Suc 0))) rec_noteq
+ [id (Suc (Suc (Suc 0))) (Suc (0)),
+ Cn (Suc (Suc (Suc 0))) (constn 0)
+ [id (Suc (Suc (Suc 0))) (0)]]]
+ in Cn (Suc (Suc 0)) (rec_maxr rR)) [id (Suc (Suc 0))
+ (0),id (Suc (Suc 0)) (Suc (0)),
+ id (Suc (Suc 0)) (0)]"
+
+lemma [intro]: "primerec rec_conj (Suc (Suc 0))"
+ apply(simp add: rec_conj_def)
+ apply(rule_tac prime_cn, auto)+
+ apply(case_tac i, auto intro: prime_id)
+ done
+
+lemma [intro]: "primerec rec_noteq (Suc (Suc 0))"
+apply(simp add: rec_noteq_def)
+apply(rule_tac prime_cn, auto)+
+apply(case_tac i, auto intro: prime_id)
+done
+
+
+lemma quo_lemma1: "rec_exec rec_quo [x, y] = quo [x, y]"
+proof(simp add: rec_exec.simps rec_quo_def)
+ let ?rR = "(Cn (Suc (Suc (Suc 0))) rec_conj
+ [Cn (Suc (Suc (Suc 0))) rec_le
+ [Cn (Suc (Suc (Suc 0))) rec_mult
+ [recf.id (Suc (Suc (Suc 0))) (Suc (0)),
+ recf.id (Suc (Suc (Suc 0))) (Suc (Suc (0)))],
+ recf.id (Suc (Suc (Suc 0))) (0)],
+ Cn (Suc (Suc (Suc 0))) rec_noteq
+ [recf.id (Suc (Suc (Suc 0)))
+ (Suc (0)), Cn (Suc (Suc (Suc 0))) (constn 0)
+ [recf.id (Suc (Suc (Suc 0))) (0)]]])"
+ have "rec_exec (rec_maxr ?rR) ([x, y]@ [ x]) = Maxr (\<lambda> args. 0 < rec_exec ?rR args) [x, y] x"
+ proof(rule_tac Maxr_lemma, simp)
+ show "primerec ?rR (Suc (Suc (Suc 0)))"
+ apply(auto)
+ apply(case_tac i, auto)
+ apply(case_tac [!] ia, auto)
+ apply(case_tac i, auto)
+ done
+ qed
+ hence g1: "rec_exec (rec_maxr ?rR) ([x, y, x]) =
+ Maxr (\<lambda> args. if rec_exec ?rR args = 0 then False
+ else True) [x, y] x"
+ by simp
+ have g2: "Maxr (\<lambda> args. if rec_exec ?rR args = 0 then False
+ else True) [x, y] x = quo [x, y]"
+ apply(simp add: rec_exec.simps)
+ apply(simp add: Maxr.simps quo.simps, auto)
+ done
+ from g1 and g2 show
+ "rec_exec (rec_maxr ?rR) ([x, y, x]) = quo [x, y]"
+ by simp
+qed
+
+text {*
+ The correctness of @{text "quo"}.
+ *}
+lemma quo_lemma2: "rec_exec rec_quo [x, y] = x div y"
+ using quo_lemma1[of x y] quo_div[of x y]
+ by simp
+
+text {*
+ @{text "rec_mod"} is the recursive function used to implement
+ the reminder function.
+ *}
+definition rec_mod :: "recf"
+ where
+ "rec_mod = Cn (Suc (Suc 0)) rec_minus [id (Suc (Suc 0)) (0),
+ Cn (Suc (Suc 0)) rec_mult [rec_quo, id (Suc (Suc 0))
+ (Suc (0))]]"
+
+text {*
+ The correctness of @{text "rec_mod"}:
+ *}
+lemma mod_lemma: "\<And> x y. rec_exec rec_mod [x, y] = (x mod y)"
+proof(simp add: rec_exec.simps rec_mod_def quo_lemma2)
+ fix x y
+ show "x - x div y * y = x mod (y::nat)"
+ using mod_div_equality2[of y x]
+ apply(subgoal_tac "y * (x div y) = (x div y ) * y", arith, simp)
+ done
+qed
+
+text{* lemmas for embranch function*}
+type_synonym ftype = "nat list \<Rightarrow> nat"
+type_synonym rtype = "nat list \<Rightarrow> bool"
+
+text {*
+ The specifation of the mutli-way branching statement on
+ page 79 of Boolos's book.
+ *}
+fun Embranch :: "(ftype * rtype) list \<Rightarrow> nat list \<Rightarrow> nat"
+ where
+ "Embranch [] xs = 0" |
+ "Embranch (gc # gcs) xs = (
+ let (g, c) = gc in
+ if c xs then g xs else Embranch gcs xs)"
+
+fun rec_embranch' :: "(recf * recf) list \<Rightarrow> nat \<Rightarrow> recf"
+ where
+ "rec_embranch' [] vl = Cn vl z [id vl (vl - 1)]" |
+ "rec_embranch' ((rg, rc) # rgcs) vl = Cn vl rec_add
+ [Cn vl rec_mult [rg, rc], rec_embranch' rgcs vl]"
+
+text {*
+ @{text "rec_embrach"} is the recursive function used to implement
+ @{text "Embranch"}.
+ *}
+fun rec_embranch :: "(recf * recf) list \<Rightarrow> recf"
+ where
+ "rec_embranch ((rg, rc) # rgcs) =
+ (let vl = arity rg in
+ rec_embranch' ((rg, rc) # rgcs) vl)"
+
+declare Embranch.simps[simp del] rec_embranch.simps[simp del]
+
+lemma embranch_all0:
+ "\<lbrakk>\<forall> j < length rcs. rec_exec (rcs ! j) xs = 0;
+ length rgs = length rcs;
+ rcs \<noteq> [];
+ list_all (\<lambda> rf. primerec rf (length xs)) (rgs @ rcs)\<rbrakk> \<Longrightarrow>
+ rec_exec (rec_embranch (zip rgs rcs)) xs = 0"
+proof(induct rcs arbitrary: rgs, simp, case_tac rgs, simp)
+ fix a rcs rgs aa list
+ assume ind:
+ "\<And>rgs. \<lbrakk>\<forall>j<length rcs. rec_exec (rcs ! j) xs = 0;
+ length rgs = length rcs; rcs \<noteq> [];
+ list_all (\<lambda>rf. primerec rf (length xs)) (rgs @ rcs)\<rbrakk> \<Longrightarrow>
+ rec_exec (rec_embranch (zip rgs rcs)) xs = 0"
+ and h: "\<forall>j<length (a # rcs). rec_exec ((a # rcs) ! j) xs = 0"
+ "length rgs = length (a # rcs)"
+ "a # rcs \<noteq> []"
+ "list_all (\<lambda>rf. primerec rf (length xs)) (rgs @ a # rcs)"
+ "rgs = aa # list"
+ have g: "rcs \<noteq> [] \<Longrightarrow> rec_exec (rec_embranch (zip list rcs)) xs = 0"
+ using h
+ by(rule_tac ind, auto)
+ show "rec_exec (rec_embranch (zip rgs (a # rcs))) xs = 0"
+ proof(case_tac "rcs = []", simp)
+ show "rec_exec (rec_embranch (zip rgs [a])) xs = 0"
+ using h
+ apply(simp add: rec_embranch.simps rec_exec.simps)
+ apply(erule_tac x = 0 in allE, simp)
+ done
+ next
+ assume "rcs \<noteq> []"
+ hence "rec_exec (rec_embranch (zip list rcs)) xs = 0"
+ using g by simp
+ thus "rec_exec (rec_embranch (zip rgs (a # rcs))) xs = 0"
+ using h
+ apply(simp add: rec_embranch.simps rec_exec.simps)
+ apply(case_tac rcs,
+ auto simp: rec_exec.simps rec_embranch.simps)
+ apply(case_tac list,
+ auto simp: rec_exec.simps rec_embranch.simps)
+ done
+ qed
+qed
+
+
+lemma embranch_exec_0: "\<lbrakk>rec_exec aa xs = 0; zip rgs list \<noteq> [];
+ list_all (\<lambda> rf. primerec rf (length xs)) ([a, aa] @ rgs @ list)\<rbrakk>
+ \<Longrightarrow> rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs
+ = rec_exec (rec_embranch (zip rgs list)) xs"
+apply(simp add: rec_exec.simps rec_embranch.simps)
+apply(case_tac "zip rgs list", simp, case_tac ab,
+ simp add: rec_embranch.simps rec_exec.simps)
+apply(subgoal_tac "arity a = length xs", auto)
+apply(subgoal_tac "arity aaa = length xs", auto)
+apply(case_tac rgs, simp, case_tac list, simp, simp)
+done
+
+lemma zip_null_iff: "\<lbrakk>length xs = k; length ys = k; zip xs ys = []\<rbrakk> \<Longrightarrow> xs = [] \<and> ys = []"
+apply(case_tac xs, simp, simp)
+apply(case_tac ys, simp, simp)
+done
+
+lemma zip_null_gr: "\<lbrakk>length xs = k; length ys = k; zip xs ys \<noteq> []\<rbrakk> \<Longrightarrow> 0 < k"
+apply(case_tac xs, simp, simp)
+done
+
+lemma Embranch_0:
+ "\<lbrakk>length rgs = k; length rcs = k; k > 0;
+ \<forall> j < k. rec_exec (rcs ! j) xs = 0\<rbrakk> \<Longrightarrow>
+ Embranch (zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) rcs)) xs = 0"
+proof(induct rgs arbitrary: rcs k, simp, simp)
+ fix a rgs rcs k
+ assume ind:
+ "\<And>rcs k. \<lbrakk>length rgs = k; length rcs = k; 0 < k; \<forall>j<k. rec_exec (rcs ! j) xs = 0\<rbrakk>
+ \<Longrightarrow> Embranch (zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) rcs)) xs = 0"
+ and h: "Suc (length rgs) = k" "length rcs = k"
+ "\<forall>j<k. rec_exec (rcs ! j) xs = 0"
+ from h show
+ "Embranch (zip (rec_exec a # map rec_exec rgs)
+ (map (\<lambda>r args. 0 < rec_exec r args) rcs)) xs = 0"
+ apply(case_tac rcs, simp, case_tac "rgs = []", simp)
+ apply(simp add: Embranch.simps)
+ apply(erule_tac x = 0 in allE, simp)
+ apply(simp add: Embranch.simps)
+ apply(erule_tac x = 0 in all_dupE, simp)
+ apply(rule_tac ind, simp, simp, simp, auto)
+ apply(erule_tac x = "Suc j" in allE, simp)
+ done
+qed
+
+text {*
+ The correctness of @{text "rec_embranch"}.
+ *}
+lemma embranch_lemma:
+ assumes branch_num:
+ "length rgs = n" "length rcs = n" "n > 0"
+ and partition:
+ "(\<exists> i < n. (rec_exec (rcs ! i) xs = 1 \<and> (\<forall> j < n. j \<noteq> i \<longrightarrow>
+ rec_exec (rcs ! j) xs = 0)))"
+ and prime_all: "list_all (\<lambda> rf. primerec rf (length xs)) (rgs @ rcs)"
+ shows "rec_exec (rec_embranch (zip rgs rcs)) xs =
+ Embranch (zip (map rec_exec rgs)
+ (map (\<lambda> r args. 0 < rec_exec r args) rcs)) xs"
+ using branch_num partition prime_all
+proof(induct rgs arbitrary: rcs n, simp)
+ fix a rgs rcs n
+ assume ind:
+ "\<And>rcs n. \<lbrakk>length rgs = n; length rcs = n; 0 < n;
+ \<exists>i<n. rec_exec (rcs ! i) xs = 1 \<and> (\<forall>j<n. j \<noteq> i \<longrightarrow> rec_exec (rcs ! j) xs = 0);
+ list_all (\<lambda>rf. primerec rf (length xs)) (rgs @ rcs)\<rbrakk>
+ \<Longrightarrow> rec_exec (rec_embranch (zip rgs rcs)) xs =
+ Embranch (zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) rcs)) xs"
+ and h: "length (a # rgs) = n" "length (rcs::recf list) = n" "0 < n"
+ " \<exists>i<n. rec_exec (rcs ! i) xs = 1 \<and>
+ (\<forall>j<n. j \<noteq> i \<longrightarrow> rec_exec (rcs ! j) xs = 0)"
+ "list_all (\<lambda>rf. primerec rf (length xs)) ((a # rgs) @ rcs)"
+ from h show "rec_exec (rec_embranch (zip (a # rgs) rcs)) xs =
+ Embranch (zip (map rec_exec (a # rgs)) (map (\<lambda>r args.
+ 0 < rec_exec r args) rcs)) xs"
+ apply(case_tac rcs, simp, simp)
+ apply(case_tac "rec_exec aa xs = 0")
+ apply(case_tac [!] "zip rgs list = []", simp)
+ apply(subgoal_tac "rgs = [] \<and> list = []", simp add: Embranch.simps rec_exec.simps rec_embranch.simps)
+ apply(rule_tac zip_null_iff, simp, simp, simp)
+thm Embranch.simps
+ proof -
+ fix aa list
+ assume g:
+ "Suc (length rgs) = n" "Suc (length list) = n"
+ "\<exists>i<n. rec_exec ((aa # list) ! i) xs = Suc 0 \<and>
+ (\<forall>j<n. j \<noteq> i \<longrightarrow> rec_exec ((aa # list) ! j) xs = 0)"
+ "primerec a (length xs) \<and>
+ list_all (\<lambda>rf. primerec rf (length xs)) rgs \<and>
+ primerec aa (length xs) \<and>
+ list_all (\<lambda>rf. primerec rf (length xs)) list"
+ "rec_exec aa xs = 0" "rcs = aa # list" "zip rgs list \<noteq> []"
+ have "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs
+ = rec_exec (rec_embranch (zip rgs list)) xs"
+ apply(rule embranch_exec_0, simp_all add: g)
+ done
+ from g and this show "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs =
+ Embranch ((rec_exec a, \<lambda>args. 0 < rec_exec aa args) #
+ zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) list)) xs"
+ apply(simp add: Embranch.simps)
+ apply(rule_tac n = "n - Suc 0" in ind)
+ apply(case_tac n, simp, simp)
+ apply(case_tac n, simp, simp)
+ apply(case_tac n, simp, simp add: zip_null_gr )
+ apply(auto)
+ apply(case_tac i, simp, simp)
+ apply(rule_tac x = nat in exI, simp)
+ apply(rule_tac allI, erule_tac x = "Suc j" in allE, simp)
+ done
+ next
+ fix aa list
+ assume g: "Suc (length rgs) = n" "Suc (length list) = n"
+ "\<exists>i<n. rec_exec ((aa # list) ! i) xs = Suc 0 \<and>
+ (\<forall>j<n. j \<noteq> i \<longrightarrow> rec_exec ((aa # list) ! j) xs = 0)"
+ "primerec a (length xs) \<and> list_all (\<lambda>rf. primerec rf (length xs)) rgs \<and>
+ primerec aa (length xs) \<and> list_all (\<lambda>rf. primerec rf (length xs)) list"
+ "rcs = aa # list" "rec_exec aa xs \<noteq> 0" "zip rgs list = []"
+ thus "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs =
+ Embranch ((rec_exec a, \<lambda>args. 0 < rec_exec aa args) #
+ zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) list)) xs"
+ apply(subgoal_tac "rgs = [] \<and> list = []", simp)
+ prefer 2
+ apply(rule_tac zip_null_iff, simp, simp, simp)
+ apply(simp add: rec_exec.simps rec_embranch.simps Embranch.simps, auto)
+ done
+ next
+ fix aa list
+ assume g: "Suc (length rgs) = n" "Suc (length list) = n"
+ "\<exists>i<n. rec_exec ((aa # list) ! i) xs = Suc 0 \<and>
+ (\<forall>j<n. j \<noteq> i \<longrightarrow> rec_exec ((aa # list) ! j) xs = 0)"
+ "primerec a (length xs) \<and> list_all (\<lambda>rf. primerec rf (length xs)) rgs
+ \<and> primerec aa (length xs) \<and> list_all (\<lambda>rf. primerec rf (length xs)) list"
+ "rcs = aa # list" "rec_exec aa xs \<noteq> 0" "zip rgs list \<noteq> []"
+ have "rec_exec aa xs = Suc 0"
+ using g
+ apply(case_tac "rec_exec aa xs", simp, auto)
+ done
+ moreover have "rec_exec (rec_embranch' (zip rgs list) (length xs)) xs = 0"
+ proof -
+ have "rec_embranch' (zip rgs list) (length xs) = rec_embranch (zip rgs list)"
+ using g
+ apply(case_tac "zip rgs list", simp, case_tac ab)
+ apply(simp add: rec_embranch.simps)
+ apply(subgoal_tac "arity aaa = length xs", simp, auto)
+ apply(case_tac rgs, simp, simp, case_tac list, simp, simp)
+ done
+ moreover have "rec_exec (rec_embranch (zip rgs list)) xs = 0"
+ proof(rule embranch_all0)
+ show " \<forall>j<length list. rec_exec (list ! j) xs = 0"
+ using g
+ apply(auto)
+ apply(case_tac i, simp)
+ apply(erule_tac x = "Suc j" in allE, simp)
+ apply(simp)
+ apply(erule_tac x = 0 in allE, simp)
+ done
+ next
+ show "length rgs = length list"
+ using g
+ apply(case_tac n, simp, simp)
+ done
+ next
+ show "list \<noteq> []"
+ using g
+ apply(case_tac list, simp, simp)
+ done
+ next
+ show "list_all (\<lambda>rf. primerec rf (length xs)) (rgs @ list)"
+ using g
+ apply auto
+ done
+ qed
+ ultimately show "rec_exec (rec_embranch' (zip rgs list) (length xs)) xs = 0"
+ by simp
+ qed
+ moreover have
+ "Embranch (zip (map rec_exec rgs)
+ (map (\<lambda>r args. 0 < rec_exec r args) list)) xs = 0"
+ using g
+ apply(rule_tac k = "length rgs" in Embranch_0)
+ apply(simp, case_tac n, simp, simp)
+ apply(case_tac rgs, simp, simp)
+ apply(auto)
+ apply(case_tac i, simp)
+ apply(erule_tac x = "Suc j" in allE, simp)
+ apply(simp)
+ apply(rule_tac x = 0 in allE, auto)
+ done
+ moreover have "arity a = length xs"
+ using g
+ apply(auto)
+ done
+ ultimately show "rec_exec (rec_embranch ((a, aa) # zip rgs list)) xs =
+ Embranch ((rec_exec a, \<lambda>args. 0 < rec_exec aa args) #
+ zip (map rec_exec rgs) (map (\<lambda>r args. 0 < rec_exec r args) list)) xs"
+ apply(simp add: rec_exec.simps rec_embranch.simps Embranch.simps)
+ done
+ qed
+qed
+
+text{*
+ @{text "prime n"} means @{text "n"} is a prime number.
+*}
+fun Prime :: "nat \<Rightarrow> bool"
+ where
+ "Prime x = (1 < x \<and> (\<forall> u < x. (\<forall> v < x. u * v \<noteq> x)))"
+
+declare Prime.simps [simp del]
+
+lemma primerec_all1:
+ "primerec (rec_all rt rf) n \<Longrightarrow> primerec rt n"
+ by (simp add: primerec_all)
+
+lemma primerec_all2: "primerec (rec_all rt rf) n \<Longrightarrow>
+ primerec rf (Suc n)"
+by(insert primerec_all[of rt rf n], simp)
+
+text {*
+ @{text "rec_prime"} is the recursive function used to implement
+ @{text "Prime"}.
+ *}
+definition rec_prime :: "recf"
+ where
+ "rec_prime = Cn (Suc 0) rec_conj
+ [Cn (Suc 0) rec_less [constn 1, id (Suc 0) (0)],
+ rec_all (Cn 1 rec_minus [id 1 0, constn 1])
+ (rec_all (Cn 2 rec_minus [id 2 0, Cn 2 (constn 1)
+ [id 2 0]]) (Cn 3 rec_noteq
+ [Cn 3 rec_mult [id 3 1, id 3 2], id 3 0]))]"
+
+(*
+lemma prime_lemma1:
+ "(rec_exec rec_prime [x] = Suc 0) \<or>
+ (rec_exec rec_prime [x] = 0)"
+apply(auto simp: rec_exec.simps rec_prime_def)
+done
+*)
+declare numeral_2_eq_2[simp del] numeral_3_eq_3[simp del]
+
+lemma exec_tmp:
+ "rec_exec (rec_all (Cn 2 rec_minus [recf.id 2 0, Cn 2 (constn (Suc 0)) [recf.id 2 0]])
+ (Cn 3 rec_noteq [Cn 3 rec_mult [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0])) [x, k] =
+ ((if (\<forall>w\<le>rec_exec (Cn 2 rec_minus [recf.id 2 0, Cn 2 (constn (Suc 0)) [recf.id 2 0]]) ([x, k]).
+ 0 < rec_exec (Cn 3 rec_noteq [Cn 3 rec_mult [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0])
+ ([x, k] @ [w])) then 1 else 0))"
+apply(rule_tac all_lemma)
+apply(auto)
+apply(case_tac [!] i, auto)
+apply(case_tac ia, auto simp: numeral_3_eq_3 numeral_2_eq_2)
+done
+
+text {*
+ The correctness of @{text "Prime"}.
+ *}
+lemma prime_lemma: "rec_exec rec_prime [x] = (if Prime x then 1 else 0)"
+proof(simp add: rec_exec.simps rec_prime_def)
+ let ?rt1 = "(Cn 2 rec_minus [recf.id 2 0,
+ Cn 2 (constn (Suc 0)) [recf.id 2 0]])"
+ let ?rf1 = "(Cn 3 rec_noteq [Cn 3 rec_mult
+ [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 (0)])"
+ let ?rt2 = "(Cn (Suc 0) rec_minus
+ [recf.id (Suc 0) 0, constn (Suc 0)])"
+ let ?rf2 = "rec_all ?rt1 ?rf1"
+ have h1: "rec_exec (rec_all ?rt2 ?rf2) ([x]) =
+ (if (\<forall>k\<le>rec_exec ?rt2 ([x]). 0 < rec_exec ?rf2 ([x] @ [k])) then 1 else 0)"
+ proof(rule_tac all_lemma, simp_all)
+ show "primerec ?rf2 (Suc (Suc 0))"
+ apply(rule_tac primerec_all_iff)
+ apply(auto)
+ apply(case_tac [!] i, auto simp: numeral_2_eq_2)
+ apply(case_tac ia, auto simp: numeral_3_eq_3)
+ done
+ next
+ show "primerec (Cn (Suc 0) rec_minus
+ [recf.id (Suc 0) 0, constn (Suc 0)]) (Suc 0)"
+ apply(auto)
+ apply(case_tac i, auto)
+ done
+ qed
+ from h1 show
+ "(Suc 0 < x \<longrightarrow> (rec_exec (rec_all ?rt2 ?rf2) [x] = 0 \<longrightarrow>
+ \<not> Prime x) \<and>
+ (0 < rec_exec (rec_all ?rt2 ?rf2) [x] \<longrightarrow> Prime x)) \<and>
+ (\<not> Suc 0 < x \<longrightarrow> \<not> Prime x \<and> (rec_exec (rec_all ?rt2 ?rf2) [x] = 0
+ \<longrightarrow> \<not> Prime x))"
+ apply(auto simp:rec_exec.simps)
+ apply(simp add: exec_tmp rec_exec.simps)
+ proof -
+ assume "\<forall>k\<le>x - Suc 0. (0::nat) < (if \<forall>w\<le>x - Suc 0.
+ 0 < (if k * w \<noteq> x then 1 else (0 :: nat)) then 1 else 0)" "Suc 0 < x"
+ thus "Prime x"
+ apply(simp add: rec_exec.simps split: if_splits)
+ apply(simp add: Prime.simps, auto)
+ apply(erule_tac x = u in allE, auto)
+ apply(case_tac u, simp, case_tac nat, simp, simp)
+ apply(case_tac v, simp, case_tac nat, simp, simp)
+ done
+ next
+ assume "\<not> Suc 0 < x" "Prime x"
+ thus "False"
+ apply(simp add: Prime.simps)
+ done
+ next
+ fix k
+ assume "rec_exec (rec_all ?rt1 ?rf1)
+ [x, k] = 0" "k \<le> x - Suc 0" "Prime x"
+ thus "False"
+ apply(simp add: exec_tmp rec_exec.simps Prime.simps split: if_splits)
+ done
+ next
+ fix k
+ assume "rec_exec (rec_all ?rt1 ?rf1)
+ [x, k] = 0" "k \<le> x - Suc 0" "Prime x"
+ thus "False"
+ apply(simp add: exec_tmp rec_exec.simps Prime.simps split: if_splits)
+ done
+ qed
+qed
+
+definition rec_dummyfac :: "recf"
+ where
+ "rec_dummyfac = Pr 1 (constn 1)
+ (Cn 3 rec_mult [id 3 2, Cn 3 s [id 3 1]])"
+
+text {*
+ The recursive function used to implment factorization.
+ *}
+definition rec_fac :: "recf"
+ where
+ "rec_fac = Cn 1 rec_dummyfac [id 1 0, id 1 0]"
+
+text {*
+ Formal specification of factorization.
+ *}
+fun fac :: "nat \<Rightarrow> nat" ("_!" [100] 99)
+ where
+ "fac 0 = 1" |
+ "fac (Suc x) = (Suc x) * fac x"
+
+lemma [simp]: "rec_exec rec_dummyfac [0, 0] = Suc 0"
+by(simp add: rec_dummyfac_def rec_exec.simps)
+
+lemma rec_cn_simp: "rec_exec (Cn n f gs) xs =
+ (let rgs = map (\<lambda> g. rec_exec g xs) gs in
+ rec_exec f rgs)"
+by(simp add: rec_exec.simps)
+
+lemma rec_id_simp: "rec_exec (id m n) xs = xs ! n"
+ by(simp add: rec_exec.simps)
+
+lemma fac_dummy: "rec_exec rec_dummyfac [x, y] = y !"
+apply(induct y)
+apply(auto simp: rec_dummyfac_def rec_exec.simps)
+done
+
+text {*
+ The correctness of @{text "rec_fac"}.
+ *}
+lemma fac_lemma: "rec_exec rec_fac [x] = x!"
+apply(simp add: rec_fac_def rec_exec.simps fac_dummy)
+done
+
+declare fac.simps[simp del]
+
+text {*
+ @{text "Np x"} returns the first prime number after @{text "x"}.
+ *}
+fun Np ::"nat \<Rightarrow> nat"
+ where
+ "Np x = Min {y. y \<le> Suc (x!) \<and> x < y \<and> Prime y}"
+
+declare Np.simps[simp del] rec_Minr.simps[simp del]
+
+text {*
+ @{text "rec_np"} is the recursive function used to implement
+ @{text "Np"}.
+ *}
+definition rec_np :: "recf"
+ where
+ "rec_np = (let Rr = Cn 2 rec_conj [Cn 2 rec_less [id 2 0, id 2 1],
+ Cn 2 rec_prime [id 2 1]]
+ in Cn 1 (rec_Minr Rr) [id 1 0, Cn 1 s [rec_fac]])"
+
+lemma [simp]: "n < Suc (n!)"
+apply(induct n, simp)
+apply(simp add: fac.simps)
+apply(case_tac n, auto simp: fac.simps)
+done
+
+lemma divsor_ex:
+"\<lbrakk>\<not> Prime x; x > Suc 0\<rbrakk> \<Longrightarrow> (\<exists> u > Suc 0. (\<exists> v > Suc 0. u * v = x))"
+ by(auto simp: Prime.simps)
+
+lemma divsor_prime_ex: "\<lbrakk>\<not> Prime x; x > Suc 0\<rbrakk> \<Longrightarrow>
+ \<exists> p. Prime p \<and> p dvd x"
+apply(induct x rule: wf_induct[where r = "measure (\<lambda> y. y)"], simp)
+apply(drule_tac divsor_ex, simp, auto)
+apply(erule_tac x = u in allE, simp)
+apply(case_tac "Prime u", simp)
+apply(rule_tac x = u in exI, simp, auto)
+done
+
+lemma [intro]: "0 < n!"
+apply(induct n)
+apply(auto simp: fac.simps)
+done
+
+lemma fac_Suc: "Suc n! = (Suc n) * (n!)" by(simp add: fac.simps)
+
+lemma fac_dvd: "\<lbrakk>0 < q; q \<le> n\<rbrakk> \<Longrightarrow> q dvd n!"
+apply(induct n, simp)
+apply(case_tac "q \<le> n", simp add: fac_Suc)
+apply(subgoal_tac "q = Suc n", simp only: fac_Suc)
+apply(rule_tac dvd_mult2, simp, simp)
+done
+
+lemma fac_dvd2: "\<lbrakk>Suc 0 < q; q dvd n!; q \<le> n\<rbrakk> \<Longrightarrow> \<not> q dvd Suc (n!)"
+proof(auto simp: dvd_def)
+ fix k ka
+ assume h1: "Suc 0 < q" "q \<le> n"
+ and h2: "Suc (q * k) = q * ka"
+ have "k < ka"
+ proof -
+ have "q * k < q * ka"
+ using h2 by arith
+ thus "k < ka"
+ using h1
+ by(auto)
+ qed
+ hence "\<exists>d. d > 0 \<and> ka = d + k"
+ by(rule_tac x = "ka - k" in exI, simp)
+ from this obtain d where "d > 0 \<and> ka = d + k" ..
+ from h2 and this and h1 show "False"
+ by(simp add: add_mult_distrib2)
+qed
+
+lemma prime_ex: "\<exists> p. n < p \<and> p \<le> Suc (n!) \<and> Prime p"
+proof(cases "Prime (n! + 1)")
+ case True thus "?thesis"
+ by(rule_tac x = "Suc (n!)" in exI, simp)
+next
+ assume h: "\<not> Prime (n! + 1)"
+ hence "\<exists> p. Prime p \<and> p dvd (n! + 1)"
+ by(erule_tac divsor_prime_ex, auto)
+ from this obtain q where k: "Prime q \<and> q dvd (n! + 1)" ..
+ thus "?thesis"
+ proof(cases "q > n")
+ case True thus "?thesis"
+ using k
+ apply(rule_tac x = q in exI, auto)
+ apply(rule_tac dvd_imp_le, auto)
+ done
+ next
+ case False thus "?thesis"
+ proof -
+ assume g: "\<not> n < q"
+ have j: "q > Suc 0"
+ using k by(case_tac q, auto simp: Prime.simps)
+ hence "q dvd n!"
+ using g
+ apply(rule_tac fac_dvd, auto)
+ done
+ hence "\<not> q dvd Suc (n!)"
+ using g j
+ by(rule_tac fac_dvd2, auto)
+ thus "?thesis"
+ using k by simp
+ qed
+ qed
+qed
+
+lemma Suc_Suc_induct[elim!]: "\<lbrakk>i < Suc (Suc 0);
+ primerec (ys ! 0) n; primerec (ys ! 1) n\<rbrakk> \<Longrightarrow> primerec (ys ! i) n"
+by(case_tac i, auto)
+
+lemma [intro]: "primerec rec_prime (Suc 0)"
+apply(auto simp: rec_prime_def, auto)
+apply(rule_tac primerec_all_iff, auto, auto)
+apply(rule_tac primerec_all_iff, auto, auto simp:
+ numeral_2_eq_2 numeral_3_eq_3)
+done
+
+text {*
+ The correctness of @{text "rec_np"}.
+ *}
+lemma np_lemma: "rec_exec rec_np [x] = Np x"
+proof(auto simp: rec_np_def rec_exec.simps Let_def fac_lemma)
+ let ?rr = "(Cn 2 rec_conj [Cn 2 rec_less [recf.id 2 0,
+ recf.id 2 (Suc 0)], Cn 2 rec_prime [recf.id 2 (Suc 0)]])"
+ let ?R = "\<lambda> zs. zs ! 0 < zs ! 1 \<and> Prime (zs ! 1)"
+ have g1: "rec_exec (rec_Minr ?rr) ([x] @ [Suc (x!)]) =
+ Minr (\<lambda> args. 0 < rec_exec ?rr args) [x] (Suc (x!))"
+ by(rule_tac Minr_lemma, auto simp: rec_exec.simps
+ prime_lemma, auto simp: numeral_2_eq_2 numeral_3_eq_3)
+ have g2: "Minr (\<lambda> args. 0 < rec_exec ?rr args) [x] (Suc (x!)) = Np x"
+ using prime_ex[of x]
+ apply(auto simp: Minr.simps Np.simps rec_exec.simps)
+ apply(erule_tac x = p in allE, simp add: prime_lemma)
+ apply(simp add: prime_lemma split: if_splits)
+ apply(subgoal_tac
+ "{uu. (Prime uu \<longrightarrow> (x < uu \<longrightarrow> uu \<le> Suc (x!)) \<and> x < uu) \<and> Prime uu}
+ = {y. y \<le> Suc (x!) \<and> x < y \<and> Prime y}", auto)
+ done
+ from g1 and g2 show "rec_exec (rec_Minr ?rr) ([x, Suc (x!)]) = Np x"
+ by simp
+qed
+
+text {*lemmas for power*}
+text {*
+ @{text "rec_power"} is the recursive function used to implement
+ power function.
+ *}
+definition rec_power :: "recf"
+ where
+ "rec_power = Pr 1 (constn 1) (Cn 3 rec_mult [id 3 0, id 3 2])"
+
+text {*
+ The correctness of @{text "rec_power"}.
+ *}
+lemma power_lemma: "rec_exec rec_power [x, y] = x^y"
+ by(induct y, auto simp: rec_exec.simps rec_power_def)
+
+text{*
+ @{text "Pi k"} returns the @{text "k"}-th prime number.
+ *}
+fun Pi :: "nat \<Rightarrow> nat"
+ where
+ "Pi 0 = 2" |
+ "Pi (Suc x) = Np (Pi x)"
+
+definition rec_dummy_pi :: "recf"
+ where
+ "rec_dummy_pi = Pr 1 (constn 2) (Cn 3 rec_np [id 3 2])"
+
+text {*
+ @{text "rec_pi"} is the recursive function used to implement
+ @{text "Pi"}.
+ *}
+definition rec_pi :: "recf"
+ where
+ "rec_pi = Cn 1 rec_dummy_pi [id 1 0, id 1 0]"
+
+lemma pi_dummy_lemma: "rec_exec rec_dummy_pi [x, y] = Pi y"
+apply(induct y)
+by(auto simp: rec_exec.simps rec_dummy_pi_def Pi.simps np_lemma)
+
+text {*
+ The correctness of @{text "rec_pi"}.
+ *}
+lemma pi_lemma: "rec_exec rec_pi [x] = Pi x"
+apply(simp add: rec_pi_def rec_exec.simps pi_dummy_lemma)
+done
+
+text{*follows: lemmas for lo*}
+fun loR :: "nat list \<Rightarrow> bool"
+ where
+ "loR [x, y, u] = (x mod (y^u) = 0)"
+
+declare loR.simps[simp del]
+
+text {*
+ @{text "Lo"} specifies the @{text "lo"} function given on page 79 of
+ Boolos's book. It is one of the two notions of integeral logarithmatic
+ operation on that page. The other is @{text "lg"}.
+ *}
+fun lo :: " nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "lo x y = (if x > 1 \<and> y > 1 \<and> {u. loR [x, y, u]} \<noteq> {} then Max {u. loR [x, y, u]}
+ else 0)"
+
+declare lo.simps[simp del]
+
+lemma [elim]: "primerec rf n \<Longrightarrow> n > 0"
+apply(induct rule: primerec.induct, auto)
+done
+
+lemma primerec_sigma[intro!]:
+ "\<lbrakk>n > Suc 0; primerec rf n\<rbrakk> \<Longrightarrow>
+ primerec (rec_sigma rf) n"
+apply(simp add: rec_sigma.simps)
+apply(auto, auto simp: nth_append)
+done
+
+lemma [intro!]: "\<lbrakk>primerec rf n; n > 0\<rbrakk> \<Longrightarrow> primerec (rec_maxr rf) n"
+apply(simp add: rec_maxr.simps)
+apply(rule_tac prime_cn, auto)
+apply(rule_tac primerec_all_iff, auto, auto simp: nth_append)
+done
+
+lemma Suc_Suc_Suc_induct[elim!]:
+ "\<lbrakk>i < Suc (Suc (Suc (0::nat))); primerec (ys ! 0) n;
+ primerec (ys ! 1) n;
+ primerec (ys ! 2) n\<rbrakk> \<Longrightarrow> primerec (ys ! i) n"
+apply(case_tac i, auto, case_tac nat, simp, simp add: numeral_2_eq_2)
+done
+
+lemma [intro]: "primerec rec_quo (Suc (Suc 0))"
+apply(simp add: rec_quo_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_mod (Suc (Suc 0))"
+apply(simp add: rec_mod_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_power (Suc (Suc 0))"
+apply(simp add: rec_power_def numeral_2_eq_2 numeral_3_eq_3)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+text {*
+ @{text "rec_lo"} is the recursive function used to implement @{text "Lo"}.
+*}
+definition rec_lo :: "recf"
+ where
+ "rec_lo = (let rR = Cn 3 rec_eq [Cn 3 rec_mod [id 3 0,
+ Cn 3 rec_power [id 3 1, id 3 2]],
+ Cn 3 (constn 0) [id 3 1]] in
+ let rb = Cn 2 (rec_maxr rR) [id 2 0, id 2 1, id 2 0] in
+ let rcond = Cn 2 rec_conj [Cn 2 rec_less [Cn 2 (constn 1)
+ [id 2 0], id 2 0],
+ Cn 2 rec_less [Cn 2 (constn 1)
+ [id 2 0], id 2 1]] in
+ let rcond2 = Cn 2 rec_minus
+ [Cn 2 (constn 1) [id 2 0], rcond]
+ in Cn 2 rec_add [Cn 2 rec_mult [rb, rcond],
+ Cn 2 rec_mult [Cn 2 (constn 0) [id 2 0], rcond2]])"
+
+lemma rec_lo_Maxr_lor:
+ "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow>
+ rec_exec rec_lo [x, y] = Maxr loR [x, y] x"
+proof(auto simp: rec_exec.simps rec_lo_def Let_def
+ numeral_2_eq_2 numeral_3_eq_3)
+ let ?rR = "(Cn (Suc (Suc (Suc 0))) rec_eq
+ [Cn (Suc (Suc (Suc 0))) rec_mod [recf.id (Suc (Suc (Suc 0))) 0,
+ Cn (Suc (Suc (Suc 0))) rec_power [recf.id (Suc (Suc (Suc 0)))
+ (Suc 0), recf.id (Suc (Suc (Suc 0))) (Suc (Suc 0))]],
+ Cn (Suc (Suc (Suc 0))) (constn 0) [recf.id (Suc (Suc (Suc 0))) (Suc 0)]])"
+ have h: "rec_exec (rec_maxr ?rR) ([x, y] @ [x]) =
+ Maxr (\<lambda> args. 0 < rec_exec ?rR args) [x, y] x"
+ by(rule_tac Maxr_lemma, auto simp: rec_exec.simps
+ mod_lemma power_lemma, auto simp: numeral_2_eq_2 numeral_3_eq_3)
+ have "Maxr loR [x, y] x = Maxr (\<lambda> args. 0 < rec_exec ?rR args) [x, y] x"
+ apply(simp add: rec_exec.simps mod_lemma power_lemma)
+ apply(simp add: Maxr.simps loR.simps)
+ done
+ from h and this show "rec_exec (rec_maxr ?rR) [x, y, x] =
+ Maxr loR [x, y] x"
+ apply(simp)
+ done
+qed
+
+lemma [simp]: "Max {ya. ya = 0 \<and> loR [0, y, ya]} = 0"
+apply(rule_tac Max_eqI, auto simp: loR.simps)
+done
+
+lemma [simp]: "Suc 0 < y \<Longrightarrow> Suc (Suc 0) < y * y"
+apply(induct y, simp)
+apply(case_tac y, simp, simp)
+done
+
+lemma less_mult: "\<lbrakk>x > 0; y > Suc 0\<rbrakk> \<Longrightarrow> x < y * x"
+apply(case_tac y, simp, simp)
+done
+
+lemma x_less_exp: "\<lbrakk>y > Suc 0\<rbrakk> \<Longrightarrow> x < y^x"
+apply(induct x, simp, simp)
+apply(case_tac x, simp, auto)
+apply(rule_tac y = "y* y^nat" in le_less_trans, simp)
+apply(rule_tac less_mult, auto)
+done
+
+lemma le_mult: "y \<noteq> (0::nat) \<Longrightarrow> x \<le> x * y"
+ by(induct y, simp, simp)
+
+lemma uplimit_loR: "\<lbrakk>Suc 0 < x; Suc 0 < y; loR [x, y, xa]\<rbrakk> \<Longrightarrow>
+ xa \<le> x"
+apply(simp add: loR.simps)
+apply(rule_tac classical, auto)
+apply(subgoal_tac "xa < y^xa")
+apply(subgoal_tac "y^xa \<le> y^xa * q", simp)
+apply(rule_tac le_mult, case_tac q, simp, simp)
+apply(rule_tac x_less_exp, simp)
+done
+
+lemma [simp]: "\<lbrakk>xa \<le> x; loR [x, y, xa]; Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow>
+ {u. loR [x, y, u]} = {ya. ya \<le> x \<and> loR [x, y, ya]}"
+apply(rule_tac Collect_cong, auto)
+apply(erule_tac uplimit_loR, simp, simp)
+done
+
+lemma Maxr_lo: "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow>
+ Maxr loR [x, y] x = lo x y"
+apply(simp add: Maxr.simps lo.simps, auto)
+apply(erule_tac x = xa in allE, simp, simp add: uplimit_loR)
+done
+
+lemma lo_lemma': "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow>
+ rec_exec rec_lo [x, y] = lo x y"
+by(simp add: Maxr_lo rec_lo_Maxr_lor)
+
+lemma lo_lemma'': "\<lbrakk>\<not> Suc 0 < x\<rbrakk> \<Longrightarrow> rec_exec rec_lo [x, y] = lo x y"
+apply(case_tac x, auto simp: rec_exec.simps rec_lo_def
+ Let_def lo.simps)
+done
+
+lemma lo_lemma''': "\<lbrakk>\<not> Suc 0 < y\<rbrakk> \<Longrightarrow> rec_exec rec_lo [x, y] = lo x y"
+apply(case_tac y, auto simp: rec_exec.simps rec_lo_def
+ Let_def lo.simps)
+done
+
+text {*
+ The correctness of @{text "rec_lo"}:
+*}
+lemma lo_lemma: "rec_exec rec_lo [x, y] = lo x y"
+apply(case_tac "Suc 0 < x \<and> Suc 0 < y")
+apply(auto simp: lo_lemma' lo_lemma'' lo_lemma''')
+done
+
+fun lgR :: "nat list \<Rightarrow> bool"
+ where
+ "lgR [x, y, u] = (y^u \<le> x)"
+
+text {*
+ @{text "lg"} specifies the @{text "lg"} function given on page 79 of
+ Boolos's book. It is one of the two notions of integeral logarithmatic
+ operation on that page. The other is @{text "lo"}.
+ *}
+fun lg :: "nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "lg x y = (if x > 1 \<and> y > 1 \<and> {u. lgR [x, y, u]} \<noteq> {} then
+ Max {u. lgR [x, y, u]}
+ else 0)"
+
+declare lg.simps[simp del] lgR.simps[simp del]
+
+text {*
+ @{text "rec_lg"} is the recursive function used to implement @{text "lg"}.
+ *}
+definition rec_lg :: "recf"
+ where
+ "rec_lg = (let rec_lgR = Cn 3 rec_le
+ [Cn 3 rec_power [id 3 1, id 3 2], id 3 0] in
+ let conR1 = Cn 2 rec_conj [Cn 2 rec_less
+ [Cn 2 (constn 1) [id 2 0], id 2 0],
+ Cn 2 rec_less [Cn 2 (constn 1)
+ [id 2 0], id 2 1]] in
+ let conR2 = Cn 2 rec_not [conR1] in
+ Cn 2 rec_add [Cn 2 rec_mult
+ [conR1, Cn 2 (rec_maxr rec_lgR)
+ [id 2 0, id 2 1, id 2 0]],
+ Cn 2 rec_mult [conR2, Cn 2 (constn 0)
+ [id 2 0]]])"
+
+lemma lg_maxr: "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow>
+ rec_exec rec_lg [x, y] = Maxr lgR [x, y] x"
+proof(simp add: rec_exec.simps rec_lg_def Let_def)
+ assume h: "Suc 0 < x" "Suc 0 < y"
+ let ?rR = "(Cn 3 rec_le [Cn 3 rec_power
+ [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0])"
+ have "rec_exec (rec_maxr ?rR) ([x, y] @ [x])
+ = Maxr ((\<lambda> args. 0 < rec_exec ?rR args)) [x, y] x"
+ proof(rule Maxr_lemma)
+ show "primerec (Cn 3 rec_le [Cn 3 rec_power
+ [recf.id 3 (Suc 0), recf.id 3 2], recf.id 3 0]) (Suc (length [x, y]))"
+ apply(auto simp: numeral_3_eq_3)+
+ done
+ qed
+ moreover have "Maxr lgR [x, y] x = Maxr ((\<lambda> args. 0 < rec_exec ?rR args)) [x, y] x"
+ apply(simp add: rec_exec.simps power_lemma)
+ apply(simp add: Maxr.simps lgR.simps)
+ done
+ ultimately show "rec_exec (rec_maxr ?rR) [x, y, x] = Maxr lgR [x, y] x"
+ by simp
+qed
+
+lemma [simp]: "\<lbrakk>Suc 0 < y; lgR [x, y, xa]\<rbrakk> \<Longrightarrow> xa \<le> x"
+apply(simp add: lgR.simps)
+apply(subgoal_tac "y^xa > xa", simp)
+apply(erule x_less_exp)
+done
+
+lemma [simp]: "\<lbrakk>Suc 0 < x; Suc 0 < y; lgR [x, y, xa]\<rbrakk> \<Longrightarrow>
+ {u. lgR [x, y, u]} = {ya. ya \<le> x \<and> lgR [x, y, ya]}"
+apply(rule_tac Collect_cong, auto)
+done
+
+lemma maxr_lg: "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow> Maxr lgR [x, y] x = lg x y"
+apply(simp add: lg.simps Maxr.simps, auto)
+apply(erule_tac x = xa in allE, simp)
+done
+
+lemma lg_lemma': "\<lbrakk>Suc 0 < x; Suc 0 < y\<rbrakk> \<Longrightarrow> rec_exec rec_lg [x, y] = lg x y"
+apply(simp add: maxr_lg lg_maxr)
+done
+
+lemma lg_lemma'': "\<not> Suc 0 < x \<Longrightarrow> rec_exec rec_lg [x, y] = lg x y"
+apply(simp add: rec_exec.simps rec_lg_def Let_def lg.simps)
+done
+
+lemma lg_lemma''': "\<not> Suc 0 < y \<Longrightarrow> rec_exec rec_lg [x, y] = lg x y"
+apply(simp add: rec_exec.simps rec_lg_def Let_def lg.simps)
+done
+
+text {*
+ The correctness of @{text "rec_lg"}.
+ *}
+lemma lg_lemma: "rec_exec rec_lg [x, y] = lg x y"
+apply(case_tac "Suc 0 < x \<and> Suc 0 < y", auto simp:
+ lg_lemma' lg_lemma'' lg_lemma''')
+done
+
+text {*
+ @{text "Entry sr i"} returns the @{text "i"}-th entry of a list of natural
+ numbers encoded by number @{text "sr"} using Godel's coding.
+ *}
+fun Entry :: "nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "Entry sr i = lo sr (Pi (Suc i))"
+
+text {*
+ @{text "rec_entry"} is the recursive function used to implement
+ @{text "Entry"}.
+ *}
+definition rec_entry:: "recf"
+ where
+ "rec_entry = Cn 2 rec_lo [id 2 0, Cn 2 rec_pi [Cn 2 s [id 2 1]]]"
+
+declare Pi.simps[simp del]
+
+text {*
+ The correctness of @{text "rec_entry"}.
+ *}
+lemma entry_lemma: "rec_exec rec_entry [str, i] = Entry str i"
+ by(simp add: rec_entry_def rec_exec.simps lo_lemma pi_lemma)
+
+section {* The construction of @{text "F"} *}
+
+text {*
+ Using the auxilliary functions obtained in last section,
+ we are going to contruct the function @{text "F"},
+ which is an interpreter of Turing Machines.
+ *}
+
+fun listsum2 :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "listsum2 xs 0 = 0"
+| "listsum2 xs (Suc n) = listsum2 xs n + xs ! n"
+
+fun rec_listsum2 :: "nat \<Rightarrow> nat \<Rightarrow> recf"
+ where
+ "rec_listsum2 vl 0 = Cn vl z [id vl 0]"
+| "rec_listsum2 vl (Suc n) = Cn vl rec_add
+ [rec_listsum2 vl n, id vl (n)]"
+
+declare listsum2.simps[simp del] rec_listsum2.simps[simp del]
+
+lemma listsum2_lemma: "\<lbrakk>length xs = vl; n \<le> vl\<rbrakk> \<Longrightarrow>
+ rec_exec (rec_listsum2 vl n) xs = listsum2 xs n"
+apply(induct n, simp_all)
+apply(simp_all add: rec_exec.simps rec_listsum2.simps listsum2.simps)
+done
+
+fun strt' :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "strt' xs 0 = 0"
+| "strt' xs (Suc n) = (let dbound = listsum2 xs n + n in
+ strt' xs n + (2^(xs ! n + dbound) - 2^dbound))"
+
+fun rec_strt' :: "nat \<Rightarrow> nat \<Rightarrow> recf"
+ where
+ "rec_strt' vl 0 = Cn vl z [id vl 0]"
+| "rec_strt' vl (Suc n) = (let rec_dbound =
+ Cn vl rec_add [rec_listsum2 vl n, Cn vl (constn n) [id vl 0]]
+ in Cn vl rec_add [rec_strt' vl n, Cn vl rec_minus
+ [Cn vl rec_power [Cn vl (constn 2) [id vl 0], Cn vl rec_add
+ [id vl (n), rec_dbound]],
+ Cn vl rec_power [Cn vl (constn 2) [id vl 0], rec_dbound]]])"
+
+declare strt'.simps[simp del] rec_strt'.simps[simp del]
+
+lemma strt'_lemma: "\<lbrakk>length xs = vl; n \<le> vl\<rbrakk> \<Longrightarrow>
+ rec_exec (rec_strt' vl n) xs = strt' xs n"
+apply(induct n)
+apply(simp_all add: rec_exec.simps rec_strt'.simps strt'.simps
+ Let_def power_lemma listsum2_lemma)
+done
+
+text {*
+ @{text "strt"} corresponds to the @{text "strt"} function on page 90 of B book, but
+ this definition generalises the original one to deal with multiple input arguments.
+ *}
+fun strt :: "nat list \<Rightarrow> nat"
+ where
+ "strt xs = (let ys = map Suc xs in
+ strt' ys (length ys))"
+
+fun rec_map :: "recf \<Rightarrow> nat \<Rightarrow> recf list"
+ where
+ "rec_map rf vl = map (\<lambda> i. Cn vl rf [id vl (i)]) [0..<vl]"
+
+text {*
+ @{text "rec_strt"} is the recursive function used to implement @{text "strt"}.
+ *}
+fun rec_strt :: "nat \<Rightarrow> recf"
+ where
+ "rec_strt vl = Cn vl (rec_strt' vl vl) (rec_map s vl)"
+
+lemma map_s_lemma: "length xs = vl \<Longrightarrow>
+ map ((\<lambda>a. rec_exec a xs) \<circ> (\<lambda>i. Cn vl s [recf.id vl i]))
+ [0..<vl]
+ = map Suc xs"
+apply(induct vl arbitrary: xs, simp, auto simp: rec_exec.simps)
+apply(subgoal_tac "\<exists> ys y. xs = ys @ [y]", auto)
+proof -
+ fix ys y
+ assume ind: "\<And>xs. length xs = length (ys::nat list) \<Longrightarrow>
+ map ((\<lambda>a. rec_exec a xs) \<circ> (\<lambda>i. Cn (length ys) s
+ [recf.id (length ys) (i)])) [0..<length ys] = map Suc xs"
+ show
+ "map ((\<lambda>a. rec_exec a (ys @ [y])) \<circ> (\<lambda>i. Cn (Suc (length ys)) s
+ [recf.id (Suc (length ys)) (i)])) [0..<length ys] = map Suc ys"
+ proof -
+ have "map ((\<lambda>a. rec_exec a ys) \<circ> (\<lambda>i. Cn (length ys) s
+ [recf.id (length ys) (i)])) [0..<length ys] = map Suc ys"
+ apply(rule_tac ind, simp)
+ done
+ moreover have
+ "map ((\<lambda>a. rec_exec a (ys @ [y])) \<circ> (\<lambda>i. Cn (Suc (length ys)) s
+ [recf.id (Suc (length ys)) (i)])) [0..<length ys]
+ = map ((\<lambda>a. rec_exec a ys) \<circ> (\<lambda>i. Cn (length ys) s
+ [recf.id (length ys) (i)])) [0..<length ys]"
+ apply(rule_tac map_ext, auto simp: rec_exec.simps nth_append)
+ done
+ ultimately show "?thesis"
+ by simp
+ qed
+next
+ fix vl xs
+ assume "length xs = Suc vl"
+ thus "\<exists>ys y. xs = ys @ [y]"
+ apply(rule_tac x = "butlast xs" in exI, rule_tac x = "last xs" in exI)
+ apply(subgoal_tac "xs \<noteq> []", auto)
+ done
+qed
+
+text {*
+ The correctness of @{text "rec_strt"}.
+ *}
+lemma strt_lemma: "length xs = vl \<Longrightarrow>
+ rec_exec (rec_strt vl) xs = strt xs"
+apply(simp add: strt.simps rec_exec.simps strt'_lemma)
+apply(subgoal_tac "(map ((\<lambda>a. rec_exec a xs) \<circ> (\<lambda>i. Cn vl s [recf.id vl (i)])) [0..<vl])
+ = map Suc xs", auto)
+apply(rule map_s_lemma, simp)
+done
+
+text {*
+ The @{text "scan"} function on page 90 of B book.
+ *}
+fun scan :: "nat \<Rightarrow> nat"
+ where
+ "scan r = r mod 2"
+
+text {*
+ @{text "rec_scan"} is the implemention of @{text "scan"}.
+ *}
+definition rec_scan :: "recf"
+ where "rec_scan = Cn 1 rec_mod [id 1 0, constn 2]"
+
+text {*
+ The correctness of @{text "scan"}.
+ *}
+lemma scan_lemma: "rec_exec rec_scan [r] = r mod 2"
+ by(simp add: rec_exec.simps rec_scan_def mod_lemma)
+
+fun newleft0 :: "nat list \<Rightarrow> nat"
+ where
+ "newleft0 [p, r] = p"
+
+definition rec_newleft0 :: "recf"
+ where
+ "rec_newleft0 = id 2 0"
+
+fun newrgt0 :: "nat list \<Rightarrow> nat"
+ where
+ "newrgt0 [p, r] = r - scan r"
+
+definition rec_newrgt0 :: "recf"
+ where
+ "rec_newrgt0 = Cn 2 rec_minus [id 2 1, Cn 2 rec_scan [id 2 1]]"
+
+(*newleft1, newrgt1: left rgt number after execute on step*)
+fun newleft1 :: "nat list \<Rightarrow> nat"
+ where
+ "newleft1 [p, r] = p"
+
+definition rec_newleft1 :: "recf"
+ where
+ "rec_newleft1 = id 2 0"
+
+fun newrgt1 :: "nat list \<Rightarrow> nat"
+ where
+ "newrgt1 [p, r] = r + 1 - scan r"
+
+definition rec_newrgt1 :: "recf"
+ where
+ "rec_newrgt1 =
+ Cn 2 rec_minus [Cn 2 rec_add [id 2 1, Cn 2 (constn 1) [id 2 0]],
+ Cn 2 rec_scan [id 2 1]]"
+
+fun newleft2 :: "nat list \<Rightarrow> nat"
+ where
+ "newleft2 [p, r] = p div 2"
+
+definition rec_newleft2 :: "recf"
+ where
+ "rec_newleft2 = Cn 2 rec_quo [id 2 0, Cn 2 (constn 2) [id 2 0]]"
+
+fun newrgt2 :: "nat list \<Rightarrow> nat"
+ where
+ "newrgt2 [p, r] = 2 * r + p mod 2"
+
+definition rec_newrgt2 :: "recf"
+ where
+ "rec_newrgt2 =
+ Cn 2 rec_add [Cn 2 rec_mult [Cn 2 (constn 2) [id 2 0], id 2 1],
+ Cn 2 rec_mod [id 2 0, Cn 2 (constn 2) [id 2 0]]]"
+
+fun newleft3 :: "nat list \<Rightarrow> nat"
+ where
+ "newleft3 [p, r] = 2 * p + r mod 2"
+
+definition rec_newleft3 :: "recf"
+ where
+ "rec_newleft3 =
+ Cn 2 rec_add [Cn 2 rec_mult [Cn 2 (constn 2) [id 2 0], id 2 0],
+ Cn 2 rec_mod [id 2 1, Cn 2 (constn 2) [id 2 0]]]"
+
+fun newrgt3 :: "nat list \<Rightarrow> nat"
+ where
+ "newrgt3 [p, r] = r div 2"
+
+definition rec_newrgt3 :: "recf"
+ where
+ "rec_newrgt3 = Cn 2 rec_quo [id 2 1, Cn 2 (constn 2) [id 2 0]]"
+
+text {*
+ The @{text "new_left"} function on page 91 of B book.
+ *}
+fun newleft :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "newleft p r a = (if a = 0 \<or> a = 1 then newleft0 [p, r]
+ else if a = 2 then newleft2 [p, r]
+ else if a = 3 then newleft3 [p, r]
+ else p)"
+
+text {*
+ @{text "rec_newleft"} is the recursive function used to
+ implement @{text "newleft"}.
+ *}
+definition rec_newleft :: "recf"
+ where
+ "rec_newleft =
+ (let g0 =
+ Cn 3 rec_newleft0 [id 3 0, id 3 1] in
+ let g1 = Cn 3 rec_newleft2 [id 3 0, id 3 1] in
+ let g2 = Cn 3 rec_newleft3 [id 3 0, id 3 1] in
+ let g3 = id 3 0 in
+ let r0 = Cn 3 rec_disj
+ [Cn 3 rec_eq [id 3 2, Cn 3 (constn 0) [id 3 0]],
+ Cn 3 rec_eq [id 3 2, Cn 3 (constn 1) [id 3 0]]] in
+ let r1 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 2) [id 3 0]] in
+ let r2 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 3) [id 3 0]] in
+ let r3 = Cn 3 rec_less [Cn 3 (constn 3) [id 3 0], id 3 2] in
+ let gs = [g0, g1, g2, g3] in
+ let rs = [r0, r1, r2, r3] in
+ rec_embranch (zip gs rs))"
+
+declare newleft.simps[simp del]
+
+
+lemma Suc_Suc_Suc_Suc_induct:
+ "\<lbrakk>i < Suc (Suc (Suc (Suc 0))); i = 0 \<Longrightarrow> P i;
+ i = 1 \<Longrightarrow> P i; i =2 \<Longrightarrow> P i;
+ i =3 \<Longrightarrow> P i\<rbrakk> \<Longrightarrow> P i"
+apply(case_tac i, simp, case_tac nat, simp,
+ case_tac nata, simp, case_tac natb, simp, simp)
+done
+
+declare quo_lemma2[simp] mod_lemma[simp]
+
+text {*
+ The correctness of @{text "rec_newleft"}.
+ *}
+lemma newleft_lemma:
+ "rec_exec rec_newleft [p, r, a] = newleft p r a"
+proof(simp only: rec_newleft_def Let_def)
+ let ?rgs = "[Cn 3 rec_newleft0 [recf.id 3 0, recf.id 3 1], Cn 3 rec_newleft2
+ [recf.id 3 0, recf.id 3 1], Cn 3 rec_newleft3 [recf.id 3 0, recf.id 3 1], recf.id 3 0]"
+ let ?rrs =
+ "[Cn 3 rec_disj [Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 0)
+ [recf.id 3 0]], Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 1) [recf.id 3 0]]],
+ Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 2) [recf.id 3 0]],
+ Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 3) [recf.id 3 0]],
+ Cn 3 rec_less [Cn 3 (constn 3) [recf.id 3 0], recf.id 3 2]]"
+ thm embranch_lemma
+ have k1: "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a]
+ = Embranch (zip (map rec_exec ?rgs) (map (\<lambda>r args. 0 < rec_exec r args) ?rrs)) [p, r, a]"
+ apply(rule_tac embranch_lemma )
+ apply(auto simp: numeral_3_eq_3 numeral_2_eq_2 rec_newleft0_def
+ rec_newleft1_def rec_newleft2_def rec_newleft3_def)+
+ apply(case_tac "a = 0 \<or> a = 1", rule_tac x = 0 in exI)
+ prefer 2
+ apply(case_tac "a = 2", rule_tac x = "Suc 0" in exI)
+ prefer 2
+ apply(case_tac "a = 3", rule_tac x = "2" in exI)
+ prefer 2
+ apply(case_tac "a > 3", rule_tac x = "3" in exI, auto)
+ apply(auto simp: rec_exec.simps)
+ apply(erule_tac [!] Suc_Suc_Suc_Suc_induct, auto simp: rec_exec.simps)
+ done(*
+ have "Embranch (zip (map rec_exec ?rgs) (map (\<lambda>r args. 0 < rec_exec r args) ?rrs)) [p, r, a]
+ = Embranch (zip ?gs ?rs) [p, r, a]"
+ apply(simp add)*)
+ have k2: "Embranch (zip (map rec_exec ?rgs) (map (\<lambda>r args. 0 < rec_exec r args) ?rrs)) [p, r, a] = newleft p r a"
+ apply(simp add: Embranch.simps)
+ apply(simp add: rec_exec.simps)
+ apply(auto simp: newleft.simps rec_newleft0_def rec_exec.simps
+ rec_newleft1_def rec_newleft2_def rec_newleft3_def)
+ done
+ from k1 and k2 show
+ "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a] = newleft p r a"
+ by simp
+qed
+
+text {*
+ The @{text "newrght"} function is one similar to @{text "newleft"}, but used to
+ compute the right number.
+ *}
+fun newrght :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "newrght p r a = (if a = 0 then newrgt0 [p, r]
+ else if a = 1 then newrgt1 [p, r]
+ else if a = 2 then newrgt2 [p, r]
+ else if a = 3 then newrgt3 [p, r]
+ else r)"
+
+text {*
+ @{text "rec_newrght"} is the recursive function used to implement
+ @{text "newrgth"}.
+ *}
+definition rec_newrght :: "recf"
+ where
+ "rec_newrght =
+ (let g0 = Cn 3 rec_newrgt0 [id 3 0, id 3 1] in
+ let g1 = Cn 3 rec_newrgt1 [id 3 0, id 3 1] in
+ let g2 = Cn 3 rec_newrgt2 [id 3 0, id 3 1] in
+ let g3 = Cn 3 rec_newrgt3 [id 3 0, id 3 1] in
+ let g4 = id 3 1 in
+ let r0 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 0) [id 3 0]] in
+ let r1 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 1) [id 3 0]] in
+ let r2 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 2) [id 3 0]] in
+ let r3 = Cn 3 rec_eq [id 3 2, Cn 3 (constn 3) [id 3 0]] in
+ let r4 = Cn 3 rec_less [Cn 3 (constn 3) [id 3 0], id 3 2] in
+ let gs = [g0, g1, g2, g3, g4] in
+ let rs = [r0, r1, r2, r3, r4] in
+ rec_embranch (zip gs rs))"
+declare newrght.simps[simp del]
+
+lemma numeral_4_eq_4: "4 = Suc 3"
+by auto
+
+lemma Suc_5_induct:
+ "\<lbrakk>i < Suc (Suc (Suc (Suc (Suc 0)))); i = 0 \<Longrightarrow> P 0;
+ i = 1 \<Longrightarrow> P 1; i = 2 \<Longrightarrow> P 2; i = 3 \<Longrightarrow> P 3; i = 4 \<Longrightarrow> P 4\<rbrakk> \<Longrightarrow> P i"
+apply(case_tac i, auto)
+apply(case_tac nat, auto)
+apply(case_tac nata, auto simp: numeral_2_eq_2)
+apply(case_tac nat, auto simp: numeral_3_eq_3 numeral_4_eq_4)
+done
+
+lemma [intro]: "primerec rec_scan (Suc 0)"
+apply(auto simp: rec_scan_def, auto)
+done
+
+text {*
+ The correctness of @{text "rec_newrght"}.
+ *}
+lemma newrght_lemma: "rec_exec rec_newrght [p, r, a] = newrght p r a"
+proof(simp only: rec_newrght_def Let_def)
+ let ?gs' = "[newrgt0, newrgt1, newrgt2, newrgt3, \<lambda> zs. zs ! 1]"
+ let ?r0 = "\<lambda> zs. zs ! 2 = 0"
+ let ?r1 = "\<lambda> zs. zs ! 2 = 1"
+ let ?r2 = "\<lambda> zs. zs ! 2 = 2"
+ let ?r3 = "\<lambda> zs. zs ! 2 = 3"
+ let ?r4 = "\<lambda> zs. zs ! 2 > 3"
+ let ?gs = "map (\<lambda> g. (\<lambda> zs. g [zs ! 0, zs ! 1])) ?gs'"
+ let ?rs = "[?r0, ?r1, ?r2, ?r3, ?r4]"
+ let ?rgs =
+ "[Cn 3 rec_newrgt0 [recf.id 3 0, recf.id 3 1],
+ Cn 3 rec_newrgt1 [recf.id 3 0, recf.id 3 1],
+ Cn 3 rec_newrgt2 [recf.id 3 0, recf.id 3 1],
+ Cn 3 rec_newrgt3 [recf.id 3 0, recf.id 3 1], recf.id 3 1]"
+ let ?rrs =
+ "[Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 0) [recf.id 3 0]], Cn 3 rec_eq [recf.id 3 2,
+ Cn 3 (constn 1) [recf.id 3 0]], Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 2) [recf.id 3 0]],
+ Cn 3 rec_eq [recf.id 3 2, Cn 3 (constn 3) [recf.id 3 0]],
+ Cn 3 rec_less [Cn 3 (constn 3) [recf.id 3 0], recf.id 3 2]]"
+
+ have k1: "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a]
+ = Embranch (zip (map rec_exec ?rgs) (map (\<lambda>r args. 0 < rec_exec r args) ?rrs)) [p, r, a]"
+ apply(rule_tac embranch_lemma)
+ apply(auto simp: numeral_3_eq_3 numeral_2_eq_2 rec_newrgt0_def
+ rec_newrgt1_def rec_newrgt2_def rec_newrgt3_def)+
+ apply(case_tac "a = 0", rule_tac x = 0 in exI)
+ prefer 2
+ apply(case_tac "a = 1", rule_tac x = "Suc 0" in exI)
+ prefer 2
+ apply(case_tac "a = 2", rule_tac x = "2" in exI)
+ prefer 2
+ apply(case_tac "a = 3", rule_tac x = "3" in exI)
+ prefer 2
+ apply(case_tac "a > 3", rule_tac x = "4" in exI, auto simp: rec_exec.simps)
+ apply(erule_tac [!] Suc_5_induct, auto simp: rec_exec.simps)
+ done
+ have k2: "Embranch (zip (map rec_exec ?rgs)
+ (map (\<lambda>r args. 0 < rec_exec r args) ?rrs)) [p, r, a] = newrght p r a"
+ apply(auto simp:Embranch.simps rec_exec.simps)
+ apply(auto simp: newrght.simps rec_newrgt3_def rec_newrgt2_def
+ rec_newrgt1_def rec_newrgt0_def rec_exec.simps
+ scan_lemma)
+ done
+ from k1 and k2 show
+ "rec_exec (rec_embranch (zip ?rgs ?rrs)) [p, r, a] =
+ newrght p r a" by simp
+qed
+
+declare Entry.simps[simp del]
+
+text {*
+ The @{text "actn"} function given on page 92 of B book, which is used to
+ fetch Turing Machine intructions.
+ In @{text "actn m q r"}, @{text "m"} is the Godel coding of a Turing Machine,
+ @{text "q"} is the current state of Turing Machine, @{text "r"} is the
+ right number of Turing Machine tape.
+ *}
+fun actn :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "actn m q r = (if q \<noteq> 0 then Entry m (4*(q - 1) + 2 * scan r)
+ else 4)"
+
+text {*
+ @{text "rec_actn"} is the recursive function used to implement @{text "actn"}
+ *}
+definition rec_actn :: "recf"
+ where
+ "rec_actn =
+ Cn 3 rec_add [Cn 3 rec_mult
+ [Cn 3 rec_entry [id 3 0, Cn 3 rec_add [Cn 3 rec_mult
+ [Cn 3 (constn 4) [id 3 0],
+ Cn 3 rec_minus [id 3 1, Cn 3 (constn 1) [id 3 0]]],
+ Cn 3 rec_mult [Cn 3 (constn 2) [id 3 0],
+ Cn 3 rec_scan [id 3 2]]]],
+ Cn 3 rec_noteq [id 3 1, Cn 3 (constn 0) [id 3 0]]],
+ Cn 3 rec_mult [Cn 3 (constn 4) [id 3 0],
+ Cn 3 rec_eq [id 3 1, Cn 3 (constn 0) [id 3 0]]]] "
+
+text {*
+ The correctness of @{text "actn"}.
+ *}
+lemma actn_lemma: "rec_exec rec_actn [m, q, r] = actn m q r"
+ by(auto simp: rec_actn_def rec_exec.simps entry_lemma scan_lemma)
+
+(* Stop point *)
+
+fun newstat :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "newstat m q r = (if q \<noteq> 0 then Entry m (4*(q - 1) + 2*scan r + 1)
+ else 0)"
+
+definition rec_newstat :: "recf"
+ where
+ "rec_newstat = Cn 3 rec_add
+ [Cn 3 rec_mult [Cn 3 rec_entry [id 3 0,
+ Cn 3 rec_add [Cn 3 rec_mult [Cn 3 (constn 4) [id 3 0],
+ Cn 3 rec_minus [id 3 1, Cn 3 (constn 1) [id 3 0]]],
+ Cn 3 rec_add [Cn 3 rec_mult [Cn 3 (constn 2) [id 3 0],
+ Cn 3 rec_scan [id 3 2]], Cn 3 (constn 1) [id 3 0]]]],
+ Cn 3 rec_noteq [id 3 1, Cn 3 (constn 0) [id 3 0]]],
+ Cn 3 rec_mult [Cn 3 (constn 0) [id 3 0],
+ Cn 3 rec_eq [id 3 1, Cn 3 (constn 0) [id 3 0]]]] "
+
+lemma newstat_lemma: "rec_exec rec_newstat [m, q, r] = newstat m q r"
+by(auto simp: rec_exec.simps entry_lemma scan_lemma rec_newstat_def)
+
+declare newstat.simps[simp del] actn.simps[simp del]
+
+text{*code the configuration*}
+
+fun trpl :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "trpl p q r = (Pi 0)^p * (Pi 1)^q * (Pi 2)^r"
+
+definition rec_trpl :: "recf"
+ where
+ "rec_trpl = Cn 3 rec_mult [Cn 3 rec_mult
+ [Cn 3 rec_power [Cn 3 (constn (Pi 0)) [id 3 0], id 3 0],
+ Cn 3 rec_power [Cn 3 (constn (Pi 1)) [id 3 0], id 3 1]],
+ Cn 3 rec_power [Cn 3 (constn (Pi 2)) [id 3 0], id 3 2]]"
+declare trpl.simps[simp del]
+lemma trpl_lemma: "rec_exec rec_trpl [p, q, r] = trpl p q r"
+by(auto simp: rec_trpl_def rec_exec.simps power_lemma trpl.simps)
+
+text{*left, stat, rght: decode func*}
+fun left :: "nat \<Rightarrow> nat"
+ where
+ "left c = lo c (Pi 0)"
+
+fun stat :: "nat \<Rightarrow> nat"
+ where
+ "stat c = lo c (Pi 1)"
+
+fun rght :: "nat \<Rightarrow> nat"
+ where
+ "rght c = lo c (Pi 2)"
+
+thm Prime.simps
+
+fun inpt :: "nat \<Rightarrow> nat list \<Rightarrow> nat"
+ where
+ "inpt m xs = trpl 0 1 (strt xs)"
+
+fun newconf :: "nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "newconf m c = trpl (newleft (left c) (rght c)
+ (actn m (stat c) (rght c)))
+ (newstat m (stat c) (rght c))
+ (newrght (left c) (rght c)
+ (actn m (stat c) (rght c)))"
+
+declare left.simps[simp del] stat.simps[simp del] rght.simps[simp del]
+ inpt.simps[simp del] newconf.simps[simp del]
+
+definition rec_left :: "recf"
+ where
+ "rec_left = Cn 1 rec_lo [id 1 0, constn (Pi 0)]"
+
+definition rec_right :: "recf"
+ where
+ "rec_right = Cn 1 rec_lo [id 1 0, constn (Pi 2)]"
+
+definition rec_stat :: "recf"
+ where
+ "rec_stat = Cn 1 rec_lo [id 1 0, constn (Pi 1)]"
+
+definition rec_inpt :: "nat \<Rightarrow> recf"
+ where
+ "rec_inpt vl = Cn vl rec_trpl
+ [Cn vl (constn 0) [id vl 0],
+ Cn vl (constn 1) [id vl 0],
+ Cn vl (rec_strt (vl - 1))
+ (map (\<lambda> i. id vl (i)) [1..<vl])]"
+
+lemma left_lemma: "rec_exec rec_left [c] = left c"
+by(simp add: rec_exec.simps rec_left_def left.simps lo_lemma)
+
+lemma right_lemma: "rec_exec rec_right [c] = rght c"
+by(simp add: rec_exec.simps rec_right_def rght.simps lo_lemma)
+
+lemma stat_lemma: "rec_exec rec_stat [c] = stat c"
+by(simp add: rec_exec.simps rec_stat_def stat.simps lo_lemma)
+
+declare rec_strt.simps[simp del] strt.simps[simp del]
+
+lemma map_cons_eq:
+ "(map ((\<lambda>a. rec_exec a (m # xs)) \<circ>
+ (\<lambda>i. recf.id (Suc (length xs)) (i)))
+ [Suc 0..<Suc (length xs)])
+ = map (\<lambda> i. xs ! (i - 1)) [Suc 0..<Suc (length xs)]"
+apply(rule map_ext, auto)
+apply(auto simp: rec_exec.simps nth_append nth_Cons split: nat.split)
+done
+
+lemma list_map_eq:
+ "vl = length (xs::nat list) \<Longrightarrow> map (\<lambda> i. xs ! (i - 1))
+ [Suc 0..<Suc vl] = xs"
+apply(induct vl arbitrary: xs, simp)
+apply(subgoal_tac "\<exists> ys y. xs = ys @ [y]", auto)
+proof -
+ fix ys y
+ assume ind:
+ "\<And>xs. length (ys::nat list) = length (xs::nat list) \<Longrightarrow>
+ map (\<lambda>i. xs ! (i - Suc 0)) [Suc 0..<length xs] @
+ [xs ! (length xs - Suc 0)] = xs"
+ and h: "Suc 0 \<le> length (ys::nat list)"
+ have "map (\<lambda>i. ys ! (i - Suc 0)) [Suc 0..<length ys] @
+ [ys ! (length ys - Suc 0)] = ys"
+ apply(rule_tac ind, simp)
+ done
+ moreover have
+ "map (\<lambda>i. (ys @ [y]) ! (i - Suc 0)) [Suc 0..<length ys]
+ = map (\<lambda>i. ys ! (i - Suc 0)) [Suc 0..<length ys]"
+ apply(rule map_ext)
+ using h
+ apply(auto simp: nth_append)
+ done
+ ultimately show "map (\<lambda>i. (ys @ [y]) ! (i - Suc 0))
+ [Suc 0..<length ys] @ [(ys @ [y]) ! (length ys - Suc 0)] = ys"
+ apply(simp del: map_eq_conv add: nth_append, auto)
+ using h
+ apply(simp)
+ done
+next
+ fix vl xs
+ assume "Suc vl = length (xs::nat list)"
+ thus "\<exists>ys y. xs = ys @ [y]"
+ apply(rule_tac x = "butlast xs" in exI,
+ rule_tac x = "last xs" in exI)
+ apply(case_tac "xs \<noteq> []", auto)
+ done
+qed
+
+lemma [elim]:
+ "Suc 0 \<le> length xs \<Longrightarrow>
+ (map ((\<lambda>a. rec_exec a (m # xs)) \<circ>
+ (\<lambda>i. recf.id (Suc (length xs)) (i)))
+ [Suc 0..<length xs] @ [(m # xs) ! length xs]) = xs"
+using map_cons_eq[of m xs]
+apply(simp del: map_eq_conv add: rec_exec.simps)
+using list_map_eq[of "length xs" xs]
+apply(simp)
+done
+
+
+lemma inpt_lemma:
+ "\<lbrakk>Suc (length xs) = vl\<rbrakk> \<Longrightarrow>
+ rec_exec (rec_inpt vl) (m # xs) = inpt m xs"
+apply(auto simp: rec_exec.simps rec_inpt_def
+ trpl_lemma inpt.simps strt_lemma)
+apply(subgoal_tac
+ "(map ((\<lambda>a. rec_exec a (m # xs)) \<circ>
+ (\<lambda>i. recf.id (Suc (length xs)) (i)))
+ [Suc 0..<length xs] @ [(m # xs) ! length xs]) = xs", simp)
+apply(auto, case_tac xs, auto)
+done
+
+definition rec_newconf:: "recf"
+ where
+ "rec_newconf =
+ Cn 2 rec_trpl
+ [Cn 2 rec_newleft [Cn 2 rec_left [id 2 1],
+ Cn 2 rec_right [id 2 1],
+ Cn 2 rec_actn [id 2 0,
+ Cn 2 rec_stat [id 2 1],
+ Cn 2 rec_right [id 2 1]]],
+ Cn 2 rec_newstat [id 2 0,
+ Cn 2 rec_stat [id 2 1],
+ Cn 2 rec_right [id 2 1]],
+ Cn 2 rec_newrght [Cn 2 rec_left [id 2 1],
+ Cn 2 rec_right [id 2 1],
+ Cn 2 rec_actn [id 2 0,
+ Cn 2 rec_stat [id 2 1],
+ Cn 2 rec_right [id 2 1]]]]"
+
+lemma newconf_lemma: "rec_exec rec_newconf [m ,c] = newconf m c"
+by(auto simp: rec_newconf_def rec_exec.simps
+ trpl_lemma newleft_lemma left_lemma
+ right_lemma stat_lemma newrght_lemma actn_lemma
+ newstat_lemma stat_lemma newconf.simps)
+
+declare newconf_lemma[simp]
+
+text {*
+ @{text "conf m r k"} computes the TM configuration after @{text "k"} steps of execution
+ of TM coded as @{text "m"} starting from the initial configuration where the left number equals @{text "0"},
+ right number equals @{text "r"}.
+ *}
+fun conf :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "conf m r 0 = trpl 0 (Suc 0) r"
+| "conf m r (Suc t) = newconf m (conf m r t)"
+
+declare conf.simps[simp del]
+
+text {*
+ @{text "conf"} is implemented by the following recursive function @{text "rec_conf"}.
+ *}
+definition rec_conf :: "recf"
+ where
+ "rec_conf = Pr 2 (Cn 2 rec_trpl [Cn 2 (constn 0) [id 2 0], Cn 2 (constn (Suc 0)) [id 2 0], id 2 1])
+ (Cn 4 rec_newconf [id 4 0, id 4 3])"
+
+lemma conf_step:
+ "rec_exec rec_conf [m, r, Suc t] =
+ rec_exec rec_newconf [m, rec_exec rec_conf [m, r, t]]"
+proof -
+ have "rec_exec rec_conf ([m, r] @ [Suc t]) =
+ rec_exec rec_newconf [m, rec_exec rec_conf [m, r, t]]"
+ by(simp only: rec_conf_def rec_pr_Suc_simp_rewrite,
+ simp add: rec_exec.simps)
+ thus "rec_exec rec_conf [m, r, Suc t] =
+ rec_exec rec_newconf [m, rec_exec rec_conf [m, r, t]]"
+ by simp
+qed
+
+text {*
+ The correctness of @{text "rec_conf"}.
+ *}
+lemma conf_lemma:
+ "rec_exec rec_conf [m, r, t] = conf m r t"
+apply(induct t)
+apply(simp add: rec_conf_def rec_exec.simps conf.simps inpt_lemma trpl_lemma)
+apply(simp add: conf_step conf.simps)
+done
+
+text {*
+ @{text "NSTD c"} returns true if the configureation coded by @{text "c"} is no a stardard
+ final configuration.
+ *}
+fun NSTD :: "nat \<Rightarrow> bool"
+ where
+ "NSTD c = (stat c \<noteq> 0 \<or> left c \<noteq> 0 \<or>
+ rght c \<noteq> 2^(lg (rght c + 1) 2) - 1 \<or> rght c = 0)"
+
+text {*
+ @{text "rec_NSTD"} is the recursive function implementing @{text "NSTD"}.
+ *}
+definition rec_NSTD :: "recf"
+ where
+ "rec_NSTD =
+ Cn 1 rec_disj [
+ Cn 1 rec_disj [
+ Cn 1 rec_disj
+ [Cn 1 rec_noteq [rec_stat, constn 0],
+ Cn 1 rec_noteq [rec_left, constn 0]] ,
+ Cn 1 rec_noteq [rec_right,
+ Cn 1 rec_minus [Cn 1 rec_power
+ [constn 2, Cn 1 rec_lg
+ [Cn 1 rec_add
+ [rec_right, constn 1],
+ constn 2]], constn 1]]],
+ Cn 1 rec_eq [rec_right, constn 0]]"
+
+lemma NSTD_lemma1: "rec_exec rec_NSTD [c] = Suc 0 \<or>
+ rec_exec rec_NSTD [c] = 0"
+by(simp add: rec_exec.simps rec_NSTD_def)
+
+declare NSTD.simps[simp del]
+lemma NSTD_lemma2': "(rec_exec rec_NSTD [c] = Suc 0) \<Longrightarrow> NSTD c"
+apply(simp add: rec_exec.simps rec_NSTD_def stat_lemma left_lemma
+ lg_lemma right_lemma power_lemma NSTD.simps eq_lemma)
+apply(auto)
+apply(case_tac "0 < left c", simp, simp)
+done
+
+lemma NSTD_lemma2'':
+ "NSTD c \<Longrightarrow> (rec_exec rec_NSTD [c] = Suc 0)"
+apply(simp add: rec_exec.simps rec_NSTD_def stat_lemma
+ left_lemma lg_lemma right_lemma power_lemma NSTD.simps)
+apply(auto split: if_splits)
+done
+
+text {*
+ The correctness of @{text "NSTD"}.
+ *}
+lemma NSTD_lemma2: "(rec_exec rec_NSTD [c] = Suc 0) = NSTD c"
+using NSTD_lemma1
+apply(auto intro: NSTD_lemma2' NSTD_lemma2'')
+done
+
+fun nstd :: "nat \<Rightarrow> nat"
+ where
+ "nstd c = (if NSTD c then 1 else 0)"
+
+lemma nstd_lemma: "rec_exec rec_NSTD [c] = nstd c"
+using NSTD_lemma1
+apply(simp add: NSTD_lemma2, auto)
+done
+
+text {* GGGGGGGGGGGGGGGGGGGGGGG *}
+
+text{*
+ @{text "nonstep m r t"} means afer @{text "t"} steps of execution, the TM coded by @{text "m"}
+ is not at a stardard final configuration.
+ *}
+fun nonstop :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "nonstop m r t = nstd (conf m r t)"
+
+text {*
+ @{text "rec_nonstop"} is the recursive function implementing @{text "nonstop"}.
+ *}
+definition rec_nonstop :: "recf"
+ where
+ "rec_nonstop = Cn 3 rec_NSTD [rec_conf]"
+
+text {*
+ The correctness of @{text "rec_nonstop"}.
+ *}
+lemma nonstop_lemma:
+ "rec_exec rec_nonstop [m, r, t] = nonstop m r t"
+apply(simp add: rec_exec.simps rec_nonstop_def nstd_lemma conf_lemma)
+done
+
+text{*
+ @{text "rec_halt"} is the recursive function calculating the steps a TM needs to execute before
+ to reach a stardard final configuration. This recursive function is the only one
+ using @{text "Mn"} combinator. So it is the only non-primitive recursive function
+ needs to be used in the construction of the universal function @{text "F"}.
+ *}
+
+definition rec_halt :: "recf"
+ where
+ "rec_halt = Mn (Suc (Suc 0)) (rec_nonstop)"
+
+declare nonstop.simps[simp del]
+
+(* when mn, use rec_calc_rel instead of rec_exec*)
+
+lemma primerec_not0: "primerec f n \<Longrightarrow> n > 0"
+by(induct f n rule: primerec.induct, auto)
+
+lemma [elim]: "primerec f 0 \<Longrightarrow> RR"
+apply(drule_tac primerec_not0, simp)
+done
+
+lemma [simp]: "length xs = Suc n \<Longrightarrow> length (butlast xs) = n"
+apply(subgoal_tac "\<exists> y ys. xs = ys @ [y]", auto)
+apply(rule_tac x = "last xs" in exI)
+apply(rule_tac x = "butlast xs" in exI)
+apply(case_tac "xs = []", auto)
+done
+
+text {*
+ The lemma relates the interpreter of primitive fucntions with
+ the calculation relation of general recursive functions.
+ *}
+lemma prime_rel_exec_eq: "primerec r (length xs)
+ \<Longrightarrow> rec_calc_rel r xs rs = (rec_exec r xs = rs)"
+proof(induct r xs arbitrary: rs rule: rec_exec.induct, simp_all)
+ fix xs rs
+ assume "primerec z (length (xs::nat list))"
+ hence "length xs = Suc 0" by(erule_tac prime_z_reverse, simp)
+ thus "rec_calc_rel z xs rs = (rec_exec z xs = rs)"
+ apply(case_tac xs, simp, auto)
+ apply(erule_tac calc_z_reverse, simp add: rec_exec.simps)
+ apply(simp add: rec_exec.simps, rule_tac calc_z)
+ done
+next
+ fix xs rs
+ assume "primerec s (length (xs::nat list))"
+ hence "length xs = Suc 0" ..
+ thus "rec_calc_rel s xs rs = (rec_exec s xs = rs)"
+ by(case_tac xs, auto simp: rec_exec.simps intro: calc_s
+ elim: calc_s_reverse)
+next
+ fix m n xs rs
+ assume "primerec (recf.id m n) (length (xs::nat list))"
+ thus
+ "rec_calc_rel (recf.id m n) xs rs =
+ (rec_exec (recf.id m n) xs = rs)"
+ apply(erule_tac prime_id_reverse)
+ apply(simp add: rec_exec.simps, auto)
+ apply(erule_tac calc_id_reverse, simp)
+ apply(rule_tac calc_id, auto)
+ done
+next
+ fix n f gs xs rs
+ assume ind1:
+ "\<And>x rs. \<lbrakk>x \<in> set gs; primerec x (length xs)\<rbrakk> \<Longrightarrow>
+ rec_calc_rel x xs rs = (rec_exec x xs = rs)"
+ and ind2:
+ "\<And>x rs. \<lbrakk>x = map (\<lambda>a. rec_exec a xs) gs;
+ primerec f (length gs)\<rbrakk> \<Longrightarrow>
+ rec_calc_rel f (map (\<lambda>a. rec_exec a xs) gs) rs =
+ (rec_exec f (map (\<lambda>a. rec_exec a xs) gs) = rs)"
+ and h: "primerec (Cn n f gs) (length xs)"
+ show "rec_calc_rel (Cn n f gs) xs rs =
+ (rec_exec (Cn n f gs) xs = rs)"
+ proof(auto simp: rec_exec.simps, erule_tac calc_cn_reverse, auto)
+ fix ys
+ assume g1:"\<forall>k<length gs. rec_calc_rel (gs ! k) xs (ys ! k)"
+ and g2: "length ys = length gs"
+ and g3: "rec_calc_rel f ys rs"
+ have "rec_calc_rel f (map (\<lambda>a. rec_exec a xs) gs) rs =
+ (rec_exec f (map (\<lambda>a. rec_exec a xs) gs) = rs)"
+ apply(rule_tac ind2, auto)
+ using h
+ apply(erule_tac prime_cn_reverse, simp)
+ done
+ moreover have "ys = (map (\<lambda>a. rec_exec a xs) gs)"
+ proof(rule_tac nth_equalityI, auto simp: g2)
+ fix i
+ assume "i < length gs" thus "ys ! i = rec_exec (gs!i) xs"
+ using ind1[of "gs ! i" "ys ! i"] g1 h
+ apply(erule_tac prime_cn_reverse, simp)
+ done
+ qed
+ ultimately show "rec_exec f (map (\<lambda>a. rec_exec a xs) gs) = rs"
+ using g3
+ by(simp)
+ next
+ from h show
+ "rec_calc_rel (Cn n f gs) xs
+ (rec_exec f (map (\<lambda>a. rec_exec a xs) gs))"
+ apply(rule_tac rs = "(map (\<lambda>a. rec_exec a xs) gs)" in calc_cn,
+ auto)
+ apply(erule_tac [!] prime_cn_reverse, auto)
+ proof -
+ fix k
+ assume "k < length gs" "primerec f (length gs)"
+ "\<forall>i<length gs. primerec (gs ! i) (length xs)"
+ thus "rec_calc_rel (gs ! k) xs (rec_exec (gs ! k) xs)"
+ using ind1[of "gs!k" "(rec_exec (gs ! k) xs)"]
+ by(simp)
+ next
+ assume "primerec f (length gs)"
+ "\<forall>i<length gs. primerec (gs ! i) (length xs)"
+ thus "rec_calc_rel f (map (\<lambda>a. rec_exec a xs) gs)
+ (rec_exec f (map (\<lambda>a. rec_exec a xs) gs))"
+ using ind2[of "(map (\<lambda>a. rec_exec a xs) gs)"
+ "(rec_exec f (map (\<lambda>a. rec_exec a xs) gs))"]
+ by simp
+ qed
+ qed
+next
+ fix n f g xs rs
+ assume ind1:
+ "\<And>rs. \<lbrakk>last xs = 0; primerec f (length xs - Suc 0)\<rbrakk>
+ \<Longrightarrow> rec_calc_rel f (butlast xs) rs =
+ (rec_exec f (butlast xs) = rs)"
+ and ind2 :
+ "\<And>rs. \<lbrakk>0 < last xs;
+ primerec (Pr n f g) (Suc (length xs - Suc 0))\<rbrakk> \<Longrightarrow>
+ rec_calc_rel (Pr n f g) (butlast xs @ [last xs - Suc 0]) rs
+ = (rec_exec (Pr n f g) (butlast xs @ [last xs - Suc 0]) = rs)"
+ and ind3:
+ "\<And>rs. \<lbrakk>0 < last xs; primerec g (Suc (Suc (length xs - Suc 0)))\<rbrakk>
+ \<Longrightarrow> rec_calc_rel g (butlast xs @
+ [last xs - Suc 0, rec_exec (Pr n f g)
+ (butlast xs @ [last xs - Suc 0])]) rs =
+ (rec_exec g (butlast xs @ [last xs - Suc 0,
+ rec_exec (Pr n f g)
+ (butlast xs @ [last xs - Suc 0])]) = rs)"
+ and h: "primerec (Pr n f g) (length (xs::nat list))"
+ show "rec_calc_rel (Pr n f g) xs rs = (rec_exec (Pr n f g) xs = rs)"
+ proof(auto)
+ assume "rec_calc_rel (Pr n f g) xs rs"
+ thus "rec_exec (Pr n f g) xs = rs"
+ proof(erule_tac calc_pr_reverse)
+ fix l
+ assume g: "xs = l @ [0]"
+ "rec_calc_rel f l rs"
+ "n = length l"
+ thus "rec_exec (Pr n f g) xs = rs"
+ using ind1[of rs] h
+ apply(simp add: rec_exec.simps,
+ erule_tac prime_pr_reverse, simp)
+ done
+ next
+ fix l y ry
+ assume d:"xs = l @ [Suc y]"
+ "rec_calc_rel (Pr (length l) f g) (l @ [y]) ry"
+ "n = length l"
+ "rec_calc_rel g (l @ [y, ry]) rs"
+ moreover hence "primerec g (Suc (Suc n))" using h
+ proof(erule_tac prime_pr_reverse)
+ assume "primerec g (Suc (Suc n))" "length xs = Suc n"
+ thus "?thesis" by simp
+ qed
+ ultimately show "rec_exec (Pr n f g) xs = rs"
+ apply(simp)
+ using ind3[of rs]
+ apply(simp add: rec_pr_Suc_simp_rewrite)
+ using ind2[of ry] h
+ apply(simp)
+ done
+ qed
+ next
+ show "rec_calc_rel (Pr n f g) xs (rec_exec (Pr n f g) xs)"
+ proof -
+ have "rec_calc_rel (Pr n f g) (butlast xs @ [last xs])
+ (rec_exec (Pr n f g) (butlast xs @ [last xs]))"
+ using h
+ apply(erule_tac prime_pr_reverse, simp)
+ apply(case_tac "last xs", simp)
+ apply(rule_tac calc_pr_zero, simp)
+ using ind1[of "rec_exec (Pr n f g) (butlast xs @ [0])"]
+ apply(simp add: rec_exec.simps, simp, simp, simp)
+ thm calc_pr_ind
+ apply(rule_tac rk = "rec_exec (Pr n f g)
+ (butlast xs@[last xs - Suc 0])" in calc_pr_ind)
+ using ind2[of "rec_exec (Pr n f g)
+ (butlast xs @ [last xs - Suc 0])"] h
+ apply(simp, simp, simp)
+ proof -
+ fix nat
+ assume "length xs = Suc n"
+ "primerec g (Suc (Suc n))"
+ "last xs = Suc nat"
+ thus
+ "rec_calc_rel g (butlast xs @ [nat, rec_exec (Pr n f g)
+ (butlast xs @ [nat])]) (rec_exec (Pr n f g) (butlast xs @ [Suc nat]))"
+ using ind3[of "rec_exec (Pr n f g)
+ (butlast xs @ [Suc nat])"]
+ apply(simp add: rec_exec.simps)
+ done
+ qed
+ thus "rec_calc_rel (Pr n f g) xs (rec_exec (Pr n f g) xs)"
+ using h
+ apply(erule_tac prime_pr_reverse, simp)
+ apply(subgoal_tac "butlast xs @ [last xs] = xs", simp)
+ apply(case_tac xs, simp, simp)
+ done
+ qed
+ qed
+next
+ fix n f xs rs
+ assume "primerec (Mn n f) (length (xs::nat list))"
+ thus "rec_calc_rel (Mn n f) xs rs = (rec_exec (Mn n f) xs = rs)"
+ by(erule_tac prime_mn_reverse)
+qed
+
+declare numeral_2_eq_2[simp] numeral_3_eq_3[simp]
+
+lemma [intro]: "primerec rec_right (Suc 0)"
+apply(simp add: rec_right_def rec_lo_def Let_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [simp]:
+"rec_calc_rel rec_right [r] rs = (rec_exec rec_right [r] = rs)"
+apply(rule_tac prime_rel_exec_eq, auto)
+done
+
+lemma [intro]: "primerec rec_pi (Suc 0)"
+apply(simp add: rec_pi_def rec_dummy_pi_def
+ rec_np_def rec_fac_def rec_prime_def
+ rec_Minr.simps Let_def get_fstn_args.simps
+ arity.simps
+ rec_all.simps rec_sigma.simps rec_accum.simps)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+apply(simp add: rec_dummyfac_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_trpl (Suc (Suc (Suc 0)))"
+apply(simp add: rec_trpl_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro!]: "\<lbrakk>0 < vl; n \<le> vl\<rbrakk> \<Longrightarrow> primerec (rec_listsum2 vl n) vl"
+apply(induct n)
+apply(simp_all add: rec_strt'.simps Let_def rec_listsum2.simps)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [elim]: "\<lbrakk>0 < vl; n \<le> vl\<rbrakk> \<Longrightarrow> primerec (rec_strt' vl n) vl"
+apply(induct n)
+apply(simp_all add: rec_strt'.simps Let_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)
+done
+
+lemma [elim]: "vl > 0 \<Longrightarrow> primerec (rec_strt vl) vl"
+apply(simp add: rec_strt.simps rec_strt'.simps)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [elim]:
+ "i < vl \<Longrightarrow> primerec ((map (\<lambda>i. recf.id (Suc vl) (i))
+ [Suc 0..<vl] @ [recf.id (Suc vl) (vl)]) ! i) (Suc vl)"
+apply(induct i, auto simp: nth_append)
+done
+
+lemma [intro]: "primerec rec_newleft0 ((Suc (Suc 0)))"
+apply(simp add: rec_newleft_def rec_embranch.simps
+ Let_def arity.simps rec_newleft0_def
+ rec_newleft1_def rec_newleft2_def rec_newleft3_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_newleft1 ((Suc (Suc 0)))"
+apply(simp add: rec_newleft_def rec_embranch.simps
+ Let_def arity.simps rec_newleft0_def
+ rec_newleft1_def rec_newleft2_def rec_newleft3_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_newleft2 ((Suc (Suc 0)))"
+apply(simp add: rec_newleft_def rec_embranch.simps
+ Let_def arity.simps rec_newleft0_def
+ rec_newleft1_def rec_newleft2_def rec_newleft3_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_newleft3 ((Suc (Suc 0)))"
+apply(simp add: rec_newleft_def rec_embranch.simps
+ Let_def arity.simps rec_newleft0_def
+ rec_newleft1_def rec_newleft2_def rec_newleft3_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_newleft (Suc (Suc (Suc 0)))"
+apply(simp add: rec_newleft_def rec_embranch.simps
+ Let_def arity.simps)
+apply(rule_tac prime_cn, auto+)
+done
+
+lemma [intro]: "primerec rec_left (Suc 0)"
+apply(simp add: rec_left_def rec_lo_def rec_entry_def Let_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_actn (Suc (Suc (Suc 0)))"
+apply(simp add: rec_left_def rec_lo_def rec_entry_def
+ Let_def rec_actn_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_stat (Suc 0)"
+apply(simp add: rec_left_def rec_lo_def rec_entry_def Let_def
+ rec_actn_def rec_stat_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_newstat (Suc (Suc (Suc 0)))"
+apply(simp add: rec_left_def rec_lo_def rec_entry_def
+ Let_def rec_actn_def rec_stat_def rec_newstat_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_newrght (Suc (Suc (Suc 0)))"
+apply(simp add: rec_newrght_def rec_embranch.simps
+ Let_def arity.simps rec_newrgt0_def
+ rec_newrgt1_def rec_newrgt2_def rec_newrgt3_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_newconf (Suc (Suc 0))"
+apply(simp add: rec_newconf_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "0 < vl \<Longrightarrow> primerec (rec_inpt (Suc vl)) (Suc vl)"
+apply(simp add: rec_inpt_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_conf (Suc (Suc (Suc 0)))"
+apply(simp add: rec_conf_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+apply(auto simp: numeral_4_eq_4)
+done
+
+lemma [simp]:
+ "rec_calc_rel rec_conf [m, r, t] rs =
+ (rec_exec rec_conf [m, r, t] = rs)"
+apply(rule_tac prime_rel_exec_eq, auto)
+done
+
+lemma [intro]: "primerec rec_lg (Suc (Suc 0))"
+apply(simp add: rec_lg_def Let_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma [intro]: "primerec rec_nonstop (Suc (Suc (Suc 0)))"
+apply(simp add: rec_nonstop_def rec_NSTD_def rec_stat_def
+ rec_lo_def Let_def rec_left_def rec_right_def rec_newconf_def
+ rec_newstat_def)
+apply(tactic {* resolve_tac [@{thm prime_cn},
+ @{thm prime_id}, @{thm prime_pr}] 1*}, auto+)+
+done
+
+lemma nonstop_eq[simp]:
+ "rec_calc_rel rec_nonstop [m, r, t] rs =
+ (rec_exec rec_nonstop [m, r, t] = rs)"
+apply(rule prime_rel_exec_eq, auto)
+done
+
+lemma halt_lemma':
+ "rec_calc_rel rec_halt [m, r] t =
+ (rec_calc_rel rec_nonstop [m, r, t] 0 \<and>
+ (\<forall> t'< t.
+ (\<exists> y. rec_calc_rel rec_nonstop [m, r, t'] y \<and>
+ y \<noteq> 0)))"
+apply(auto simp: rec_halt_def)
+apply(erule calc_mn_reverse, simp)
+apply(erule_tac calc_mn_reverse)
+apply(erule_tac x = t' in allE, simp)
+apply(rule_tac calc_mn, simp_all)
+done
+
+text {*
+ The following lemma gives the correctness of @{text "rec_halt"}.
+ It says: if @{text "rec_halt"} calculates that the TM coded by @{text "m"}
+ will reach a standard final configuration after @{text "t"} steps of execution, then it is indeed so.
+ *}
+lemma halt_lemma:
+ "rec_calc_rel (rec_halt) [m, r] t =
+ (rec_exec rec_nonstop [m, r, t] = 0 \<and>
+ (\<forall> t'< t. (\<exists> y. rec_exec rec_nonstop [m, r, t'] = y
+ \<and> y \<noteq> 0)))"
+using halt_lemma'[of m r t]
+by simp
+
+text {*F: universal machine*}
+
+text {*
+ @{text "valu r"} extracts computing result out of the right number @{text "r"}.
+ *}
+fun valu :: "nat \<Rightarrow> nat"
+ where
+ "valu r = (lg (r + 1) 2) - 1"
+
+text {*
+ @{text "rec_valu"} is the recursive function implementing @{text "valu"}.
+*}
+definition rec_valu :: "recf"
+ where
+ "rec_valu = Cn 1 rec_minus [Cn 1 rec_lg [s, constn 2], constn 1]"
+
+text {*
+ The correctness of @{text "rec_valu"}.
+*}
+lemma value_lemma: "rec_exec rec_valu [r] = valu r"
+apply(simp add: rec_exec.simps rec_valu_def lg_lemma)
+done
+
+lemma [intro]: "primerec rec_valu (Suc 0)"
+apply(simp add: rec_valu_def)
+apply(rule_tac k = "Suc (Suc 0)" in prime_cn)
+apply(auto simp: prime_s)
+proof -
+ show "primerec rec_lg (Suc (Suc 0))" by auto
+next
+ show "Suc (Suc 0) = Suc (Suc 0)" by simp
+next
+ show "primerec (constn (Suc (Suc 0))) (Suc 0)" by auto
+qed
+
+lemma [simp]: "rec_calc_rel rec_valu [r] rs =
+ (rec_exec rec_valu [r] = rs)"
+apply(rule_tac prime_rel_exec_eq, auto)
+done
+
+declare valu.simps[simp del]
+
+text {*
+ The definition of the universal function @{text "rec_F"}.
+ *}
+definition rec_F :: "recf"
+ where
+ "rec_F = Cn (Suc (Suc 0)) rec_valu [Cn (Suc (Suc 0)) rec_right [Cn (Suc (Suc 0))
+ rec_conf ([id (Suc (Suc 0)) 0, id (Suc (Suc 0)) (Suc 0), rec_halt])]]"
+
+lemma get_fstn_args_nth:
+ "k < n \<Longrightarrow> (get_fstn_args m n ! k) = id m (k)"
+apply(induct n, simp)
+apply(case_tac "k = n", simp_all add: get_fstn_args.simps
+ nth_append)
+done
+
+lemma [simp]:
+ "\<lbrakk>ys \<noteq> []; k < length ys\<rbrakk> \<Longrightarrow>
+ (get_fstn_args (length ys) (length ys) ! k) =
+ id (length ys) (k)"
+by(erule_tac get_fstn_args_nth)
+
+lemma calc_rel_get_pren:
+ "\<lbrakk>ys \<noteq> []; k < length ys\<rbrakk> \<Longrightarrow>
+ rec_calc_rel (get_fstn_args (length ys) (length ys) ! k) ys
+ (ys ! k)"
+apply(simp)
+apply(rule_tac calc_id, auto)
+done
+
+lemma [elim]:
+ "\<lbrakk>xs \<noteq> []; k < Suc (length xs)\<rbrakk> \<Longrightarrow>
+ rec_calc_rel (get_fstn_args (Suc (length xs))
+ (Suc (length xs)) ! k) (m # xs) ((m # xs) ! k)"
+using calc_rel_get_pren[of "m#xs" k]
+apply(simp)
+done
+
+text {*
+ The correctness of @{text "rec_F"}, halt case.
+ *}
+lemma F_lemma:
+ "rec_calc_rel rec_halt [m, r] t \<Longrightarrow>
+ rec_calc_rel rec_F [m, r] (valu (rght (conf m r t)))"
+apply(simp add: rec_F_def)
+apply(rule_tac rs = "[rght (conf m r t)]" in calc_cn,
+ auto simp: value_lemma)
+apply(rule_tac rs = "[conf m r t]" in calc_cn,
+ auto simp: right_lemma)
+apply(rule_tac rs = "[m, r, t]" in calc_cn, auto)
+apply(subgoal_tac " k = 0 \<or> k = Suc 0 \<or> k = Suc (Suc 0)",
+ auto simp:nth_append)
+apply(rule_tac [1-2] calc_id, simp_all add: conf_lemma)
+done
+
+
+text {*
+ The correctness of @{text "rec_F"}, nonhalt case.
+ *}
+lemma F_lemma2:
+ "\<forall> t. \<not> rec_calc_rel rec_halt [m, r] t \<Longrightarrow>
+ \<forall> rs. \<not> rec_calc_rel rec_F [m, r] rs"
+apply(auto simp: rec_F_def)
+apply(erule_tac calc_cn_reverse, simp (no_asm_use))+
+proof -
+ fix rs rsa rsb rsc
+ assume h:
+ "\<forall>t. \<not> rec_calc_rel rec_halt [m, r] t"
+ "length rsa = Suc 0"
+ "rec_calc_rel rec_valu rsa rs"
+ "length rsb = Suc 0"
+ "rec_calc_rel rec_right rsb (rsa ! 0)"
+ "length rsc = (Suc (Suc (Suc 0)))"
+ "rec_calc_rel rec_conf rsc (rsb ! 0)"
+ and g: "\<forall>k<Suc (Suc (Suc 0)). rec_calc_rel ([recf.id (Suc (Suc 0)) 0,
+ recf.id (Suc (Suc 0)) (Suc 0), rec_halt] ! k) [m, r] (rsc ! k)"
+ have "rec_calc_rel (rec_halt ) [m, r]
+ (rsc ! (Suc (Suc 0)))"
+ using g
+ apply(erule_tac x = "(Suc (Suc 0))" in allE)
+ apply(simp add:nth_append)
+ done
+ thus "False"
+ using h
+ apply(erule_tac x = "ysb ! (Suc (Suc 0))" in allE, simp)
+ done
+qed
+
+section {* Coding function of TMs *}
+
+text {*
+ The purpose of this section is to get the coding function of Turing Machine, which is
+ going to be named @{text "code"}.
+ *}
+
+fun bl2nat :: "block list \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "bl2nat [] n = 0"
+| "bl2nat (Bk#bl) n = bl2nat bl (Suc n)"
+| "bl2nat (Oc#bl) n = 2^n + bl2nat bl (Suc n)"
+
+fun bl2wc :: "block list \<Rightarrow> nat"
+ where
+ "bl2wc xs = bl2nat xs 0"
+
+fun trpl_code :: "t_conf \<Rightarrow> nat"
+ where
+ "trpl_code (st, l, r) = trpl (bl2wc l) st (bl2wc r)"
+
+declare bl2nat.simps[simp del] bl2wc.simps[simp del]
+ trpl_code.simps[simp del]
+
+fun action_map :: "taction \<Rightarrow> nat"
+ where
+ "action_map W0 = 0"
+| "action_map W1 = 1"
+| "action_map L = 2"
+| "action_map R = 3"
+| "action_map Nop = 4"
+
+fun action_map_iff :: "nat \<Rightarrow> taction"
+ where
+ "action_map_iff (0::nat) = W0"
+| "action_map_iff (Suc 0) = W1"
+| "action_map_iff (Suc (Suc 0)) = L"
+| "action_map_iff (Suc (Suc (Suc 0))) = R"
+| "action_map_iff n = Nop"
+
+fun block_map :: "block \<Rightarrow> nat"
+ where
+ "block_map Bk = 0"
+| "block_map Oc = 1"
+
+fun godel_code' :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "godel_code' [] n = 1"
+| "godel_code' (x#xs) n = (Pi n)^x * godel_code' xs (Suc n) "
+
+fun godel_code :: "nat list \<Rightarrow> nat"
+ where
+ "godel_code xs = (let lh = length xs in
+ 2^lh * (godel_code' xs (Suc 0)))"
+
+fun modify_tprog :: "tprog \<Rightarrow> nat list"
+ where
+ "modify_tprog [] = []"
+| "modify_tprog ((ac, ns)#nl) = action_map ac # ns # modify_tprog nl"
+
+text {*
+ @{text "code tp"} gives the Godel coding of TM program @{text "tp"}.
+ *}
+fun code :: "tprog \<Rightarrow> nat"
+ where
+ "code tp = (let nl = modify_tprog tp in
+ godel_code nl)"
+
+section {* Relating interperter functions to the execution of TMs *}
+
+lemma [simp]: "bl2wc [] = 0" by(simp add: bl2wc.simps bl2nat.simps)
+term trpl
+
+lemma [simp]: "\<lbrakk>fetch tp 0 b = (nact, ns)\<rbrakk> \<Longrightarrow> action_map nact = 4"
+apply(simp add: fetch.simps)
+done
+
+thm entry_lemma
+lemma Pi_gr_1[simp]: "Pi n > Suc 0"
+proof(induct n, auto simp: Pi.simps Np.simps)
+ fix n
+ let ?setx = "{y. y \<le> Suc (Pi n!) \<and> Pi n < y \<and> Prime y}"
+ have "finite ?setx" by auto
+ moreover have "?setx \<noteq> {}"
+ using prime_ex[of "Pi n"]
+ apply(auto)
+ done
+ ultimately show "Suc 0 < Min ?setx"
+ apply(simp add: Min_gr_iff)
+ apply(auto simp: Prime.simps)
+ done
+qed
+
+lemma Pi_not_0[simp]: "Pi n > 0"
+using Pi_gr_1[of n]
+by arith
+
+declare godel_code.simps[simp del]
+
+lemma [simp]: "0 < godel_code' nl n"
+apply(induct nl arbitrary: n)
+apply(auto simp: godel_code'.simps)
+done
+
+lemma godel_code_great: "godel_code nl > 0"
+apply(simp add: godel_code.simps)
+done
+
+lemma godel_code_eq_1: "(godel_code nl = 1) = (nl = [])"
+apply(auto simp: godel_code.simps)
+done
+
+lemma [elim]:
+ "\<lbrakk>i < length nl; \<not> Suc 0 < godel_code nl\<rbrakk> \<Longrightarrow> nl ! i = 0"
+using godel_code_great[of nl] godel_code_eq_1[of nl]
+apply(simp)
+done
+
+term set_of
+lemma prime_coprime: "\<lbrakk>Prime x; Prime y; x\<noteq>y\<rbrakk> \<Longrightarrow> coprime x y"
+proof(simp only: Prime.simps coprime_nat, auto simp: dvd_def,
+ rule_tac classical, simp)
+ fix d k ka
+ assume case_ka: "\<forall>u<d * ka. \<forall>v<d * ka. u * v \<noteq> d * ka"
+ and case_k: "\<forall>u<d * k. \<forall>v<d * k. u * v \<noteq> d * k"
+ and h: "(0::nat) < d" "d \<noteq> Suc 0" "Suc 0 < d * ka"
+ "ka \<noteq> k" "Suc 0 < d * k"
+ from h have "k > Suc 0 \<or> ka >Suc 0"
+ apply(auto)
+ apply(case_tac ka, simp, simp)
+ apply(case_tac k, simp, simp)
+ done
+ from this show "False"
+ proof(erule_tac disjE)
+ assume "(Suc 0::nat) < k"
+ hence "k < d*k \<and> d < d*k"
+ using h
+ by(auto)
+ thus "?thesis"
+ using case_k
+ apply(erule_tac x = d in allE)
+ apply(simp)
+ apply(erule_tac x = k in allE)
+ apply(simp)
+ done
+ next
+ assume "(Suc 0::nat) < ka"
+ hence "ka < d * ka \<and> d < d*ka"
+ using h by auto
+ thus "?thesis"
+ using case_ka
+ apply(erule_tac x = d in allE)
+ apply(simp)
+ apply(erule_tac x = ka in allE)
+ apply(simp)
+ done
+ qed
+qed
+
+lemma Pi_inc: "Pi (Suc i) > Pi i"
+proof(simp add: Pi.simps Np.simps)
+ let ?setx = "{y. y \<le> Suc (Pi i!) \<and> Pi i < y \<and> Prime y}"
+ have "finite ?setx" by simp
+ moreover have "?setx \<noteq> {}"
+ using prime_ex[of "Pi i"]
+ apply(auto)
+ done
+ ultimately show "Pi i < Min ?setx"
+ apply(simp add: Min_gr_iff)
+ done
+qed
+
+lemma Pi_inc_gr: "i < j \<Longrightarrow> Pi i < Pi j"
+proof(induct j, simp)
+ fix j
+ assume ind: "i < j \<Longrightarrow> Pi i < Pi j"
+ and h: "i < Suc j"
+ from h show "Pi i < Pi (Suc j)"
+ proof(cases "i < j")
+ case True thus "?thesis"
+ proof -
+ assume "i < j"
+ hence "Pi i < Pi j" by(erule_tac ind)
+ moreover have "Pi j < Pi (Suc j)"
+ apply(simp add: Pi_inc)
+ done
+ ultimately show "?thesis"
+ by simp
+ qed
+ next
+ assume "i < Suc j" "\<not> i < j"
+ hence "i = j"
+ by arith
+ thus "Pi i < Pi (Suc j)"
+ apply(simp add: Pi_inc)
+ done
+ qed
+qed
+
+lemma Pi_notEq: "i \<noteq> j \<Longrightarrow> Pi i \<noteq> Pi j"
+apply(case_tac "i < j")
+using Pi_inc_gr[of i j]
+apply(simp)
+using Pi_inc_gr[of j i]
+apply(simp)
+done
+
+lemma [intro]: "Prime (Suc (Suc 0))"
+apply(auto simp: Prime.simps)
+apply(case_tac u, simp, case_tac nat, simp, simp)
+done
+
+lemma Prime_Pi[intro]: "Prime (Pi n)"
+proof(induct n, auto simp: Pi.simps Np.simps)
+ fix n
+ let ?setx = "{y. y \<le> Suc (Pi n!) \<and> Pi n < y \<and> Prime y}"
+ show "Prime (Min ?setx)"
+ proof -
+ have "finite ?setx" by simp
+ moreover have "?setx \<noteq> {}"
+ using prime_ex[of "Pi n"]
+ apply(simp)
+ done
+ ultimately show "?thesis"
+ apply(drule_tac Min_in, simp, simp)
+ done
+ qed
+qed
+
+lemma Pi_coprime: "i \<noteq> j \<Longrightarrow> coprime (Pi i) (Pi j)"
+using Prime_Pi[of i]
+using Prime_Pi[of j]
+apply(rule_tac prime_coprime, simp_all add: Pi_notEq)
+done
+
+lemma Pi_power_coprime: "i \<noteq> j \<Longrightarrow> coprime ((Pi i)^m) ((Pi j)^n)"
+by(rule_tac coprime_exp2_nat, erule_tac Pi_coprime)
+
+lemma coprime_dvd_mult_nat2: "\<lbrakk>coprime (k::nat) n; k dvd n * m\<rbrakk> \<Longrightarrow> k dvd m"
+apply(erule_tac coprime_dvd_mult_nat)
+apply(simp add: dvd_def, auto)
+apply(rule_tac x = ka in exI)
+apply(subgoal_tac "n * m = m * n", simp)
+apply(simp add: nat_mult_commute)
+done
+
+declare godel_code'.simps[simp del]
+
+lemma godel_code'_butlast_last_id' :
+ "godel_code' (ys @ [y]) (Suc j) = godel_code' ys (Suc j) *
+ Pi (Suc (length ys + j)) ^ y"
+proof(induct ys arbitrary: j, simp_all add: godel_code'.simps)
+qed
+
+lemma godel_code'_butlast_last_id:
+"xs \<noteq> [] \<Longrightarrow> godel_code' xs (Suc j) =
+ godel_code' (butlast xs) (Suc j) * Pi (length xs + j)^(last xs)"
+apply(subgoal_tac "\<exists> ys y. xs = ys @ [y]")
+apply(erule_tac exE, erule_tac exE, simp add:
+ godel_code'_butlast_last_id')
+apply(rule_tac x = "butlast xs" in exI)
+apply(rule_tac x = "last xs" in exI, auto)
+done
+
+lemma godel_code'_not0: "godel_code' xs n \<noteq> 0"
+apply(induct xs, auto simp: godel_code'.simps)
+done
+
+lemma godel_code_append_cons:
+ "length xs = i \<Longrightarrow> godel_code' (xs@y#ys) (Suc 0)
+ = godel_code' xs (Suc 0) * Pi (Suc i)^y * godel_code' ys (i + 2)"
+proof(induct "length xs" arbitrary: i y ys xs, simp add: godel_code'.simps,simp)
+ fix x xs i y ys
+ assume ind:
+ "\<And>xs i y ys. \<lbrakk>x = i; length xs = i\<rbrakk> \<Longrightarrow>
+ godel_code' (xs @ y # ys) (Suc 0)
+ = godel_code' xs (Suc 0) * Pi (Suc i) ^ y *
+ godel_code' ys (Suc (Suc i))"
+ and h: "Suc x = i"
+ "length (xs::nat list) = i"
+ have
+ "godel_code' (butlast xs @ last xs # ((y::nat)#ys)) (Suc 0) =
+ godel_code' (butlast xs) (Suc 0) * Pi (Suc (i - 1))^(last xs)
+ * godel_code' (y#ys) (Suc (Suc (i - 1)))"
+ apply(rule_tac ind)
+ using h
+ by(auto)
+ moreover have
+ "godel_code' xs (Suc 0)= godel_code' (butlast xs) (Suc 0) *
+ Pi (i)^(last xs)"
+ using godel_code'_butlast_last_id[of xs] h
+ apply(case_tac "xs = []", simp, simp)
+ done
+ moreover have "butlast xs @ last xs # y # ys = xs @ y # ys"
+ using h
+ apply(case_tac xs, auto)
+ done
+ ultimately show
+ "godel_code' (xs @ y # ys) (Suc 0) =
+ godel_code' xs (Suc 0) * Pi (Suc i) ^ y *
+ godel_code' ys (Suc (Suc i))"
+ using h
+ apply(simp add: godel_code'_not0 Pi_not_0)
+ apply(simp add: godel_code'.simps)
+ done
+qed
+
+lemma Pi_coprime_pre:
+ "length ps \<le> i \<Longrightarrow> coprime (Pi (Suc i)) (godel_code' ps (Suc 0))"
+proof(induct "length ps" arbitrary: ps, simp add: godel_code'.simps)
+ fix x ps
+ assume ind:
+ "\<And>ps. \<lbrakk>x = length ps; length ps \<le> i\<rbrakk> \<Longrightarrow>
+ coprime (Pi (Suc i)) (godel_code' ps (Suc 0))"
+ and h: "Suc x = length ps"
+ "length (ps::nat list) \<le> i"
+ have g: "coprime (Pi (Suc i)) (godel_code' (butlast ps) (Suc 0))"
+ apply(rule_tac ind)
+ using h by auto
+ have k: "godel_code' ps (Suc 0) =
+ godel_code' (butlast ps) (Suc 0) * Pi (length ps)^(last ps)"
+ using godel_code'_butlast_last_id[of ps 0] h
+ by(case_tac ps, simp, simp)
+ from g have
+ "coprime (Pi (Suc i)) (godel_code' (butlast ps) (Suc 0) *
+ Pi (length ps)^(last ps)) "
+ proof(rule_tac coprime_mult_nat, simp)
+ show "coprime (Pi (Suc i)) (Pi (length ps) ^ last ps)"
+ apply(rule_tac coprime_exp_nat, rule prime_coprime, auto)
+ using Pi_notEq[of "Suc i" "length ps"] h by simp
+ qed
+ from this and k show "coprime (Pi (Suc i)) (godel_code' ps (Suc 0))"
+ by simp
+qed
+
+lemma Pi_coprime_suf: "i < j \<Longrightarrow> coprime (Pi i) (godel_code' ps j)"
+proof(induct "length ps" arbitrary: ps, simp add: godel_code'.simps)
+ fix x ps
+ assume ind:
+ "\<And>ps. \<lbrakk>x = length ps; i < j\<rbrakk> \<Longrightarrow>
+ coprime (Pi i) (godel_code' ps j)"
+ and h: "Suc x = length (ps::nat list)" "i < j"
+ have g: "coprime (Pi i) (godel_code' (butlast ps) j)"
+ apply(rule ind) using h by auto
+ have k: "(godel_code' ps j) = godel_code' (butlast ps) j *
+ Pi (length ps + j - 1)^last ps"
+ using h godel_code'_butlast_last_id[of ps "j - 1"]
+ apply(case_tac "ps = []", simp, simp)
+ done
+ from g have
+ "coprime (Pi i) (godel_code' (butlast ps) j *
+ Pi (length ps + j - 1)^last ps)"
+ apply(rule_tac coprime_mult_nat, simp)
+ using Pi_power_coprime[of i "length ps + j - 1" 1 "last ps"] h
+ apply(auto)
+ done
+ from k and this show "coprime (Pi i) (godel_code' ps j)"
+ by auto
+qed
+
+lemma godel_finite:
+ "finite {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
+proof(rule_tac n = "godel_code' nl (Suc 0)" in
+ bounded_nat_set_is_finite, auto,
+ case_tac "ia < godel_code' nl (Suc 0)", auto)
+ fix ia
+ assume g1: "Pi (Suc i) ^ ia dvd godel_code' nl (Suc 0)"
+ and g2: "\<not> ia < godel_code' nl (Suc 0)"
+ from g1 have "Pi (Suc i)^ia \<le> godel_code' nl (Suc 0)"
+ apply(erule_tac dvd_imp_le)
+ using godel_code'_not0[of nl "Suc 0"] by simp
+ moreover have "ia < Pi (Suc i)^ia"
+ apply(rule x_less_exp)
+ using Pi_gr_1 by auto
+ ultimately show "False"
+ using g2
+ by(auto)
+qed
+
+
+lemma godel_code_in:
+ "i < length nl \<Longrightarrow> nl ! i \<in> {u. Pi (Suc i) ^ u dvd
+ godel_code' nl (Suc 0)}"
+proof -
+ assume h: "i<length nl"
+ hence "godel_code' (take i nl@(nl!i)#drop (Suc i) nl) (Suc 0)
+ = godel_code' (take i nl) (Suc 0) * Pi (Suc i)^(nl!i) *
+ godel_code' (drop (Suc i) nl) (i + 2)"
+ by(rule_tac godel_code_append_cons, simp)
+ moreover from h have "take i nl @ (nl ! i) # drop (Suc i) nl = nl"
+ using upd_conv_take_nth_drop[of i nl "nl ! i"]
+ apply(simp)
+ done
+ ultimately show
+ "nl ! i \<in> {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
+ by(simp)
+qed
+
+lemma godel_code'_get_nth:
+ "i < length nl \<Longrightarrow> Max {u. Pi (Suc i) ^ u dvd
+ godel_code' nl (Suc 0)} = nl ! i"
+proof(rule_tac Max_eqI)
+ let ?gc = "godel_code' nl (Suc 0)"
+ assume h: "i < length nl" thus "finite {u. Pi (Suc i) ^ u dvd ?gc}"
+ by (simp add: godel_finite)
+next
+ fix y
+ let ?suf ="godel_code' (drop (Suc i) nl) (i + 2)"
+ let ?pref = "godel_code' (take i nl) (Suc 0)"
+ assume h: "i < length nl"
+ "y \<in> {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
+ moreover hence
+ "godel_code' (take i nl@(nl!i)#drop (Suc i) nl) (Suc 0)
+ = ?pref * Pi (Suc i)^(nl!i) * ?suf"
+ by(rule_tac godel_code_append_cons, simp)
+ moreover from h have "take i nl @ (nl!i) # drop (Suc i) nl = nl"
+ using upd_conv_take_nth_drop[of i nl "nl!i"]
+ by simp
+ ultimately show "y\<le>nl!i"
+ proof(simp)
+ let ?suf' = "godel_code' (drop (Suc i) nl) (Suc (Suc i))"
+ assume mult_dvd:
+ "Pi (Suc i) ^ y dvd ?pref * Pi (Suc i) ^ nl ! i * ?suf'"
+ hence "Pi (Suc i) ^ y dvd ?pref * Pi (Suc i) ^ nl ! i"
+ proof(rule_tac coprime_dvd_mult_nat)
+ show "coprime (Pi (Suc i)^y) ?suf'"
+ proof -
+ have "coprime (Pi (Suc i) ^ y) (?suf'^(Suc 0))"
+ apply(rule_tac coprime_exp2_nat)
+ apply(rule_tac Pi_coprime_suf, simp)
+ done
+ thus "?thesis" by simp
+ qed
+ qed
+ hence "Pi (Suc i) ^ y dvd Pi (Suc i) ^ nl ! i"
+ proof(rule_tac coprime_dvd_mult_nat2)
+ show "coprime (Pi (Suc i) ^ y) ?pref"
+ proof -
+ have "coprime (Pi (Suc i)^y) (?pref^Suc 0)"
+ apply(rule_tac coprime_exp2_nat)
+ apply(rule_tac Pi_coprime_pre, simp)
+ done
+ thus "?thesis" by simp
+ qed
+ qed
+ hence "Pi (Suc i) ^ y \<le> Pi (Suc i) ^ nl ! i "
+ apply(rule_tac dvd_imp_le, auto)
+ done
+ thus "y \<le> nl ! i"
+ apply(rule_tac power_le_imp_le_exp, auto)
+ done
+ qed
+next
+ assume h: "i<length nl"
+ thus "nl ! i \<in> {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
+ by(rule_tac godel_code_in, simp)
+qed
+
+lemma [simp]:
+ "{u. Pi (Suc i) ^ u dvd (Suc (Suc 0)) ^ length nl *
+ godel_code' nl (Suc 0)} =
+ {u. Pi (Suc i) ^ u dvd godel_code' nl (Suc 0)}"
+apply(rule_tac Collect_cong, auto)
+apply(rule_tac n = " (Suc (Suc 0)) ^ length nl" in
+ coprime_dvd_mult_nat2)
+proof -
+ fix u
+ show "coprime (Pi (Suc i) ^ u) ((Suc (Suc 0)) ^ length nl)"
+ proof(rule_tac coprime_exp2_nat)
+ have "Pi 0 = (2::nat)"
+ apply(simp add: Pi.simps)
+ done
+ moreover have "coprime (Pi (Suc i)) (Pi 0)"
+ apply(rule_tac Pi_coprime, simp)
+ done
+ ultimately show "coprime (Pi (Suc i)) (Suc (Suc 0))" by simp
+ qed
+qed
+
+lemma godel_code_get_nth:
+ "i < length nl \<Longrightarrow>
+ Max {u. Pi (Suc i) ^ u dvd godel_code nl} = nl ! i"
+by(simp add: godel_code.simps godel_code'_get_nth)
+
+thm trpl.simps
+
+lemma "trpl l st r = godel_code' [l, st, r] 0"
+apply(simp add: trpl.simps godel_code'.simps)
+done
+
+lemma mod_dvd_simp: "(x mod y = (0::nat)) = (y dvd x)"
+by(simp add: dvd_def, auto)
+
+lemma dvd_power_le: "\<lbrakk>a > Suc 0; a ^ y dvd a ^ l\<rbrakk> \<Longrightarrow> y \<le> l"
+apply(case_tac "y \<le> l", simp, simp)
+apply(subgoal_tac "\<exists> d. y = l + d", auto simp: power_add)
+apply(rule_tac x = "y - l" in exI, simp)
+done
+
+
+lemma [elim]: "Pi n = 0 \<Longrightarrow> RR"
+ using Pi_not_0[of n] by simp
+
+lemma [elim]: "Pi n = Suc 0 \<Longrightarrow> RR"
+ using Pi_gr_1[of n] by simp
+
+lemma finite_power_dvd:
+ "\<lbrakk>(a::nat) > Suc 0; y \<noteq> 0\<rbrakk> \<Longrightarrow> finite {u. a^u dvd y}"
+apply(auto simp: dvd_def)
+apply(rule_tac n = y in bounded_nat_set_is_finite, auto)
+apply(case_tac k, simp,simp)
+apply(rule_tac trans_less_add1)
+apply(erule_tac x_less_exp)
+done
+
+lemma conf_decode1: "\<lbrakk>m \<noteq> n; m \<noteq> k; k \<noteq> n\<rbrakk> \<Longrightarrow>
+ Max {u. Pi m ^ u dvd Pi m ^ l * Pi n ^ st * Pi k ^ r} = l"
+proof -
+ let ?setx = "{u. Pi m ^ u dvd Pi m ^ l * Pi n ^ st * Pi k ^ r}"
+ assume g: "m \<noteq> n" "m \<noteq> k" "k \<noteq> n"
+ show "Max ?setx = l"
+ proof(rule_tac Max_eqI)
+ show "finite ?setx"
+ apply(rule_tac finite_power_dvd, auto simp: Pi_gr_1)
+ done
+ next
+ fix y
+ assume h: "y \<in> ?setx"
+ have "Pi m ^ y dvd Pi m ^ l"
+ proof -
+ have "Pi m ^ y dvd Pi m ^ l * Pi n ^ st"
+ using h g
+ apply(rule_tac n = "Pi k^r" in coprime_dvd_mult_nat)
+ apply(rule Pi_power_coprime, simp, simp)
+ done
+ thus "Pi m^y dvd Pi m^l"
+ apply(rule_tac n = " Pi n ^ st" in coprime_dvd_mult_nat)
+ using g
+ apply(rule_tac Pi_power_coprime, simp, simp)
+ done
+ qed
+ thus "y \<le> (l::nat)"
+ apply(rule_tac a = "Pi m" in power_le_imp_le_exp)
+ apply(simp_all add: Pi_gr_1)
+ apply(rule_tac dvd_power_le, auto)
+ done
+ next
+ show "l \<in> ?setx" by simp
+ qed
+qed
+
+lemma conf_decode2:
+ "\<lbrakk>m \<noteq> n; m \<noteq> k; n \<noteq> k;
+ \<not> Suc 0 < Pi m ^ l * Pi n ^ st * Pi k ^ r\<rbrakk> \<Longrightarrow> l = 0"
+apply(case_tac "Pi m ^ l * Pi n ^ st * Pi k ^ r", auto)
+done
+
+lemma [simp]: "left (trpl l st r) = l"
+apply(simp add: left.simps trpl.simps lo.simps
+ loR.simps mod_dvd_simp, auto simp: conf_decode1)
+apply(case_tac "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r",
+ auto)
+apply(erule_tac x = l in allE, auto)
+done
+
+lemma [simp]: "stat (trpl l st r) = st"
+apply(simp add: stat.simps trpl.simps lo.simps
+ loR.simps mod_dvd_simp, auto)
+apply(subgoal_tac "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r
+ = Pi (Suc 0)^st * Pi 0 ^ l * Pi (Suc (Suc 0)) ^ r")
+apply(simp (no_asm_simp) add: conf_decode1, simp)
+apply(case_tac "Pi 0 ^ l * Pi (Suc 0) ^ st *
+ Pi (Suc (Suc 0)) ^ r", auto)
+apply(erule_tac x = st in allE, auto)
+done
+
+lemma [simp]: "rght (trpl l st r) = r"
+apply(simp add: rght.simps trpl.simps lo.simps
+ loR.simps mod_dvd_simp, auto)
+apply(subgoal_tac "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r
+ = Pi (Suc (Suc 0))^r * Pi 0 ^ l * Pi (Suc 0) ^ st")
+apply(simp (no_asm_simp) add: conf_decode1, simp)
+apply(case_tac "Pi 0 ^ l * Pi (Suc 0) ^ st * Pi (Suc (Suc 0)) ^ r",
+ auto)
+apply(erule_tac x = r in allE, auto)
+done
+
+lemma max_lor:
+ "i < length nl \<Longrightarrow> Max {u. loR [godel_code nl, Pi (Suc i), u]}
+ = nl ! i"
+apply(simp add: loR.simps godel_code_get_nth mod_dvd_simp)
+done
+
+lemma godel_decode:
+ "i < length nl \<Longrightarrow> Entry (godel_code nl) i = nl ! i"
+apply(auto simp: Entry.simps lo.simps max_lor)
+apply(erule_tac x = "nl!i" in allE)
+using max_lor[of i nl] godel_finite[of i nl]
+apply(simp)
+apply(drule_tac Max_in, auto simp: loR.simps
+ godel_code.simps mod_dvd_simp)
+using godel_code_in[of i nl]
+apply(simp)
+done
+
+lemma Four_Suc: "4 = Suc (Suc (Suc (Suc 0)))"
+by auto
+
+declare numeral_2_eq_2[simp del]
+
+lemma modify_tprog_fetch_even:
+ "\<lbrakk>st \<le> length tp div 2; st > 0\<rbrakk> \<Longrightarrow>
+ modify_tprog tp ! (4 * (st - Suc 0) ) =
+ action_map (fst (tp ! (2 * (st - Suc 0))))"
+proof(induct st arbitrary: tp, simp)
+ fix tp st
+ assume ind:
+ "\<And>tp. \<lbrakk>st \<le> length tp div 2; 0 < st\<rbrakk> \<Longrightarrow>
+ modify_tprog tp ! (4 * (st - Suc 0)) =
+ action_map (fst ((tp::tprog) ! (2 * (st - Suc 0))))"
+ and h: "Suc st \<le> length (tp::tprog) div 2" "0 < Suc st"
+ thus "modify_tprog tp ! (4 * (Suc st - Suc 0)) =
+ action_map (fst (tp ! (2 * (Suc st - Suc 0))))"
+ proof(cases "st = 0")
+ case True thus "?thesis"
+ using h
+ apply(auto)
+ apply(cases tp, simp, case_tac a, simp add: modify_tprog.simps)
+ done
+ next
+ case False
+ assume g: "st \<noteq> 0"
+ hence "\<exists> aa ab ba bb tp'. tp = (aa, ab) # (ba, bb) # tp'"
+ using h
+ apply(case_tac tp, simp, case_tac list, simp, simp)
+ done
+ from this obtain aa ab ba bb tp' where g1:
+ "tp = (aa, ab) # (ba, bb) # tp'" by blast
+ hence g2:
+ "modify_tprog tp' ! (4 * (st - Suc 0)) =
+ action_map (fst ((tp'::tprog) ! (2 * (st - Suc 0))))"
+ apply(rule_tac ind)
+ using h g by auto
+ thus "?thesis"
+ using g1 g
+ apply(case_tac st, simp, simp add: Four_Suc)
+ done
+ qed
+qed
+
+lemma modify_tprog_fetch_odd:
+ "\<lbrakk>st \<le> length tp div 2; st > 0\<rbrakk> \<Longrightarrow>
+ modify_tprog tp ! (Suc (Suc (4 * (st - Suc 0)))) =
+ action_map (fst (tp ! (Suc (2 * (st - Suc 0)))))"
+proof(induct st arbitrary: tp, simp)
+ fix tp st
+ assume ind:
+ "\<And>tp. \<lbrakk>st \<le> length tp div 2; 0 < st\<rbrakk> \<Longrightarrow>
+ modify_tprog tp ! Suc (Suc (4 * (st - Suc 0))) =
+ action_map (fst (tp ! Suc (2 * (st - Suc 0))))"
+ and h: "Suc st \<le> length (tp::tprog) div 2" "0 < Suc st"
+ thus "modify_tprog tp ! Suc (Suc (4 * (Suc st - Suc 0)))
+ = action_map (fst (tp ! Suc (2 * (Suc st - Suc 0))))"
+ proof(cases "st = 0")
+ case True thus "?thesis"
+ using h
+ apply(auto)
+ apply(cases tp, simp, case_tac a, simp add: modify_tprog.simps)
+ apply(case_tac list, simp, case_tac ab,
+ simp add: modify_tprog.simps)
+ done
+ next
+ case False
+ assume g: "st \<noteq> 0"
+ hence "\<exists> aa ab ba bb tp'. tp = (aa, ab) # (ba, bb) # tp'"
+ using h
+ apply(case_tac tp, simp, case_tac list, simp, simp)
+ done
+ from this obtain aa ab ba bb tp' where g1:
+ "tp = (aa, ab) # (ba, bb) # tp'" by blast
+ hence g2: "modify_tprog tp' ! Suc (Suc (4 * (st - Suc 0))) =
+ action_map (fst (tp' ! Suc (2 * (st - Suc 0))))"
+ apply(rule_tac ind)
+ using h g by auto
+ thus "?thesis"
+ using g1 g
+ apply(case_tac st, simp, simp add: Four_Suc)
+ done
+ qed
+qed
+
+lemma modify_tprog_fetch_action:
+ "\<lbrakk>st \<le> length tp div 2; st > 0; b = 1 \<or> b = 0\<rbrakk> \<Longrightarrow>
+ modify_tprog tp ! (4 * (st - Suc 0) + 2* b) =
+ action_map (fst (tp ! ((2 * (st - Suc 0)) + b)))"
+apply(erule_tac disjE, auto elim: modify_tprog_fetch_odd
+ modify_tprog_fetch_even)
+done
+
+lemma length_modify: "length (modify_tprog tp) = 2 * length tp"
+apply(induct tp, auto)
+done
+
+declare fetch.simps[simp del]
+
+lemma fetch_action_eq:
+ "\<lbrakk>block_map b = scan r; fetch tp st b = (nact, ns);
+ st \<le> length tp div 2\<rbrakk> \<Longrightarrow> actn (code tp) st r = action_map nact"
+proof(simp add: actn.simps, auto)
+ let ?i = "4 * (st - Suc 0) + 2 * (r mod 2)"
+ assume h: "block_map b = r mod 2" "fetch tp st b = (nact, ns)"
+ "st \<le> length tp div 2" "0 < st"
+ have "?i < length (modify_tprog tp)"
+ proof -
+ have "length (modify_tprog tp) = 2 * length tp"
+ by(simp add: length_modify)
+ thus "?thesis"
+ using h
+ by(auto)
+ qed
+ hence
+ "Entry (godel_code (modify_tprog tp))?i =
+ (modify_tprog tp) ! ?i"
+ by(erule_tac godel_decode)
+ thm modify_tprog.simps
+ moreover have
+ "modify_tprog tp ! ?i =
+ action_map (fst (tp ! (2 * (st - Suc 0) + r mod 2)))"
+ apply(rule_tac modify_tprog_fetch_action)
+ using h
+ by(auto)
+ moreover have "(fst (tp ! (2 * (st - Suc 0) + r mod 2))) = nact"
+ using h
+ apply(simp add: fetch.simps nth_of.simps)
+ apply(case_tac b, auto simp: block_map.simps nth_of.simps split: if_splits)
+ done
+ ultimately show
+ "Entry (godel_code (modify_tprog tp))
+ (4 * (st - Suc 0) + 2 * (r mod 2))
+ = action_map nact"
+ by simp
+qed
+
+lemma [simp]: "fetch tp 0 b = (nact, ns) \<Longrightarrow> ns = 0"
+by(simp add: fetch.simps)
+
+lemma Five_Suc: "5 = Suc 4" by simp
+
+lemma modify_tprog_fetch_state:
+ "\<lbrakk>st \<le> length tp div 2; st > 0; b = 1 \<or> b = 0\<rbrakk> \<Longrightarrow>
+ modify_tprog tp ! Suc (4 * (st - Suc 0) + 2 * b) =
+ (snd (tp ! (2 * (st - Suc 0) + b)))"
+proof(induct st arbitrary: tp, simp)
+ fix st tp
+ assume ind:
+ "\<And>tp. \<lbrakk>st \<le> length tp div 2; 0 < st; b = 1 \<or> b = 0\<rbrakk> \<Longrightarrow>
+ modify_tprog tp ! Suc (4 * (st - Suc 0) + 2 * b) =
+ snd (tp ! (2 * (st - Suc 0) + b))"
+ and h:
+ "Suc st \<le> length (tp::tprog) div 2"
+ "0 < Suc st"
+ "b = 1 \<or> b = 0"
+ show "modify_tprog tp ! Suc (4 * (Suc st - Suc 0) + 2 * b) =
+ snd (tp ! (2 * (Suc st - Suc 0) + b))"
+ proof(cases "st = 0")
+ case True
+ thus "?thesis"
+ using h
+ apply(cases tp, simp, case_tac a, simp add: modify_tprog.simps)
+ apply(case_tac list, simp, case_tac ab,
+ simp add: modify_tprog.simps, auto)
+ done
+ next
+ case False
+ assume g: "st \<noteq> 0"
+ hence "\<exists> aa ab ba bb tp'. tp = (aa, ab) # (ba, bb) # tp'"
+ using h
+ apply(case_tac tp, simp, case_tac list, simp, simp)
+ done
+ from this obtain aa ab ba bb tp' where g1:
+ "tp = (aa, ab) # (ba, bb) # tp'" by blast
+ hence g2:
+ "modify_tprog tp' ! Suc (4 * (st - Suc 0) + 2 * b) =
+ snd (tp' ! (2 * (st - Suc 0) + b))"
+ apply(rule_tac ind)
+ using h g by auto
+ thus "?thesis"
+ using g1 g
+ apply(case_tac st, simp, simp)
+ done
+ qed
+qed
+
+lemma fetch_state_eq:
+ "\<lbrakk>block_map b = scan r;
+ fetch tp st b = (nact, ns);
+ st \<le> length tp div 2\<rbrakk> \<Longrightarrow> newstat (code tp) st r = ns"
+proof(simp add: newstat.simps, auto)
+ let ?i = "Suc (4 * (st - Suc 0) + 2 * (r mod 2))"
+ assume h: "block_map b = r mod 2" "fetch tp st b =
+ (nact, ns)" "st \<le> length tp div 2" "0 < st"
+ have "?i < length (modify_tprog tp)"
+ proof -
+ have "length (modify_tprog tp) = 2 * length tp"
+ apply(simp add: length_modify)
+ done
+ thus "?thesis"
+ using h
+ by(auto)
+ qed
+ hence "Entry (godel_code (modify_tprog tp)) (?i) =
+ (modify_tprog tp) ! ?i"
+ by(erule_tac godel_decode)
+ thm modify_tprog.simps
+ moreover have
+ "modify_tprog tp ! ?i =
+ (snd (tp ! (2 * (st - Suc 0) + r mod 2)))"
+ apply(rule_tac modify_tprog_fetch_state)
+ using h
+ by(auto)
+ moreover have "(snd (tp ! (2 * (st - Suc 0) + r mod 2))) = ns"
+ using h
+ apply(simp add: fetch.simps nth_of.simps)
+ apply(case_tac b, auto simp: block_map.simps nth_of.simps
+ split: if_splits)
+ done
+ ultimately show "Entry (godel_code (modify_tprog tp)) (?i)
+ = ns"
+ by simp
+qed
+
+
+lemma [intro!]:
+ "\<lbrakk>a = a'; b = b'; c = c'\<rbrakk> \<Longrightarrow> trpl a b c = trpl a' b' c'"
+by simp
+
+lemma [simp]: "bl2wc [Bk] = 0"
+by(simp add: bl2wc.simps bl2nat.simps)
+
+lemma bl2nat_double: "bl2nat xs (Suc n) = 2 * bl2nat xs n"
+proof(induct xs arbitrary: n)
+ case Nil thus "?case"
+ by(simp add: bl2nat.simps)
+next
+ case (Cons x xs) thus "?case"
+ proof -
+ assume ind: "\<And>n. bl2nat xs (Suc n) = 2 * bl2nat xs n "
+ show "bl2nat (x # xs) (Suc n) = 2 * bl2nat (x # xs) n"
+ proof(cases x)
+ case Bk thus "?thesis"
+ apply(simp add: bl2nat.simps)
+ using ind[of "Suc n"] by simp
+ next
+ case Oc thus "?thesis"
+ apply(simp add: bl2nat.simps)
+ using ind[of "Suc n"] by simp
+ qed
+ qed
+qed
+
+
+lemma [simp]: "c \<noteq> [] \<Longrightarrow> 2 * bl2wc (tl c) = bl2wc c - bl2wc c mod 2 "
+apply(case_tac c, simp, case_tac a)
+apply(auto simp: bl2wc.simps bl2nat.simps bl2nat_double)
+done
+
+lemma [simp]:
+ "c \<noteq> [] \<Longrightarrow> bl2wc (Oc # tl c) = Suc (bl2wc c) - bl2wc c mod 2 "
+apply(case_tac c, simp, case_tac a)
+apply(auto simp: bl2wc.simps bl2nat.simps bl2nat_double)
+done
+
+lemma [simp]: "bl2wc (Bk # c) = 2*bl2wc (c)"
+apply(simp add: bl2wc.simps bl2nat.simps bl2nat_double)
+done
+
+lemma [simp]: "bl2wc [Oc] = Suc 0"
+ by(simp add: bl2wc.simps bl2nat.simps)
+
+lemma [simp]: "b \<noteq> [] \<Longrightarrow> bl2wc (tl b) = bl2wc b div 2"
+apply(case_tac b, simp, case_tac a)
+apply(auto simp: bl2wc.simps bl2nat.simps bl2nat_double)
+done
+
+lemma [simp]: "b \<noteq> [] \<Longrightarrow> bl2wc ([hd b]) = bl2wc b mod 2"
+apply(case_tac b, simp, case_tac a)
+apply(auto simp: bl2wc.simps bl2nat.simps bl2nat_double)
+done
+
+lemma [simp]: "\<lbrakk>b \<noteq> []; c \<noteq> []\<rbrakk> \<Longrightarrow> bl2wc (hd b # c) = 2 * bl2wc c + bl2wc b mod 2"
+apply(case_tac b, simp, case_tac a)
+apply(auto simp: bl2wc.simps bl2nat.simps bl2nat_double)
+done
+
+lemma [simp]: " 2 * (bl2wc c div 2) = bl2wc c - bl2wc c mod 2"
+ by(simp add: mult_div_cancel)
+
+lemma [simp]: "bl2wc (Oc # list) mod 2 = Suc 0"
+ by(simp add: bl2wc.simps bl2nat.simps bl2nat_double)
+
+
+declare code.simps[simp del]
+declare nth_of.simps[simp del]
+declare new_tape.simps[simp del]
+
+text {*
+ The lemma relates the one step execution of TMs with the interpreter function @{text "rec_newconf"}.
+ *}
+lemma rec_t_eq_step:
+ "(\<lambda> (s, l, r). s \<le> length tp div 2) c \<Longrightarrow>
+ trpl_code (tstep c tp) =
+ rec_exec rec_newconf [code tp, trpl_code c]"
+apply(cases c, auto simp: tstep.simps)
+proof(case_tac "fetch tp a (case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)",
+ simp add: newconf.simps trpl_code.simps)
+ fix a b c aa ba
+ assume h: "(a::nat) \<le> length tp div 2"
+ "fetch tp a (case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x) = (aa, ba)"
+ moreover hence "actn (code tp) a (bl2wc c) = action_map aa"
+ apply(rule_tac b = "(case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)"
+ in fetch_action_eq, auto)
+ apply(auto split: list.splits)
+ apply(case_tac ab, auto)
+ done
+ moreover from h have "(newstat (code tp) a (bl2wc c)) = ba"
+ apply(rule_tac b = "(case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)"
+ in fetch_state_eq, auto split: list.splits)
+ apply(case_tac ab, auto)
+ done
+ ultimately show
+ "trpl_code (ba, new_tape aa (b, c)) =
+ trpl (newleft (bl2wc b) (bl2wc c) (actn (code tp) a (bl2wc c)))
+ (newstat (code tp) a (bl2wc c)) (newrght (bl2wc b) (bl2wc c)
+ (actn (code tp) a (bl2wc c)))"
+ by(auto simp: new_tape.simps trpl_code.simps
+ newleft.simps newrght.simps split: taction.splits)
+qed
+
+lemma [simp]: "a\<^bsup>0\<^esup> = []"
+apply(simp add: exp_zero)
+done
+lemma [simp]: "bl2nat (Oc # Oc\<^bsup>x\<^esup>) 0 = (2 * 2 ^ x - Suc 0)"
+apply(induct x)
+apply(simp add: bl2nat.simps)
+apply(simp add: bl2nat.simps bl2nat_double exp_ind_def)
+done
+
+lemma [simp]: "bl2nat (Oc\<^bsup>y\<^esup>) 0 = 2^y - Suc 0"
+apply(induct y, auto simp: bl2nat.simps exp_ind_def bl2nat_double)
+apply(case_tac "(2::nat)^y", auto)
+done
+
+lemma [simp]: "bl2nat (Bk\<^bsup>l\<^esup>) n = 0"
+apply(induct l, auto simp: bl2nat.simps bl2nat_double exp_ind_def)
+done
+
+lemma bl2nat_cons_bk: "bl2nat (ks @ [Bk]) 0 = bl2nat ks 0"
+apply(induct ks, auto simp: bl2nat.simps split: block.splits)
+apply(case_tac a, auto simp: bl2nat.simps bl2nat_double)
+done
+
+lemma bl2nat_cons_oc:
+ "bl2nat (ks @ [Oc]) 0 = bl2nat ks 0 + 2 ^ length ks"
+apply(induct ks, auto simp: bl2nat.simps split: block.splits)
+apply(case_tac a, auto simp: bl2nat.simps bl2nat_double)
+done
+
+lemma bl2nat_append:
+ "bl2nat (xs @ ys) 0 = bl2nat xs 0 + bl2nat ys (length xs) "
+proof(induct "length xs" arbitrary: xs ys, simp add: bl2nat.simps)
+ fix x xs ys
+ assume ind:
+ "\<And>xs ys. x = length xs \<Longrightarrow>
+ bl2nat (xs @ ys) 0 = bl2nat xs 0 + bl2nat ys (length xs)"
+ and h: "Suc x = length (xs::block list)"
+ have "\<exists> ks k. xs = ks @ [k]"
+ apply(rule_tac x = "butlast xs" in exI,
+ rule_tac x = "last xs" in exI)
+ using h
+ apply(case_tac xs, auto)
+ done
+ from this obtain ks k where "xs = ks @ [k]" by blast
+ moreover hence
+ "bl2nat (ks @ (k # ys)) 0 = bl2nat ks 0 +
+ bl2nat (k # ys) (length ks)"
+ apply(rule_tac ind) using h by simp
+ ultimately show "bl2nat (xs @ ys) 0 =
+ bl2nat xs 0 + bl2nat ys (length xs)"
+ apply(case_tac k, simp_all add: bl2nat.simps)
+ apply(simp_all only: bl2nat_cons_bk bl2nat_cons_oc)
+ done
+qed
+
+lemma bl2nat_exp: "n \<noteq> 0 \<Longrightarrow> bl2nat bl n = 2^n * bl2nat bl 0"
+apply(induct bl)
+apply(auto simp: bl2nat.simps)
+apply(case_tac a, auto simp: bl2nat.simps bl2nat_double)
+done
+
+lemma nat_minus_eq: "\<lbrakk>a = b; c = d\<rbrakk> \<Longrightarrow> a - c = b - d"
+by auto
+
+lemma tape_of_nat_list_butlast_last:
+ "ys \<noteq> [] \<Longrightarrow> <ys @ [y]> = <ys> @ Bk # Oc\<^bsup>Suc y\<^esup>"
+apply(induct ys, simp, simp)
+apply(case_tac "ys = []", simp add: tape_of_nl_abv
+ tape_of_nat_list.simps)
+apply(simp)
+done
+
+lemma listsum2_append:
+ "\<lbrakk>n \<le> length xs\<rbrakk> \<Longrightarrow> listsum2 (xs @ ys) n = listsum2 xs n"
+apply(induct n)
+apply(auto simp: listsum2.simps nth_append)
+done
+
+lemma strt'_append:
+ "\<lbrakk>n \<le> length xs\<rbrakk> \<Longrightarrow> strt' xs n = strt' (xs @ ys) n"
+proof(induct n arbitrary: xs ys)
+ fix xs ys
+ show "strt' xs 0 = strt' (xs @ ys) 0" by(simp add: strt'.simps)
+next
+ fix n xs ys
+ assume ind:
+ "\<And> xs ys. n \<le> length xs \<Longrightarrow> strt' xs n = strt' (xs @ ys) n"
+ and h: "Suc n \<le> length (xs::nat list)"
+ show "strt' xs (Suc n) = strt' (xs @ ys) (Suc n)"
+ using ind[of xs ys] h
+ apply(simp add: strt'.simps nth_append listsum2_append)
+ done
+qed
+
+lemma length_listsum2_eq:
+ "\<lbrakk>length (ys::nat list) = k\<rbrakk>
+ \<Longrightarrow> length (<ys>) = listsum2 (map Suc ys) k + k - 1"
+apply(induct k arbitrary: ys, simp_all add: listsum2.simps)
+apply(subgoal_tac "\<exists> xs x. ys = xs @ [x]", auto)
+proof -
+ fix xs x
+ assume ind: "\<And>ys. length ys = length xs \<Longrightarrow> length (<ys>)
+ = listsum2 (map Suc ys) (length xs) +
+ length (xs::nat list) - Suc 0"
+ have "length (<xs>)
+ = listsum2 (map Suc xs) (length xs) + length xs - Suc 0"
+ apply(rule_tac ind, simp)
+ done
+ thus "length (<xs @ [x]>) =
+ Suc (listsum2 (map Suc xs @ [Suc x]) (length xs) + x + length xs)"
+ apply(case_tac "xs = []")
+ apply(simp add: tape_of_nl_abv listsum2.simps
+ tape_of_nat_list.simps)
+ apply(simp add: tape_of_nat_list_butlast_last)
+ using listsum2_append[of "length xs" "map Suc xs" "[Suc x]"]
+ apply(simp)
+ done
+next
+ fix k ys
+ assume "length ys = Suc k"
+ thus "\<exists>xs x. ys = xs @ [x]"
+ apply(rule_tac x = "butlast ys" in exI,
+ rule_tac x = "last ys" in exI)
+ apply(case_tac ys, auto)
+ done
+qed
+
+lemma tape_of_nat_list_length:
+ "length (<(ys::nat list)>) =
+ listsum2 (map Suc ys) (length ys) + length ys - 1"
+ using length_listsum2_eq[of ys "length ys"]
+ apply(simp)
+ done
+
+
+
+lemma [simp]:
+ "trpl_code (steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp 0) =
+ rec_exec rec_conf [code tp, bl2wc (<lm>), 0]"
+apply(simp add: steps.simps rec_exec.simps conf_lemma conf.simps
+ inpt.simps trpl_code.simps bl2wc.simps)
+done
+
+text {*
+ The following lemma relates the multi-step interpreter function @{text "rec_conf"}
+ with the multi-step execution of TMs.
+ *}
+lemma rec_t_eq_steps:
+ "turing_basic.t_correct tp \<Longrightarrow>
+ trpl_code (steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp) =
+ rec_exec rec_conf [code tp, bl2wc (<lm>), stp]"
+proof(induct stp)
+ case 0 thus "?case" by(simp)
+next
+ case (Suc n) thus "?case"
+ proof -
+ assume ind:
+ "t_correct tp \<Longrightarrow> trpl_code (steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp n)
+ = rec_exec rec_conf [code tp, bl2wc (<lm>), n]"
+ and h: "t_correct tp"
+ show
+ "trpl_code (steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp (Suc n)) =
+ rec_exec rec_conf [code tp, bl2wc (<lm>), Suc n]"
+ proof(case_tac "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp n",
+ simp only: tstep_red conf_lemma conf.simps)
+ fix a b c
+ assume g: "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp n = (a, b, c) "
+ hence "conf (code tp) (bl2wc (<lm>)) n= trpl_code (a, b, c)"
+ using ind h
+ apply(simp add: conf_lemma)
+ done
+ moreover hence
+ "trpl_code (tstep (a, b, c) tp) =
+ rec_exec rec_newconf [code tp, trpl_code (a, b, c)]"
+ thm rec_t_eq_step
+ apply(rule_tac rec_t_eq_step)
+ using h g
+ apply(simp add: s_keep)
+ done
+ ultimately show
+ "trpl_code (tstep (a, b, c) tp) =
+ newconf (code tp) (conf (code tp) (bl2wc (<lm>)) n)"
+ by(simp add: newconf_lemma)
+ qed
+ qed
+qed
+
+lemma [simp]: "bl2wc (Bk\<^bsup>m\<^esup>) = 0"
+apply(induct m)
+apply(simp, simp)
+done
+
+lemma [simp]: "bl2wc (Oc\<^bsup>rs\<^esup>@Bk\<^bsup>n\<^esup>) = bl2wc (Oc\<^bsup>rs\<^esup>)"
+apply(induct rs, simp,
+ simp add: bl2wc.simps bl2nat.simps bl2nat_double)
+done
+
+lemma lg_power: "x > Suc 0 \<Longrightarrow> lg (x ^ rs) x = rs"
+proof(simp add: lg.simps, auto)
+ fix xa
+ assume h: "Suc 0 < x"
+ show "Max {ya. ya \<le> x ^ rs \<and> lgR [x ^ rs, x, ya]} = rs"
+ apply(rule_tac Max_eqI, simp_all add: lgR.simps)
+ apply(simp add: h)
+ using x_less_exp[of x rs] h
+ apply(simp)
+ done
+next
+ assume "\<not> Suc 0 < x ^ rs" "Suc 0 < x"
+ thus "rs = 0"
+ apply(case_tac "x ^ rs", simp, simp)
+ done
+next
+ assume "Suc 0 < x" "\<forall>xa. \<not> lgR [x ^ rs, x, xa]"
+ thus "rs = 0"
+ apply(simp only:lgR.simps)
+ apply(erule_tac x = rs in allE, simp)
+ done
+qed
+
+text {*
+ The following lemma relates execution of TMs with
+ the multi-step interpreter function @{text "rec_nonstop"}. Note,
+ @{text "rec_nonstop"} is constructed using @{text "rec_conf"}.
+ *}
+lemma nonstop_t_eq:
+ "\<lbrakk>steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>);
+ turing_basic.t_correct tp;
+ rs > 0\<rbrakk>
+ \<Longrightarrow> rec_exec rec_nonstop [code tp, bl2wc (<lm>), stp] = 0"
+proof(simp add: nonstop_lemma nonstop.simps nstd.simps)
+ assume h: "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+ and tc_t: "turing_basic.t_correct tp" "rs > 0"
+ have g: "rec_exec rec_conf [code tp, bl2wc (<lm>), stp] =
+ trpl_code (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup>@Bk\<^bsup>n\<^esup>)"
+ using rec_t_eq_steps[of tp l lm stp] tc_t h
+ by(simp)
+ thus "\<not> NSTD (conf (code tp) (bl2wc (<lm>)) stp)"
+ proof(auto simp: NSTD.simps)
+ show "stat (conf (code tp) (bl2wc (<lm>)) stp) = 0"
+ using g
+ by(auto simp: conf_lemma trpl_code.simps)
+ next
+ show "left (conf (code tp) (bl2wc (<lm>)) stp) = 0"
+ using g
+ by(simp add: conf_lemma trpl_code.simps)
+ next
+ show "rght (conf (code tp) (bl2wc (<lm>)) stp) =
+ 2 ^ lg (Suc (rght (conf (code tp) (bl2wc (<lm>)) stp))) 2 - Suc 0"
+ using g h
+ proof(simp add: conf_lemma trpl_code.simps)
+ have "2 ^ lg (Suc (bl2wc (Oc\<^bsup>rs\<^esup>))) 2 = Suc (bl2wc (Oc\<^bsup>rs\<^esup>))"
+ apply(simp add: bl2wc.simps lg_power)
+ done
+ thus "bl2wc (Oc\<^bsup>rs\<^esup>) = 2 ^ lg (Suc (bl2wc (Oc\<^bsup>rs\<^esup>))) 2 - Suc 0"
+ apply(simp)
+ done
+ qed
+ next
+ show "0 < rght (conf (code tp) (bl2wc (<lm>)) stp)"
+ using g h tc_t
+ apply(simp add: conf_lemma trpl_code.simps bl2wc.simps
+ bl2nat.simps)
+ apply(case_tac rs, simp, simp add: bl2nat.simps)
+ done
+ qed
+qed
+
+lemma [simp]: "actn m 0 r = 4"
+by(simp add: actn.simps)
+
+lemma [simp]: "newstat m 0 r = 0"
+by(simp add: newstat.simps)
+
+declare exp_def[simp del]
+
+lemma halt_least_step:
+ "\<lbrakk>steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs \<^esup> @ Bk\<^bsup>n\<^esup>);
+ turing_basic.t_correct tp;
+ 0<rs\<rbrakk> \<Longrightarrow>
+ \<exists> stp. (nonstop (code tp) (bl2wc (<lm>)) stp = 0 \<and>
+ (\<forall> stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stp \<le> stp'))"
+proof(induct stp, simp add: steps.simps, simp)
+ fix stp
+ assume ind:
+ "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>) \<Longrightarrow>
+ \<exists>stp. nonstop (code tp) (bl2wc (<lm>)) stp = 0 \<and>
+ (\<forall>stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stp \<le> stp')"
+ and h:
+ "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp (Suc stp) = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+ "turing_basic.t_correct tp"
+ "0 < rs"
+ from h show
+ "\<exists>stp. nonstop (code tp) (bl2wc (<lm>)) stp = 0
+ \<and> (\<forall>stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stp \<le> stp')"
+ proof(simp add: tstep_red,
+ case_tac "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp", simp,
+ case_tac a, simp add: tstep_0)
+ assume "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+ thus "\<exists>stp. nonstop (code tp) (bl2wc (<lm>)) stp = 0 \<and>
+ (\<forall>stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stp \<le> stp')"
+ apply(erule_tac ind)
+ done
+ next
+ fix a b c nat
+ assume "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (a, b, c)"
+ "a = Suc nat"
+ thus "\<exists>stp. nonstop (code tp) (bl2wc (<lm>)) stp = 0 \<and>
+ (\<forall>stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stp \<le> stp')"
+ using h
+ apply(rule_tac x = "Suc stp" in exI, auto)
+ apply(drule_tac nonstop_t_eq, simp_all add: nonstop_lemma)
+ proof -
+ fix stp'
+ assume g:"steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (Suc nat, b, c)"
+ "nonstop (code tp) (bl2wc (<lm>)) stp' = 0"
+ thus "Suc stp \<le> stp'"
+ proof(case_tac "Suc stp \<le> stp'", simp, simp)
+ assume "\<not> Suc stp \<le> stp'"
+ hence "stp' \<le> stp" by simp
+ hence "\<not> isS0 (steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp')"
+ using g
+ apply(case_tac "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp'",auto,
+ simp add: isS0_def)
+ apply(subgoal_tac "\<exists> n. stp = stp' + n",
+ auto simp: steps_add steps_0)
+ apply(rule_tac x = "stp - stp'" in exI, simp)
+ done
+ hence "nonstop (code tp) (bl2wc (<lm>)) stp' = 1"
+ proof(case_tac "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp'",
+ simp add: isS0_def nonstop.simps)
+ fix a b c
+ assume k:
+ "0 < a" "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp' = (a, b, c)"
+ thus " NSTD (conf (code tp) (bl2wc (<lm>)) stp')"
+ using rec_t_eq_steps[of tp l lm stp'] h
+ proof(simp add: conf_lemma)
+ assume "trpl_code (a, b, c) = conf (code tp) (bl2wc (<lm>)) stp'"
+ moreover have "NSTD (trpl_code (a, b, c))"
+ using k
+ apply(auto simp: trpl_code.simps NSTD.simps)
+ done
+ ultimately show "NSTD (conf (code tp) (bl2wc (<lm>)) stp')" by simp
+ qed
+ qed
+ thus "False" using g by simp
+ qed
+ qed
+ qed
+qed
+
+(*
+lemma halt_steps_ex:
+ "\<lbrakk>steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>);
+ lm \<noteq> []; turing_basic.t_correct tp; 0<rs\<rbrakk> \<Longrightarrow>
+ \<exists> t. rec_calc_rel (rec_halt (length lm)) (code tp # lm) t"
+apply(drule_tac halt_least_step, auto)
+apply(rule_tac x = stp in exI)
+apply(simp add: halt_lemma nonstop_lemma)
+apply(auto)
+done*)
+thm loR.simps
+
+lemma conf_trpl_ex: "\<exists> p q r. conf m (bl2wc (<lm>)) stp = trpl p q r"
+apply(induct stp, auto simp: conf.simps inpt.simps trpl.simps
+ newconf.simps)
+apply(rule_tac x = 0 in exI, rule_tac x = 1 in exI,
+ rule_tac x = "bl2wc (<lm>)" in exI)
+apply(simp)
+done
+
+lemma nonstop_rgt_ex:
+ "nonstop m (bl2wc (<lm>)) stpa = 0 \<Longrightarrow> \<exists> r. conf m (bl2wc (<lm>)) stpa = trpl 0 0 r"
+apply(auto simp: nonstop.simps NSTD.simps split: if_splits)
+using conf_trpl_ex[of m lm stpa]
+apply(auto)
+done
+
+lemma [elim]: "x > Suc 0 \<Longrightarrow> Max {u. x ^ u dvd x ^ r} = r"
+proof(rule_tac Max_eqI)
+ assume "x > Suc 0"
+ thus "finite {u. x ^ u dvd x ^ r}"
+ apply(rule_tac finite_power_dvd, auto)
+ done
+next
+ fix y
+ assume "Suc 0 < x" "y \<in> {u. x ^ u dvd x ^ r}"
+ thus "y \<le> r"
+ apply(case_tac "y\<le> r", simp)
+ apply(subgoal_tac "\<exists> d. y = r + d")
+ apply(auto simp: power_add)
+ apply(rule_tac x = "y - r" in exI, simp)
+ done
+next
+ show "r \<in> {u. x ^ u dvd x ^ r}" by simp
+qed
+
+lemma lo_power: "x > Suc 0 \<Longrightarrow> lo (x ^ r) x = r"
+apply(auto simp: lo.simps loR.simps mod_dvd_simp)
+apply(case_tac "x^r", simp_all)
+done
+
+lemma lo_rgt: "lo (trpl 0 0 r) (Pi 2) = r"
+apply(simp add: trpl.simps lo_power)
+done
+
+lemma conf_keep:
+ "conf m lm stp = trpl 0 0 r \<Longrightarrow>
+ conf m lm (stp + n) = trpl 0 0 r"
+apply(induct n)
+apply(auto simp: conf.simps newconf.simps newleft.simps
+ newrght.simps rght.simps lo_rgt)
+done
+
+lemma halt_state_keep_steps_add:
+ "\<lbrakk>nonstop m (bl2wc (<lm>)) stpa = 0\<rbrakk> \<Longrightarrow>
+ conf m (bl2wc (<lm>)) stpa = conf m (bl2wc (<lm>)) (stpa + n)"
+apply(drule_tac nonstop_rgt_ex, auto simp: conf_keep)
+done
+
+lemma halt_state_keep:
+ "\<lbrakk>nonstop m (bl2wc (<lm>)) stpa = 0; nonstop m (bl2wc (<lm>)) stpb = 0\<rbrakk> \<Longrightarrow>
+ conf m (bl2wc (<lm>)) stpa = conf m (bl2wc (<lm>)) stpb"
+apply(case_tac "stpa > stpb")
+using halt_state_keep_steps_add[of m lm stpb "stpa - stpb"]
+apply simp
+using halt_state_keep_steps_add[of m lm stpa "stpb - stpa"]
+apply(simp)
+done
+
+thm halt_lemma
+
+text {*
+ The correntess of @{text "rec_F"} which relates the interpreter function @{text "rec_F"} with the
+ execution of of TMs.
+ *}
+lemma F_t_halt_eq:
+ "\<lbrakk>steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup>@Bk\<^bsup>n\<^esup>);
+ turing_basic.t_correct tp;
+ 0<rs\<rbrakk>
+ \<Longrightarrow> rec_calc_rel rec_F [code tp, (bl2wc (<lm>))] (rs - Suc 0)"
+apply(frule_tac halt_least_step, auto)
+apply(frule_tac nonstop_t_eq, auto simp: nonstop_lemma)
+using rec_t_eq_steps[of tp l lm stp]
+apply(simp add: conf_lemma)
+proof -
+ fix stpa
+ assume h:
+ "nonstop (code tp) (bl2wc (<lm>)) stpa = 0"
+ "\<forall>stp'. nonstop (code tp) (bl2wc (<lm>)) stp' = 0 \<longrightarrow> stpa \<le> stp'"
+ "nonstop (code tp) (bl2wc (<lm>)) stp = 0"
+ "trpl_code (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>) = conf (code tp) (bl2wc (<lm>)) stp"
+ "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+ hence g1: "conf (code tp) (bl2wc (<lm>)) stpa = trpl_code (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+ using halt_state_keep[of "code tp" lm stpa stp]
+ by(simp)
+ moreover have g2:
+ "rec_calc_rel rec_halt [code tp, (bl2wc (<lm>))] stpa"
+ using h
+ apply(simp add: halt_lemma nonstop_lemma, auto)
+ done
+ show
+ "rec_calc_rel rec_F [code tp, (bl2wc (<lm>))] (rs - Suc 0)"
+ proof -
+ have
+ "rec_calc_rel rec_F [code tp, (bl2wc (<lm>))]
+ (valu (rght (conf (code tp) (bl2wc (<lm>)) stpa)))"
+ apply(rule F_lemma) using g2 h by auto
+ moreover have
+ "valu (rght (conf (code tp) (bl2wc (<lm>)) stpa)) = rs - Suc 0"
+ using g1
+ apply(simp add: valu.simps trpl_code.simps
+ bl2wc.simps bl2nat_append lg_power)
+ done
+ ultimately show "?thesis" by simp
+ qed
+qed
+
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/utm/UTM.thy Sat Sep 29 12:38:12 2012 +0000
@@ -0,0 +1,4704 @@
+theory UTM
+imports Main uncomputable recursive abacus UF GCD
+begin
+
+section {* Wang coding of input arguments *}
+
+text {*
+ The direct compilation of the universal function @{text "rec_F"} can not give us UTM, because @{text "rec_F"} is of arity 2,
+ where the first argument represents the Godel coding of the TM being simulated and the second argument represents the right number (in Wang's coding) of the TM tape.
+ (Notice, left number is always @{text "0"} at the very beginning). However, UTM needs to simulate the execution of any TM which may
+ very well take many input arguments. Therefore, a initialization TM needs to run before the TM compiled from @{text "rec_F"}, and the sequential
+ composition of these two TMs will give rise to the UTM 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 @{text "rec_F"} as the second
+ argument.
+
+ However, this initialization TM (named @{text "t_wcode"}) can not be constructed by compiling from any resurve function, because every recursive
+ function takes a fixed number of input arguments, while @{text "t_wcode"} needs to take varying number of arguments and tranform them into
+ Wang's coding. Therefore, this section give a direct construction of @{text "t_wcode"} with just some parts being obtained from recursive functions.
+*}
+
+definition rec_twice :: "recf"
+ where
+ "rec_twice = Cn 1 rec_mult [id 1 0, constn 2]"
+
+definition rec_fourtimes :: "recf"
+ where
+ "rec_fourtimes = Cn 1 rec_mult [id 1 0, constn 4]"
+
+definition abc_twice :: "abc_prog"
+ where
+ "abc_twice = (let (aprog, ary, fp) = rec_ci rec_twice in
+ aprog [+] dummy_abc ((Suc 0)))"
+
+definition abc_fourtimes :: "abc_prog"
+ where
+ "abc_fourtimes = (let (aprog, ary, fp) = rec_ci rec_fourtimes in
+ aprog [+] dummy_abc ((Suc 0)))"
+
+definition twice_ly :: "nat list"
+ where
+ "twice_ly = layout_of abc_twice"
+
+definition fourtimes_ly :: "nat list"
+ where
+ "fourtimes_ly = layout_of abc_fourtimes"
+
+definition t_twice :: "tprog"
+ where
+ "t_twice = change_termi_state (tm_of (abc_twice) @ (tMp 1 (start_of twice_ly (length abc_twice) - Suc 0)))"
+
+definition t_fourtimes :: "tprog"
+ where
+ "t_fourtimes = change_termi_state (tm_of (abc_fourtimes) @
+ (tMp 1 (start_of fourtimes_ly (length abc_fourtimes) - Suc 0)))"
+
+
+definition t_twice_len :: "nat"
+ where
+ "t_twice_len = length t_twice div 2"
+
+definition t_wcode_main_first_part:: "tprog"
+ where
+ "t_wcode_main_first_part \<equiv>
+ [(L, 1), (L, 2), (L, 7), (R, 3),
+ (R, 4), (W0, 3), (R, 4), (R, 5),
+ (W1, 6), (R, 5), (R, 13), (L, 6),
+ (R, 0), (R, 8), (R, 9), (Nop, 8),
+ (R, 10), (W0, 9), (R, 10), (R, 11),
+ (W1, 12), (R, 11), (R, t_twice_len + 14), (L, 12)]"
+
+definition t_wcode_main :: "tprog"
+ where
+ "t_wcode_main = (t_wcode_main_first_part @ tshift t_twice 12 @ [(L, 1), (L, 1)]
+ @ tshift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)])"
+
+fun bl_bin :: "block 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 = "block 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\<^bsup>ln\<^esup> @ Oc # ires \<and>
+ r = Oc\<^bsup>(Suc (Suc rs))\<^esup> @ Bk\<^bsup>rn \<^esup>)"
+
+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\<^bsup>ln\<^esup> @ Oc # ires \<and>
+ r = Oc\<^bsup>Suc (Suc (Suc 2*rs))\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ml\<^esup> @ Oc # Oc # ires \<and>
+ r = Bk\<^bsup>mr\<^esup> @ Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+fun wcode_erase1 :: "bin_inv_t"
+ where
+"wcode_erase1 ires rs (l, r) =
+ (\<exists> ln rn. l = Oc # ires \<and>
+ tl r = Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ml\<^esup> @ Oc # ires \<and>
+ r = Bk\<^bsup>mr\<^esup> @ Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ml\<^esup> @ Bk # Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires \<and>
+ r = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ln\<^esup> @ Oc # ires \<and>
+ r = Bk # Oc\<^bsup>(Suc (Suc rs))\<^esup> @ Bk\<^bsup>rn \<^esup>)"
+
+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\<^bsup>ml\<^esup> @ Bk # Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires \<and>
+ r = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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 [simp]: "<0::nat> = [Oc]"
+apply(simp add: tape_of_nat_abv exponent_def tape_of_nat_list.simps)
+done
+
+lemma tape_of_Suc_nat: "<Suc (a ::nat)> = replicate a Oc @ [Oc, Oc]"
+apply(simp add: tape_of_nat_abv exp_ind tape_of_nat_list.simps)
+apply(simp only: exp_ind_def[THEN sym])
+apply(simp only: exp_ind, simp, simp add: exponent_def)
+done
+
+lemma [simp]: "length (<a::nat>) = Suc a"
+apply(simp add: tape_of_nat_abv tape_of_nat_list.simps)
+done
+
+lemma [simp]: "<[a::nat]> = <a>"
+apply(simp add: tape_of_nat_abv tape_of_nl_abv exponent_def
+ tape_of_nat_list.simps)
+done
+
+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
+
+declare exp_def[simp del]
+
+lemma bl_bin_nat_Suc:
+ "bl_bin (<Suc a>) = bl_bin (<a>) + 2^(Suc a)"
+apply(simp add: tape_of_nat_abv bin_wc_eq)
+apply(simp add: bl2wc.simps)
+done
+lemma [simp]: " rev (a\<^bsup>aa\<^esup>) = a\<^bsup>aa\<^esup>"
+apply(simp add: exponent_def)
+done
+
+declare tape_of_nl_abv_cons[simp del]
+
+lemma tape_of_nl_rev: "rev (<lm::nat list>) = (<rev lm>)"
+apply(induct lm rule: list_tl_induct, simp)
+apply(case_tac "list = []", simp add: tape_of_nl_abv tape_of_nat_list.simps)
+apply(simp add: tape_of_nat_list_butlast_last tape_of_nl_abv_cons)
+done
+lemma [simp]: "a\<^bsup>Suc 0\<^esup> = [a]"
+by(simp add: exp_def)
+lemma tape_of_nl_cons_app1: "(<a # xs @ [b]>) = (Oc\<^bsup>Suc a\<^esup> @ Bk # (<xs@ [b]>))"
+apply(case_tac xs, simp add: tape_of_nl_abv tape_of_nat_list.simps)
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps)
+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\<^bsup>Suc a\<^esup>"
+apply(simp add: tape_of_nat_abv)
+done
+lemma tape_of_nl_cons_app2: "(<c # xs @ [b]>) = (<c # xs> @ Bk # Oc\<^bsup>Suc b\<^esup>)"
+proof(induct "length xs" arbitrary: xs c,
+ simp add: tape_of_nl_abv tape_of_nat_list.simps)
+ fix x xs c
+ assume ind: "\<And>xs c. x = length xs \<Longrightarrow> <c # xs @ [b]> =
+ <c # xs> @ Bk # Oc\<^bsup>Suc b\<^esup>"
+ and h: "Suc x = length (xs::nat list)"
+ show "<c # xs @ [b]> = <c # xs> @ Bk # Oc\<^bsup>Suc b\<^esup>"
+ proof(case_tac xs, simp add: tape_of_nl_abv tape_of_nat_list.simps)
+ fix a list
+ assume g: "xs = a # list"
+ hence k: "<a # list @ [b]> = <a # list> @ Bk # Oc\<^bsup>Suc b\<^esup>"
+ apply(rule_tac ind)
+ using h
+ apply(simp)
+ done
+ from g and k show "<c # xs @ [b]> = <c # xs> @ Bk # Oc\<^bsup>Suc b\<^esup>"
+ apply(simp add: tape_of_nl_abv tape_of_nat_list.simps)
+ done
+ qed
+qed
+
+lemma [simp]: "length (<aa # a # list>) = Suc (Suc aa) + length (<a # list>)"
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps)
+done
+
+lemma [simp]: "bl_bin (Oc\<^bsup>Suc aa\<^esup> @ Bk # tape_of_nat_list (a # lista) @ [Bk, Oc]) =
+ bl_bin (Oc\<^bsup>Suc aa\<^esup> @ Bk # tape_of_nat_list (a # lista)) +
+ 2* 2^(length (Oc\<^bsup>Suc aa\<^esup> @ Bk # tape_of_nat_list (a # lista)))"
+using bl_bin_bk_oc[of "Oc\<^bsup>Suc aa\<^esup> @ Bk # tape_of_nat_list (a # lista)"]
+apply(simp)
+done
+
+lemma [simp]:
+ "bl_bin (<aa # list>) + (4 * rs + 4) * 2 ^ (length (<aa # list>) - Suc 0)
+ = bl_bin (Oc\<^bsup>Suc aa\<^esup> @ Bk # <list @ [0]>) + rs * (2 * 2 ^ (aa + length (<list @ [0]>)))"
+apply(case_tac "list", simp add: add_mult_distrib, simp)
+apply(simp add: tape_of_nl_cons_app2 add_mult_distrib)
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps)
+done
+
+lemma tape_of_nl_app_Suc: "((<list @ [Suc ab]>)) = (<list @ [ab]>) @ [Oc]"
+apply(induct list)
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps exp_ind)
+apply(case_tac list)
+apply(simp_all add:tape_of_nl_abv tape_of_nat_list.simps exp_ind)
+done
+
+lemma [simp]: "bl_bin (Oc # Oc\<^bsup>aa\<^esup> @ Bk # <list @ [ab]> @ [Oc])
+ = bl_bin (Oc # Oc\<^bsup>aa\<^esup> @ Bk # <list @ [ab]>) +
+ 2^(length (Oc # Oc\<^bsup>aa\<^esup> @ Bk # <list @ [ab]>))"
+apply(simp add: bin_wc_eq)
+apply(simp add: bl2nat_cons_oc bl2wc.simps)
+using bl2nat_cons_oc[of "Oc # Oc\<^bsup>aa\<^esup> @ Bk # <list @ [ab]>"]
+apply(simp)
+done
+lemma [simp]: "bl_bin (Oc # Oc\<^bsup>aa\<^esup> @ Bk # <list @ [ab]>) + (4 * 2 ^ (aa + length (<list @ [ab]>)) +
+ 4 * (rs * 2 ^ (aa + length (<list @ [ab]>)))) =
+ bl_bin (Oc # Oc\<^bsup>aa\<^esup> @ 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]
+
+text{* double case*}
+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 :: "t_conf \<Rightarrow> nat"
+ where
+ "wcode_double_case_state (st, l, r) =
+ 13 - st"
+
+fun wcode_double_case_step :: "t_conf \<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 :: "t_conf \<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 :: "(t_conf \<times> t_conf) set"
+ where "wcode_double_case_le \<equiv> (inv_image lex_pair wcode_double_case_measure)"
+
+lemma [intro]: "wf lex_pair"
+by(auto intro:wf_lex_prod simp:lex_pair_def)
+
+lemma wf_wcode_double_case_le[intro]: "wf wcode_double_case_le"
+by(auto intro:wf_inv_image simp: wcode_double_case_le_def )
+term fetch
+
+lemma [simp]: "fetch t_wcode_main (Suc 0) Bk = (L, Suc 0)"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main (Suc 0) Oc = (L, Suc (Suc 0))"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main (Suc (Suc 0)) Oc = (R, 3)"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main (Suc (Suc (Suc 0))) Bk = (R, 4)"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main (Suc (Suc (Suc 0))) Oc = (W0, 3)"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 4 Bk = (R, 4)"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 4 Oc = (R, 5)"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 5 Oc = (R, 5)"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 5 Bk = (W1, 6)"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 6 Bk = (R, 13)"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 6 Oc = (L, 6)"
+apply(simp add: t_wcode_main_def t_wcode_main_first_part_def
+ fetch.simps nth_of.simps)
+done
+lemma [elim]: "Bk\<^bsup>mr\<^esup> = [] \<Longrightarrow> mr = 0"
+apply(case_tac mr, auto simp: exponent_def)
+done
+
+lemma [simp]: "wcode_on_left_moving_1 ires rs (b, []) = False"
+apply(simp add: wcode_on_left_moving_1.simps wcode_on_left_moving_1_B.simps
+ wcode_on_left_moving_1_O.simps, auto)
+done
+
+
+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 [simp]: "wcode_on_left_moving_1 ires rs (b, r) \<Longrightarrow> b \<noteq> []"
+apply(simp add: wcode_double_case_inv_simps, auto)
+done
+
+
+lemma [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(case_tac ml, simp)
+apply(rule_tac x = "mr - Suc (Suc 0)" in exI, rule_tac x = rn in exI)
+apply(case_tac mr, simp, case_tac nat, simp, simp add: exp_ind)
+apply(rule_tac disjI1)
+apply(rule_tac x = nat in exI, rule_tac x = "Suc mr" in exI, rule_tac x = rn in exI,
+ simp add: exp_ind_def)
+apply(erule_tac exE)+
+apply(simp)
+done
+
+
+lemma [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(erule_tac [!] exE)+
+apply(case_tac mr, simp, simp add: exp_ind_def)
+apply(rule_tac x = ln in exI, rule_tac x = rn in exI, simp)
+done
+
+
+lemma [simp]: "wcode_on_checking_1 ires rs (b, []) = False"
+apply(auto simp: wcode_double_case_inv_simps)
+done
+
+lemma [simp]: "wcode_on_checking_1 ires rs (b, Bk # list) = False"
+apply(auto simp: wcode_double_case_inv_simps)
+done
+
+lemma [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)+
+apply(rule_tac x = ln in exI, rule_tac x = rn in exI, simp)
+done
+
+
+lemma [simp]: "wcode_on_checking_1 ires rs (b, []) = False"
+apply(simp add: wcode_double_case_inv_simps)
+done
+
+lemma [simp]: "wcode_on_checking_1 ires rs ([], Bk # list) = False"
+apply(simp add: wcode_double_case_inv_simps)
+done
+
+lemma [simp]: "wcode_erase1 ires rs (b, []) = False"
+apply(simp add: wcode_double_case_inv_simps)
+done
+
+lemma [simp]: "wcode_on_right_moving_1 ires rs (b, []) = False"
+apply(simp add: wcode_double_case_inv_simps exp_ind_def)
+done
+
+lemma [simp]: "wcode_on_right_moving_1 ires rs (b, []) = False"
+apply(simp add: wcode_double_case_inv_simps exp_ind_def)
+done
+
+lemma [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(rule_tac x = "Suc ml" in exI, rule_tac x = "mr - Suc 0" in exI,
+ rule_tac x = rn in exI)
+apply(simp add: exp_ind_def)
+apply(case_tac mr, simp, simp add: exp_ind_def)
+done
+
+lemma [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(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 add: exp_ind_def)
+apply(case_tac ml, simp, case_tac nat, simp, simp)
+apply(simp add: exp_ind_def)
+done
+
+lemma [simp]:
+ "wcode_on_right_moving_1 ires rs (b, []) \<Longrightarrow> False"
+apply(simp add: wcode_double_case_inv_simps exponent_def)
+done
+
+lemma [elim]: "\<lbrakk>wcode_erase1 ires rs (b, Bk # ba); Bk # b = aa \<and> list = ba; c = Bk # ba\<rbrakk>
+ \<Longrightarrow> wcode_on_right_moving_1 ires rs (aa, ba)"
+apply(simp only: wcode_double_case_inv_simps)
+apply(erule_tac exE)+
+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)
+done
+
+lemma [elim]: "\<lbrakk>wcode_erase1 ires rs (aa, Oc # list); b = aa \<and> Bk # list = ba\<rbrakk> \<Longrightarrow>
+ wcode_erase1 ires rs (aa, ba)"
+apply(simp only: wcode_double_case_inv_simps)
+apply(erule_tac exE)+
+apply(rule_tac x = ln in exI, rule_tac x = rn in exI, auto)
+done
+
+lemma [elim]: "\<lbrakk>wcode_goon_right_moving_1 ires rs (aa, []); b = aa \<and> [Oc] = ba\<rbrakk>
+ \<Longrightarrow> wcode_backto_standard_pos ires rs (aa, ba)"
+apply(simp only: wcode_double_case_inv_simps)
+apply(erule_tac exE)+
+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)
+apply(case_tac mr, simp_all add: exponent_def)
+done
+
+lemma [elim]:
+ "\<lbrakk>wcode_goon_right_moving_1 ires rs (aa, Bk # list); b = aa \<and> Oc # list = ba\<rbrakk>
+ \<Longrightarrow> wcode_backto_standard_pos ires rs (aa, ba)"
+apply(simp only: wcode_double_case_inv_simps)
+apply(erule_tac exE)+
+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 - Suc 0" in exI, simp)
+apply(case_tac mr, simp, case_tac rn, simp, simp_all add: exp_ind_def)
+done
+
+lemma [elim]: "\<lbrakk>wcode_goon_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(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 add: exp_ind_def)
+apply(case_tac mr, simp, case_tac rn, simp_all add: exp_ind_def)
+done
+
+lemma [elim]: "\<lbrakk>wcode_backto_standard_pos ires rs (b, []); Bk # b = aa\<rbrakk> \<Longrightarrow> False"
+apply(auto simp: wcode_double_case_inv_simps wcode_backto_standard_pos_O.simps
+ wcode_backto_standard_pos_B.simps)
+apply(case_tac mr, simp_all add: exp_ind_def)
+done
+
+lemma [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)+
+apply(rule_tac x = ln in exI, rule_tac x = rn in exI, simp)
+apply(auto)
+apply(case_tac [!] mr, simp_all add: exp_ind_def)
+done
+
+lemma [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 [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)
+apply(case_tac mr, simp, simp add: exp_ind_def)
+done
+
+lemma [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(case_tac ml, simp)
+apply(rule_tac disjI1, rule_tac conjI)
+apply(rule_tac x = ln in exI, simp, rule_tac x = rn in exI, simp)
+apply(rule_tac disjI2)
+apply(rule_tac x = nat in exI, rule_tac x = "Suc mr" in exI, rule_tac x = ln in exI,
+ rule_tac x = rn in exI, simp)
+apply(simp add: exp_ind_def)
+done
+
+declare new_tape.simps[simp del] nth_of.simps[simp del] fetch.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. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main 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. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main 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 add: tstep_red)
+ fix na a b c
+ show "a \<noteq> 13 \<and> wcode_double_case_inv a ires rs (b, c) \<longrightarrow>
+ (case tstep (a, b, c) t_wcode_main of (st, x) \<Rightarrow>
+ wcode_double_case_inv st ires rs x) \<and>
+ (tstep (a, b, c) t_wcode_main, 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: tstep.simps,
+ case_tac [!] c, simp_all, case_tac [!] "(c::block list)!0")
+ apply(simp_all add: new_tape.simps 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 add: exp_ind_def)
+ apply(rule_tac x = "Suc 0" in exI, simp add: exp_ind_def)
+ apply(auto)
+ 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 = steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main
+ in \<exists>n. P (f n) \<and> Q (f n)"
+ apply(simp add: Let_def)
+ done
+qed
+
+lemma [elim]: "t_ncorrect tp
+ \<Longrightarrow> t_ncorrect (abacus.tshift tp a)"
+apply(simp add: t_ncorrect.simps shift_length)
+done
+
+lemma tshift_fetch: "\<lbrakk> fetch tp a b = (aa, st'); 0 < st'\<rbrakk>
+ \<Longrightarrow> fetch (abacus.tshift tp (length tp1 div 2)) a b
+ = (aa, st' + length tp1 div 2)"
+apply(subgoal_tac "a > 0")
+apply(auto simp: fetch.simps nth_of.simps shift_length nth_map
+ tshift.simps split: block.splits if_splits)
+done
+
+lemma t_steps_steps_eq: "\<lbrakk>steps (st, l, r) tp stp = (st', l', r');
+ 0 < st';
+ 0 < st \<and> st \<le> length tp div 2;
+ t_ncorrect tp1;
+ t_ncorrect tp\<rbrakk>
+ \<Longrightarrow> t_steps (st + length tp1 div 2, l, r) (tshift tp (length tp1 div 2),
+ length tp1 div 2) stp
+ = (st' + length tp1 div 2, l', r')"
+apply(induct stp arbitrary: st' l' r', simp add: steps.simps t_steps.simps,
+ simp add: tstep_red stepn)
+apply(case_tac "(steps (st, l, r) tp stp)", simp)
+proof -
+ fix stp st' l' r' a b c
+ assume ind: "\<And>st' l' r'.
+ \<lbrakk>a = st' \<and> b = l' \<and> c = r'; 0 < st'\<rbrakk>
+ \<Longrightarrow> t_steps (st + length tp1 div 2, l, r)
+ (abacus.tshift tp (length tp1 div 2), length tp1 div 2) stp =
+ (st' + length tp1 div 2, l', r')"
+ and h: "tstep (a, b, c) tp = (st', l', r')" "0 < st'" "t_ncorrect tp1" "t_ncorrect tp"
+ have k: "t_steps (st + length tp1 div 2, l, r) (abacus.tshift tp (length tp1 div 2),
+ length tp1 div 2) stp = (a + length tp1 div 2, b, c)"
+ apply(rule_tac ind, simp)
+ using h
+ apply(case_tac a, simp_all add: tstep.simps fetch.simps)
+ done
+ from h and this show "t_step (t_steps (st + length tp1 div 2, l, r) (abacus.tshift tp (length tp1 div 2), length tp1 div 2) stp)
+ (abacus.tshift tp (length tp1 div 2), length tp1 div 2) =
+ (st' + length tp1 div 2, l', r')"
+ apply(simp add: k)
+ apply(simp add: tstep.simps t_step.simps)
+ apply(case_tac "fetch tp a (case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)", simp)
+ apply(subgoal_tac "fetch (abacus.tshift tp (length tp1 div 2)) a
+ (case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x) = (aa, st' + length tp1 div 2)", simp)
+ apply(simp add: tshift_fetch)
+ done
+qed
+
+lemma t_tshift_lemma: "\<lbrakk> steps (st, l, r) tp stp = (st', l', r');
+ st' \<noteq> 0;
+ stp > 0;
+ 0 < st \<and> st \<le> length tp div 2;
+ t_ncorrect tp1;
+ t_ncorrect tp;
+ t_ncorrect tp2
+ \<rbrakk>
+ \<Longrightarrow> \<exists> stp>0. steps (st + length tp1 div 2, l, r) (tp1 @ tshift tp (length tp1 div 2) @ tp2) stp
+ = (st' + length tp1 div 2, l', r')"
+proof -
+ assume h: "steps (st, l, r) tp stp = (st', l', r')"
+ "st' \<noteq> 0" "stp > 0"
+ "0 < st \<and> st \<le> length tp div 2"
+ "t_ncorrect tp1"
+ "t_ncorrect tp"
+ "t_ncorrect tp2"
+ from h have
+ "\<exists>stp>0. t_steps (st + length tp1 div 2, l, r) (tp1 @ abacus.tshift tp (length tp1 div 2) @ tp2, 0) stp =
+ (st' + length tp1 div 2, l', r')"
+ apply(rule_tac stp = stp in turing_shift, simp_all add: shift_length)
+ apply(simp add: t_steps_steps_eq)
+ apply(simp add: t_ncorrect.simps shift_length)
+ done
+ thus "\<exists> stp>0. steps (st + length tp1 div 2, l, r) (tp1 @ tshift tp (length tp1 div 2) @ tp2) stp
+ = (st' + length tp1 div 2, l', r')"
+ apply(erule_tac exE)
+ apply(rule_tac x = stp in exI, simp)
+ apply(subgoal_tac "length (tp1 @ abacus.tshift tp (length tp1 div 2) @ tp2) mod 2 = 0")
+ apply(simp only: steps_eq)
+ using h
+ apply(auto simp: t_ncorrect.simps shift_length)
+ apply arith
+ done
+qed
+
+
+lemma t_twice_len_ge: "Suc 0 \<le> length t_twice div 2"
+apply(simp add: t_twice_def tMp.simps shift_length)
+done
+
+lemma [intro]: "rec_calc_rel (recf.id (Suc 0) 0) [rs] rs"
+ apply(rule_tac calc_id, simp_all)
+ done
+
+lemma [intro]: "rec_calc_rel (constn 2) [rs] 2"
+using prime_rel_exec_eq[of "constn 2" "[rs]" 2]
+apply(subgoal_tac "primerec (constn 2) 1", auto)
+done
+
+lemma [intro]: "rec_calc_rel rec_mult [rs, 2] (2 * rs)"
+using prime_rel_exec_eq[of "rec_mult" "[rs, 2]" "2*rs"]
+apply(subgoal_tac "primerec rec_mult (Suc (Suc 0))", auto)
+done
+lemma t_twice_correct: "\<exists>stp ln rn. steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ (tm_of abc_twice @ tMp (Suc 0) (start_of twice_ly (length abc_twice) - Suc 0)) stp =
+ (0, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+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. steps (Suc 0, Bk # Bk # ires, <[rs]> @ Bk\<^bsup>n\<^esup>) (tm_of abc_twice @ tMp (Suc 0)
+ (start_of twice_ly (length abc_twice) - 1)) stp = (0, Bk\<^bsup>m\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2*rs)\<^esup> @ Bk\<^bsup>l\<^esup>)"
+ proof(rule_tac t_compiled_by_rec)
+ show "rec_ci rec_twice = (a, b, c)" by (simp add: h)
+ next
+ show "rec_calc_rel rec_twice [rs] (2 * rs)"
+ apply(simp add: rec_twice_def)
+ apply(rule_tac rs = "[rs, 2]" in calc_cn, simp_all)
+ apply(rule_tac allI, case_tac k, auto)
+ done
+ next
+ show "length [rs] = Suc 0" by simp
+ next
+ show "layout_of (a [+] dummy_abc (Suc 0)) = layout_of (a [+] dummy_abc (Suc 0))"
+ by simp
+ next
+ show "start_of twice_ly (length abc_twice) =
+ start_of (layout_of (a [+] dummy_abc (Suc 0))) (length (a [+] dummy_abc (Suc 0)))"
+ using h
+ apply(simp add: twice_ly_def abc_twice_def)
+ done
+ next
+ show "tm_of abc_twice = tm_of (a [+] dummy_abc (Suc 0))"
+ using h
+ apply(simp add: abc_twice_def)
+ done
+ qed
+ thus "\<exists>stp ln rn. steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ (tm_of abc_twice @ tMp (Suc 0) (start_of twice_ly (length abc_twice) - Suc 0)) stp =
+ (0, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(simp add: tape_of_nl_abv tape_of_nat_list.simps)
+ done
+qed
+
+lemma change_termi_state_fetch: "\<lbrakk>fetch ap a b = (aa, st); st > 0\<rbrakk>
+ \<Longrightarrow> fetch (change_termi_state ap) a b = (aa, st)"
+apply(case_tac b, auto simp: fetch.simps nth_of.simps change_termi_state.simps nth_map
+ split: if_splits block.splits)
+done
+
+lemma change_termi_state_exec_in_range:
+ "\<lbrakk>steps (st, l, r) ap stp = (st', l', r'); st' \<noteq> 0\<rbrakk>
+ \<Longrightarrow> steps (st, l, r) (change_termi_state ap) stp = (st', l', r')"
+proof(induct stp arbitrary: st l r st' l' r', simp add: steps.simps)
+ fix stp st l r st' l' r'
+ assume ind: "\<And>st l r st' l' r'.
+ \<lbrakk>steps (st, l, r) ap stp = (st', l', r'); st' \<noteq> 0\<rbrakk> \<Longrightarrow>
+ steps (st, l, r) (change_termi_state ap) stp = (st', l', r')"
+ and h: "steps (st, l, r) ap (Suc stp) = (st', l', r')" "st' \<noteq> 0"
+ from h show "steps (st, l, r) (change_termi_state ap) (Suc stp) = (st', l', r')"
+ proof(simp add: tstep_red, case_tac "steps (st, l, r) ap stp", simp)
+ fix a b c
+ assume g: "steps (st, l, r) ap stp = (a, b, c)"
+ "tstep (a, b, c) ap = (st', l', r')" "0 < st'"
+ hence "steps (st, l, r) (change_termi_state ap) stp = (a, b, c)"
+ apply(rule_tac ind, simp)
+ apply(case_tac a, simp_all add: tstep_0)
+ done
+ from g and this show "tstep (steps (st, l, r) (change_termi_state ap) stp)
+ (change_termi_state ap) = (st', l', r')"
+ apply(simp add: tstep.simps)
+ apply(case_tac "fetch ap a (case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)", simp)
+ apply(subgoal_tac "fetch (change_termi_state ap) a (case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)
+ = (aa, st')", simp)
+ apply(simp add: change_termi_state_fetch)
+ done
+ qed
+qed
+
+lemma change_termi_state_fetch0:
+ "\<lbrakk>0 < a; a \<le> length ap div 2; t_correct ap; fetch ap a b = (aa, 0)\<rbrakk>
+ \<Longrightarrow> fetch (change_termi_state ap) a b = (aa, Suc (length ap div 2))"
+apply(case_tac b, auto simp: fetch.simps nth_of.simps change_termi_state.simps nth_map
+ split: if_splits block.splits)
+done
+
+lemma turing_change_termi_state:
+ "\<lbrakk>steps (Suc 0, l, r) ap stp = (0, l', r'); t_correct ap\<rbrakk>
+ \<Longrightarrow> \<exists> stp. steps (Suc 0, l, r) (change_termi_state ap) stp =
+ (Suc (length ap div 2), l', r')"
+apply(drule first_halt_point)
+apply(erule_tac exE)
+apply(rule_tac x = "Suc stp" in exI, simp add: tstep_red)
+apply(case_tac "steps (Suc 0, l, r) ap stp")
+apply(simp add: isS0_def change_termi_state_exec_in_range)
+apply(subgoal_tac "steps (Suc 0, l, r) (change_termi_state ap) stp = (a, b, c)", simp)
+apply(simp add: tstep.simps)
+apply(case_tac "fetch ap a (case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)", simp)
+apply(subgoal_tac "fetch (change_termi_state ap) a
+ (case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x) = (aa, Suc (length ap div 2))", simp)
+apply(rule_tac ap = ap in change_termi_state_fetch0, simp_all)
+apply(rule_tac tp = "(l, r)" and l = b and r = c and stp = stp and A = ap in s_keep, simp_all)
+apply(simp add: change_termi_state_exec_in_range)
+done
+
+lemma t_twice_change_term_state:
+ "\<exists> stp ln rn. steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_twice stp
+ = (Suc t_twice_len, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+using t_twice_correct[of ires rs n]
+apply(erule_tac exE)
+apply(erule_tac exE)
+apply(erule_tac exE)
+proof(drule_tac turing_change_termi_state)
+ fix stp ln rn
+ show "t_correct (tm_of abc_twice @ tMp (Suc 0) (start_of twice_ly (length abc_twice) - Suc 0))"
+ apply(rule_tac t_compiled_correct, simp_all)
+ apply(simp add: twice_ly_def)
+ done
+next
+ fix stp ln rn
+ show "\<exists>stp. steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ (change_termi_state (tm_of abc_twice @ tMp (Suc 0)
+ (start_of twice_ly (length abc_twice) - Suc 0))) stp =
+ (Suc (length (tm_of abc_twice @ tMp (Suc 0) (start_of twice_ly (length abc_twice) - Suc 0)) div 2),
+ Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>) \<Longrightarrow>
+ \<exists>stp ln rn. steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_twice stp =
+ (Suc t_twice_len, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(erule_tac exE)
+ apply(simp add: t_twice_len_def t_twice_def)
+ apply(rule_tac x = stp in exI, rule_tac x = ln in exI, rule_tac x = rn in exI, simp)
+ done
+qed
+
+lemma t_twice_append_pre:
+ "steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_twice stp
+ = (Suc t_twice_len, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)
+ \<Longrightarrow> \<exists> stp>0. steps (Suc 0 + length t_wcode_main_first_part div 2, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ (t_wcode_main_first_part @ tshift t_twice (length t_wcode_main_first_part div 2) @
+ ([(L, 1), (L, 1)] @ tshift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)])) stp
+ = (Suc (t_twice_len) + length t_wcode_main_first_part div 2, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+proof(rule_tac t_tshift_lemma, simp_all add: t_twice_len_ge)
+ assume "steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_twice stp =
+ (Suc t_twice_len, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ thus "0 < stp"
+ apply(case_tac stp, simp add: steps.simps t_twice_len_ge t_twice_len_def)
+ using t_twice_len_ge
+ apply(simp, simp)
+ done
+next
+ show "t_ncorrect t_wcode_main_first_part"
+ apply(simp add: t_ncorrect.simps t_wcode_main_first_part_def)
+ done
+next
+ show "t_ncorrect t_twice"
+ using length_tm_even[of abc_twice]
+ apply(auto simp: t_ncorrect.simps t_twice_def)
+ apply(arith)
+ done
+next
+ show "t_ncorrect ((L, Suc 0) # (L, Suc 0) #
+ abacus.tshift t_fourtimes (t_twice_len + 13) @ [(L, Suc 0), (L, Suc 0)])"
+ using length_tm_even[of abc_fourtimes]
+ apply(simp add: t_ncorrect.simps shift_length t_fourtimes_def)
+ apply arith
+ done
+qed
+
+lemma t_twice_append:
+ "\<exists> stp ln rn. steps (Suc 0 + length t_wcode_main_first_part div 2, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ (t_wcode_main_first_part @ tshift t_twice (length t_wcode_main_first_part div 2) @
+ ([(L, 1), (L, 1)] @ tshift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)])) stp
+ = (Suc (t_twice_len) + length t_wcode_main_first_part div 2, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ using t_twice_change_term_state[of ires rs n]
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(drule_tac t_twice_append_pre)
+ apply(erule_tac exE)
+ apply(rule_tac x = stpa in exI, rule_tac x = ln in exI, rule_tac x = rn in exI)
+ apply(simp)
+ done
+
+lemma [simp]: "fetch t_wcode_main (Suc (t_twice_len + length t_wcode_main_first_part div 2)) Oc
+ = (L, Suc 0)"
+apply(subgoal_tac "length (t_twice) mod 2 = 0")
+apply(simp add: t_wcode_main_def nth_append fetch.simps t_wcode_main_first_part_def
+ nth_of.simps shift_length t_twice_len_def, auto)
+apply(simp add: t_twice_def)
+apply(subgoal_tac "length (tm_of abc_twice) mod 2 = 0")
+apply arith
+apply(rule_tac tm_even)
+done
+
+lemma wcode_jump1:
+ "\<exists> stp ln rn. steps (Suc (t_twice_len) + length t_wcode_main_first_part div 2,
+ Bk\<^bsup>m\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>n\<^esup>)
+ t_wcode_main stp
+ = (Suc 0, Bk\<^bsup>ln\<^esup> @ Bk # ires, Bk # Oc\<^bsup>Suc (2 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+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 tstep.simps exp_ind_def new_tape.simps)
+apply(case_tac m, simp, simp add: exp_ind_def)
+apply(simp add: exp_ind_def[THEN sym] exp_ind[THEN sym])
+done
+
+lemma wcode_main_first_part_len:
+ "length t_wcode_main_first_part = 24"
+ apply(simp add: t_wcode_main_first_part_def)
+ done
+
+lemma wcode_double_case:
+ shows "\<exists>stp ln rn. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (Suc 0, Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires, Bk # Oc\<^bsup>Suc (2 * rs + 2)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+proof -
+ have "\<exists>stp ln rn. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (13, Bk # Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires, Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ using wcode_double_case_first_correctness[of ires rs m n]
+ apply(simp)
+ apply(erule_tac exE)
+ apply(case_tac "steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Oc # ires,
+ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main na",
+ auto simp: wcode_double_case_inv.simps
+ wcode_before_double.simps)
+ apply(rule_tac x = na in exI, rule_tac x = ln in exI, rule_tac x = rn in exI)
+ apply(simp)
+ done
+ from this obtain stpa lna rna where stp1:
+ "steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stpa =
+ (13, Bk # Bk # Bk\<^bsup>lna\<^esup> @ Oc # ires, Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rna\<^esup>)" by blast
+ have "\<exists> stp ln rn. steps (13, Bk # Bk # Bk\<^bsup>lna\<^esup> @ Oc # ires, Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rna\<^esup>) t_wcode_main stp =
+ (13 + t_twice_len, Bk # Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires, Oc\<^bsup>Suc (Suc (Suc (2 *rs)))\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ using t_twice_append[of "Bk\<^bsup>lna\<^esup> @ Oc # ires" "Suc rs" rna]
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(simp add: wcode_main_first_part_len)
+ apply(rule_tac x = stp in exI, rule_tac x = "ln + lna" in exI,
+ rule_tac x = rn in exI)
+ apply(simp add: t_wcode_main_def)
+ apply(simp add: exp_ind_def[THEN sym] exp_add[THEN sym])
+ done
+ from this obtain stpb lnb rnb where stp2:
+ "steps (13, Bk # Bk # Bk\<^bsup>lna\<^esup> @ Oc # ires, Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rna\<^esup>) t_wcode_main stpb =
+ (13 + t_twice_len, Bk # Bk # Bk\<^bsup>lnb\<^esup> @ Oc # ires, Oc\<^bsup>Suc (Suc (Suc (2 *rs)))\<^esup> @ Bk\<^bsup>rnb\<^esup>)" by blast
+ have "\<exists>stp ln rn. steps (13 + t_twice_len, Bk # Bk # Bk\<^bsup>lnb\<^esup> @ Oc # ires,
+ Oc\<^bsup>Suc (Suc (Suc (2 *rs)))\<^esup> @ Bk\<^bsup>rnb\<^esup>) t_wcode_main stp =
+ (Suc 0, Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires, Bk # Oc\<^bsup>Suc (Suc (Suc (2 *rs)))\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ using wcode_jump1[of lnb "Oc # ires" "Suc rs" rnb]
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(rule_tac x = stp in exI,
+ rule_tac x = ln in exI,
+ rule_tac x = rn in exI, simp add:wcode_main_first_part_len t_wcode_main_def)
+ apply(subgoal_tac "Bk\<^bsup>lnb\<^esup> @ Bk # Bk # Oc # ires = Bk # Bk # Bk\<^bsup>lnb\<^esup> @ Oc # ires", simp)
+ apply(simp add: exp_ind_def[THEN sym] exp_ind[THEN sym])
+ apply(simp)
+ apply(case_tac lnb, simp, simp add: exp_ind_def[THEN sym] exp_ind)
+ done
+ from this obtain stpc lnc rnc where stp3:
+ "steps (13 + t_twice_len, Bk # Bk # Bk\<^bsup>lnb\<^esup> @ Oc # ires,
+ Oc\<^bsup>Suc (Suc (Suc (2 *rs)))\<^esup> @ Bk\<^bsup>rnb\<^esup>) t_wcode_main stpc =
+ (Suc 0, Bk # Bk\<^bsup>lnc\<^esup> @ Oc # ires, Bk # Oc\<^bsup>Suc (Suc (Suc (2 *rs)))\<^esup> @ Bk\<^bsup>rnc\<^esup>)"
+ 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 add: steps_add)
+ done
+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\<^bsup>ml\<^esup> @ Oc # Bk # Oc # ires \<and>
+ r = Bk\<^bsup>mr\<^esup> @ Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+fun wcode_erase2 :: "bin_inv_t"
+ where
+ "wcode_erase2 ires rs (l, r) =
+ (\<exists> ln rn. l = Bk # Oc # ires \<and>
+ tl r = Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ml\<^esup> @ Oc # ires \<and>
+ r = Bk\<^bsup>mr\<^esup> @ Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ml\<^esup> @ Bk # Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires \<and>
+ r = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ln\<^esup> @ Oc # ires \<and>
+ r = Bk # Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ml \<^esup>@ Bk # Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires \<and>
+ r = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ln\<^esup> @ Oc # ires \<and>
+ r = Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+declare wcode_on_left_moving_2_B.simps[simp del] wcode_on_left_moving_2.simps[simp del]
+ wcode_on_left_moving_2_O.simps[simp del] wcode_on_checking_2.simps[simp del]
+ wcode_goon_checking.simps[simp del] wcode_right_move.simps[simp del]
+ wcode_erase2.simps[simp del]
+ wcode_on_right_moving_2.simps[simp del] wcode_goon_right_moving_2.simps[simp del]
+ wcode_backto_standard_pos_2_B.simps[simp del] wcode_backto_standard_pos_2_O.simps[simp del]
+ wcode_backto_standard_pos_2.simps[simp del]
+
+lemmas wcode_fourtimes_invs =
+ wcode_on_left_moving_2_B.simps wcode_on_left_moving_2.simps
+ wcode_on_left_moving_2_O.simps wcode_on_checking_2.simps
+ wcode_goon_checking.simps wcode_right_move.simps
+ wcode_erase2.simps
+ wcode_on_right_moving_2.simps wcode_goon_right_moving_2.simps
+ wcode_backto_standard_pos_2_B.simps wcode_backto_standard_pos_2_O.simps
+ wcode_backto_standard_pos_2.simps
+
+fun wcode_fourtimes_case_inv :: "nat \<Rightarrow> bin_inv_t"
+ where
+ "wcode_fourtimes_case_inv st ires rs (l, r) =
+ (if st = Suc 0 then wcode_on_left_moving_2 ires rs (l, r)
+ else if st = Suc (Suc 0) then wcode_on_checking_2 ires rs (l, r)
+ else if st = 7 then wcode_goon_checking ires rs (l, r)
+ else if st = 8 then wcode_right_move ires rs (l, r)
+ else if st = 9 then wcode_erase2 ires rs (l, r)
+ else if st = 10 then wcode_on_right_moving_2 ires rs (l, r)
+ else if st = 11 then wcode_goon_right_moving_2 ires rs (l, r)
+ else if st = 12 then wcode_backto_standard_pos_2 ires rs (l, r)
+ else if st = t_twice_len + 14 then wcode_before_fourtimes ires rs (l, r)
+ else False)"
+
+declare wcode_fourtimes_case_inv.simps[simp del]
+
+fun wcode_fourtimes_case_state :: "t_conf \<Rightarrow> nat"
+ where
+ "wcode_fourtimes_case_state (st, l, r) = 13 - st"
+
+fun wcode_fourtimes_case_step :: "t_conf \<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 :: "t_conf \<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 :: "(t_conf \<times> t_conf) 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 intro:wf_inv_image simp: wcode_fourtimes_case_le_def)
+
+lemma [simp]: "fetch t_wcode_main (Suc (Suc 0)) Bk = (L, 7)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 7 Oc = (R, 8)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 8 Bk = (R, 9)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 9 Bk = (R, 10)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 9 Oc = (W0, 9)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 10 Bk = (R, 10)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 10 Oc = (R, 11)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 11 Bk = (W1, 12)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 11 Oc = (R, 11)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 12 Oc = (L, 12)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_main 12 Bk = (R, t_twice_len + 14)"
+apply(simp add: t_wcode_main_def fetch.simps
+ t_wcode_main_first_part_def nth_of.simps)
+done
+
+
+lemma [simp]: "wcode_on_left_moving_2 ires rs (b, []) = False"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [simp]: "wcode_on_checking_2 ires rs (b, []) = False"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [simp]: "wcode_goon_checking ires rs (b, []) = False"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [simp]: "wcode_right_move ires rs (b, []) = False"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [simp]: "wcode_erase2 ires rs (b, []) = False"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [simp]: "wcode_on_right_moving_2 ires rs (b, []) = False"
+apply(auto simp: wcode_fourtimes_invs exponent_def)
+done
+
+lemma [simp]: "wcode_backto_standard_pos_2 ires rs (b, []) = False"
+apply(auto simp: wcode_fourtimes_invs exponent_def)
+done
+
+lemma [simp]: "wcode_on_left_moving_2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(simp add: wcode_fourtimes_invs, auto)
+done
+
+lemma [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(case_tac ml, simp)
+apply(rule_tac x = "mr - (Suc (Suc 0))" in exI, rule_tac x = rn in exI, simp)
+apply(case_tac mr, simp, case_tac nat, simp, simp add: exp_ind)
+apply(rule_tac disjI1)
+apply(rule_tac x = nat in exI, rule_tac x = "Suc mr" in exI, rule_tac x = rn in exI,
+ simp add: exp_ind_def)
+apply(simp)
+done
+
+lemma [simp]: "wcode_on_checking_2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [simp]: "wcode_on_checking_2 ires rs (b, Bk # list)
+ \<Longrightarrow> wcode_goon_checking ires rs (tl b, hd b # Bk # list)"
+apply(simp only: wcode_fourtimes_invs)
+apply(auto)
+done
+
+lemma [simp]: "wcode_goon_checking ires rs (b, Bk # list) = False"
+apply(simp add: wcode_fourtimes_invs)
+done
+
+lemma [simp]: " wcode_right_move ires rs (b, Bk # list) \<Longrightarrow> b\<noteq> []"
+apply(simp add: wcode_fourtimes_invs)
+done
+
+lemma [simp]: "wcode_right_move ires rs (b, Bk # list) \<Longrightarrow> wcode_erase2 ires rs (Bk # b, list)"
+apply(auto simp:wcode_fourtimes_invs )
+apply(rule_tac x = ln in exI, rule_tac x = rn in exI, simp)
+done
+
+lemma [simp]: "wcode_erase2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [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)
+apply(rule_tac x = "Suc (Suc ln)" in exI, simp add: exp_ind, auto)
+done
+
+lemma [simp]: "wcode_on_right_moving_2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(auto simp:wcode_fourtimes_invs )
+done
+
+lemma [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(rule_tac x = "Suc ml" in exI, simp add: exp_ind_def)
+apply(rule_tac x = "mr - 1" in exI, case_tac mr, auto simp: exp_ind_def)
+done
+
+lemma [simp]: "wcode_goon_right_moving_2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [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)
+apply(rule_tac x = ml in exI, auto)
+apply(rule_tac x = "Suc 0" in exI, simp)
+apply(case_tac mr, simp_all add: exp_ind_def)
+apply(rule_tac x = "rn - 1" in exI, simp)
+apply(case_tac rn, simp, simp add: exp_ind_def)
+done
+
+lemma [simp]: "wcode_backto_standard_pos_2 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(simp add: wcode_fourtimes_invs, auto)
+done
+
+lemma [simp]: "wcode_on_left_moving_2 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
+apply(simp add: wcode_fourtimes_invs, auto)
+done
+
+lemma [simp]: "wcode_on_left_moving_2 ires rs (b, Oc # list) \<Longrightarrow>
+ wcode_on_checking_2 ires rs (tl b, hd b # Oc # list)"
+apply(auto simp: wcode_fourtimes_invs)
+apply(case_tac [!] mr, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wcode_goon_right_moving_2 ires rs (b, []) \<Longrightarrow> b \<noteq> []"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [simp]: "wcode_goon_right_moving_2 ires rs (b, []) \<Longrightarrow>
+ wcode_backto_standard_pos_2 ires rs (b, [Oc])"
+apply(simp only: wcode_fourtimes_invs)
+apply(erule_tac exE)+
+apply(rule_tac disjI1)
+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)
+apply(case_tac mr, simp, simp add: exp_ind_def)
+done
+
+lemma "wcode_backto_standard_pos_2 ires rs (b, Bk # list)
+ \<Longrightarrow> (\<exists>ln. b = Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires) \<and> (\<exists>rn. list = Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+apply(auto simp: wcode_fourtimes_invs)
+apply(case_tac [!] mr, auto simp: exp_ind_def)
+done
+
+
+lemma [simp]: "wcode_on_checking_2 ires rs (b, Oc # list) \<Longrightarrow> False"
+apply(simp add: wcode_fourtimes_invs)
+done
+
+lemma [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 [simp]: "wcode_right_move ires rs (b, Oc # list) = False"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [simp]: " wcode_erase2 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
+apply(simp add: wcode_fourtimes_invs)
+done
+
+lemma [simp]: "wcode_erase2 ires rs (b, Oc # list)
+ \<Longrightarrow> wcode_erase2 ires rs (b, Bk # list)"
+apply(auto simp: wcode_fourtimes_invs)
+done
+
+lemma [simp]: "wcode_on_right_moving_2 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
+apply(simp only: wcode_fourtimes_invs)
+apply(auto)
+done
+
+lemma [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(case_tac mr, simp_all add: exp_ind_def)
+apply(rule_tac x = "Suc 0" in exI, auto)
+apply(rule_tac x = "ml - 2" in exI)
+apply(case_tac ml, simp, case_tac nat, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wcode_goon_right_moving_2 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
+apply(simp only:wcode_fourtimes_invs, auto)
+done
+
+lemma [simp]: "wcode_backto_standard_pos_2 ires rs (b, Bk # list)
+ \<Longrightarrow> (\<exists>ln. b = Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires) \<and> (\<exists>rn. list = Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+apply(simp add: wcode_fourtimes_invs, auto)
+apply(case_tac [!] mr, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wcode_on_checking_2 ires rs (b, Oc # list) = False"
+apply(simp add: wcode_fourtimes_invs)
+done
+
+lemma [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(rule_tac x = "Suc ml" in exI, auto simp: exp_ind_def)
+apply(rule_tac x = "mr - 1" in exI)
+apply(case_tac mr, case_tac rn, auto simp: exp_ind_def)
+done
+
+lemma [simp]: "wcode_backto_standard_pos_2 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
+apply(simp only: wcode_fourtimes_invs, auto)
+done
+
+lemma [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(case_tac ml, simp)
+apply(rule_tac disjI2)
+apply(rule_tac conjI, rule_tac x = ln in exI, simp)
+apply(rule_tac x = rn in exI, simp)
+apply(rule_tac disjI1)
+apply(rule_tac x = nat in exI, rule_tac x = "Suc mr" in exI,
+ rule_tac x = ln in exI, rule_tac x = rn in exI, simp add: exp_ind_def)
+apply(simp)
+done
+
+lemma wcode_fourtimes_case_first_correctness:
+ shows "let P = (\<lambda> (st, l, r). st = t_twice_len + 14) in
+ let Q = (\<lambda> (st, l, r). wcode_fourtimes_case_inv st ires rs (l, r)) in
+ let f = (\<lambda> stp. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp) in
+ \<exists> n .P (f n) \<and> Q (f (n::nat))"
+proof -
+ let ?P = "(\<lambda> (st, l, r). st = t_twice_len + 14)"
+ let ?Q = "(\<lambda> (st, l, r). wcode_fourtimes_case_inv st ires rs (l, r))"
+ let ?f = "(\<lambda> stp. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main 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
+ show "\<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"
+ apply(rule_tac allI,
+ case_tac "steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main na", simp,
+ rule_tac impI)
+ apply(simp add: tstep_red tstep.simps, case_tac c, simp, case_tac [2] aa, simp_all)
+
+ apply(simp_all add: wcode_fourtimes_case_inv.simps new_tape.simps
+ wcode_fourtimes_case_le_def lex_pair_def split: if_splits)
+ done
+ 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 add: exp_ind_def)
+ apply(rule_tac x ="Suc 0" in exI, auto)
+ done
+ next
+ show "\<not> ?P (?f 0)"
+ apply(simp add: steps.simps)
+ done
+ qed
+ thus "?thesis"
+ apply(erule_tac exE, simp)
+ done
+qed
+
+definition t_fourtimes_len :: "nat"
+ where
+ "t_fourtimes_len = (length t_fourtimes div 2)"
+
+lemma t_fourtimes_len_gr: "t_fourtimes_len > 0"
+apply(simp add: t_fourtimes_len_def t_fourtimes_def)
+done
+
+lemma t_fourtimes_correct:
+ "\<exists>stp ln rn. steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ (tm_of abc_fourtimes @ tMp (Suc 0) (start_of fourtimes_ly (length abc_fourtimes) - Suc 0)) stp =
+ (0, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (4 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+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. steps (Suc 0, Bk # Bk # ires, <[rs]> @ Bk\<^bsup>n\<^esup>) (tm_of abc_fourtimes @ tMp (Suc 0)
+ (start_of fourtimes_ly (length abc_fourtimes) - 1)) stp = (0, Bk\<^bsup>m\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (4*rs)\<^esup> @ Bk\<^bsup>l\<^esup>)"
+ proof(rule_tac t_compiled_by_rec)
+ show "rec_ci rec_fourtimes = (a, b, c)" by (simp add: h)
+ next
+ show "rec_calc_rel rec_fourtimes [rs] (4 * rs)"
+ using prime_rel_exec_eq [of rec_fourtimes "[rs]" "4 * rs"]
+ apply(subgoal_tac "primerec rec_fourtimes (length [rs])")
+ apply(simp_all add: rec_fourtimes_def rec_exec.simps)
+ apply(auto)
+ apply(simp only: Nat.One_nat_def[THEN sym], auto)
+ done
+ next
+ show "length [rs] = Suc 0" by simp
+ next
+ show "layout_of (a [+] dummy_abc (Suc 0)) = layout_of (a [+] dummy_abc (Suc 0))"
+ by simp
+ next
+ show "start_of fourtimes_ly (length abc_fourtimes) =
+ start_of (layout_of (a [+] dummy_abc (Suc 0))) (length (a [+] dummy_abc (Suc 0)))"
+ using h
+ apply(simp add: fourtimes_ly_def abc_fourtimes_def)
+ done
+ next
+ show "tm_of abc_fourtimes = tm_of (a [+] dummy_abc (Suc 0))"
+ using h
+ apply(simp add: abc_fourtimes_def)
+ done
+ qed
+ thus "\<exists>stp ln rn. steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ (tm_of abc_fourtimes @ tMp (Suc 0) (start_of fourtimes_ly (length abc_fourtimes) - Suc 0)) stp =
+ (0, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (4 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(simp add: tape_of_nl_abv tape_of_nat_list.simps)
+ done
+qed
+
+lemma t_fourtimes_change_term_state:
+ "\<exists> stp ln rn. steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_fourtimes stp
+ = (Suc t_fourtimes_len, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (4 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+using t_fourtimes_correct[of ires rs n]
+apply(erule_tac exE)
+apply(erule_tac exE)
+apply(erule_tac exE)
+proof(drule_tac turing_change_termi_state)
+ fix stp ln rn
+ show "t_correct (tm_of abc_fourtimes @ tMp (Suc 0)
+ (start_of fourtimes_ly (length abc_fourtimes) - Suc 0))"
+ apply(rule_tac t_compiled_correct, auto simp: fourtimes_ly_def)
+ done
+next
+ fix stp ln rn
+ show "\<exists>stp. steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ (change_termi_state (tm_of abc_fourtimes @ tMp (Suc 0)
+ (start_of fourtimes_ly (length abc_fourtimes) - Suc 0))) stp =
+ (Suc (length (tm_of abc_fourtimes @ tMp (Suc 0) (start_of fourtimes_ly
+ (length abc_fourtimes) - Suc 0)) div 2), Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (4 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>) \<Longrightarrow>
+ \<exists>stp ln rn. steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_fourtimes stp =
+ (Suc t_fourtimes_len, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (4 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(erule_tac exE)
+ apply(simp add: t_fourtimes_len_def t_fourtimes_def)
+ apply(rule_tac x = stp in exI, rule_tac x = ln in exI, rule_tac x = rn in exI, simp)
+ done
+qed
+
+lemma t_fourtimes_append_pre:
+ "steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_fourtimes stp
+ = (Suc t_fourtimes_len, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (4 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)
+ \<Longrightarrow> \<exists> stp>0. steps (Suc 0 + length (t_wcode_main_first_part @
+ tshift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2,
+ Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ ((t_wcode_main_first_part @
+ tshift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) @
+ tshift t_fourtimes (length (t_wcode_main_first_part @
+ tshift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2) @ ([(L, 1), (L, 1)])) stp
+ = (Suc t_fourtimes_len + length (t_wcode_main_first_part @
+ tshift t_twice (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2,
+ Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (4 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+proof(rule_tac t_tshift_lemma, auto)
+ assume "steps (Suc 0, Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_fourtimes stp =
+ (Suc t_fourtimes_len, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (4 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ thus "0 < stp"
+ using t_fourtimes_len_gr
+ apply(case_tac stp, simp_all add: steps.simps)
+ done
+next
+ show "Suc 0 \<le> length t_fourtimes div 2"
+ apply(simp add: t_fourtimes_def shift_length tMp.simps)
+ done
+next
+ show "t_ncorrect (t_wcode_main_first_part @
+ abacus.tshift t_twice (length t_wcode_main_first_part div 2) @
+ [(L, Suc 0), (L, Suc 0)])"
+ apply(simp add: t_ncorrect.simps t_wcode_main_first_part_def shift_length
+ t_twice_def)
+ using tm_even[of abc_twice]
+ by arith
+next
+ show "t_ncorrect t_fourtimes"
+ apply(simp add: t_fourtimes_def steps.simps t_ncorrect.simps)
+ using tm_even[of abc_fourtimes]
+ by arith
+next
+ show "t_ncorrect [(L, Suc 0), (L, Suc 0)]"
+ apply(simp add: t_ncorrect.simps)
+ done
+qed
+
+lemma [simp]: "length t_wcode_main_first_part = 24"
+apply(simp add: t_wcode_main_first_part_def)
+done
+
+lemma [simp]: "(26 + length t_twice) div 2 = (length t_twice) div 2 + 13"
+using tm_even[of abc_twice]
+apply(simp add: t_twice_def)
+done
+
+lemma [simp]: "((26 + length (abacus.tshift t_twice 12)) div 2)
+ = (length (abacus.tshift t_twice 12) div 2 + 13)"
+using tm_even[of abc_twice]
+apply(simp add: t_twice_def)
+done
+
+lemma [simp]: "t_twice_len + 14 = 14 + length (abacus.tshift t_twice 12) div 2"
+using tm_even[of abc_twice]
+apply(simp add: t_twice_def t_twice_len_def shift_length)
+done
+
+lemma t_fourtimes_append:
+ "\<exists> stp ln rn.
+ steps (Suc 0 + length (t_wcode_main_first_part @ tshift t_twice
+ (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2,
+ Bk # Bk # ires, Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ ((t_wcode_main_first_part @ tshift t_twice (length t_wcode_main_first_part div 2) @
+ [(L, 1), (L, 1)]) @ tshift t_fourtimes (t_twice_len + 13) @ [(L, 1), (L, 1)]) stp
+ = (Suc t_fourtimes_len + length (t_wcode_main_first_part @ tshift t_twice
+ (length t_wcode_main_first_part div 2) @ [(L, 1), (L, 1)]) div 2, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires,
+ Oc\<^bsup>Suc (4 * rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ using t_fourtimes_change_term_state[of ires rs n]
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(drule_tac t_fourtimes_append_pre)
+ apply(erule_tac exE)
+ apply(rule_tac x = stpa in exI, rule_tac x = ln in exI, rule_tac x = rn in exI)
+ apply(simp add: t_twice_len_def shift_length)
+ done
+
+lemma t_wcode_main_len: "length t_wcode_main = length t_twice + length t_fourtimes + 28"
+apply(simp add: t_wcode_main_def shift_length)
+done
+
+lemma [simp]: "fetch t_wcode_main (14 + length t_twice div 2 + t_fourtimes_len) b
+ = (L, Suc 0)"
+using tm_even[of "abc_twice"] tm_even[of "abc_fourtimes"]
+apply(case_tac b)
+apply(simp_all only: fetch.simps)
+apply(auto simp: nth_of.simps t_wcode_main_len t_twice_len_def
+ t_fourtimes_def t_twice_def t_fourtimes_def t_fourtimes_len_def)
+apply(auto simp: t_wcode_main_def t_wcode_main_first_part_def shift_length t_twice_def nth_append
+ t_fourtimes_def)
+done
+
+lemma wcode_jump2:
+ "\<exists> stp ln rn. steps (t_twice_len + 14 + t_fourtimes_len
+ , Bk # Bk # Bk\<^bsup>lnb\<^esup> @ Oc # ires, Oc\<^bsup>Suc (4 * rs + 4)\<^esup> @ Bk\<^bsup>rnb\<^esup>) t_wcode_main stp =
+ (Suc 0, Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires, Bk # Oc\<^bsup>Suc (4 * rs + 4)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+apply(rule_tac x = "Suc 0" in exI)
+apply(simp add: steps.simps shift_length)
+apply(rule_tac x = lnb in exI, rule_tac x = rnb in exI)
+apply(simp add: tstep.simps new_tape.simps)
+done
+
+lemma wcode_fourtimes_case:
+ shows "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (Suc 0, Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires, Bk # Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+proof -
+ have "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (t_twice_len + 14, Bk # Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires, Oc\<^bsup>Suc (rs + 1)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ using wcode_fourtimes_case_first_correctness[of ires rs m n]
+ apply(simp add: wcode_fourtimes_case_inv.simps, auto)
+ apply(rule_tac x = na in exI, rule_tac x = ln in exI,
+ rule_tac x = rn in exI)
+ apply(simp)
+ done
+ from this obtain stpa lna rna where stp1:
+ "steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Oc # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stpa =
+ (t_twice_len + 14, Bk # Bk # Bk\<^bsup>lna\<^esup> @ Oc # ires, Oc\<^bsup>Suc (rs + 1)\<^esup> @ Bk\<^bsup>rna\<^esup>)" by blast
+ have "\<exists>stp ln rn. steps (t_twice_len + 14, Bk # Bk # Bk\<^bsup>lna\<^esup> @ Oc # ires, Oc\<^bsup>Suc (rs + 1)\<^esup> @ Bk\<^bsup>rna\<^esup>)
+ t_wcode_main stp =
+ (t_twice_len + 14 + t_fourtimes_len, Bk # Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires, Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ using t_fourtimes_append[of " Bk\<^bsup>lna\<^esup> @ Oc # ires" "rs + 1" rna]
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(simp add: t_wcode_main_def)
+ apply(rule_tac x = stp in exI,
+ rule_tac x = "ln + lna" in exI,
+ rule_tac x = rn in exI, simp)
+ apply(simp add: exp_ind_def[THEN sym] exp_add[THEN sym])
+ done
+ from this obtain stpb lnb rnb where stp2:
+ "steps (t_twice_len + 14, Bk # Bk # Bk\<^bsup>lna\<^esup> @ Oc # ires, Oc\<^bsup>Suc (rs + 1)\<^esup> @ Bk\<^bsup>rna\<^esup>)
+ t_wcode_main stpb =
+ (t_twice_len + 14 + t_fourtimes_len, Bk # Bk # Bk\<^bsup>lnb\<^esup> @ Oc # ires, Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rnb\<^esup>)"
+ by blast
+ have "\<exists>stp ln rn. steps (t_twice_len + 14 + t_fourtimes_len,
+ Bk # Bk # Bk\<^bsup>lnb\<^esup> @ Oc # ires, Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rnb\<^esup>)
+ t_wcode_main stp =
+ (Suc 0, Bk # Bk\<^bsup>ln\<^esup> @ Oc # ires, Bk # Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(rule wcode_jump2)
+ done
+ from this obtain stpc lnc rnc where stp3:
+ "steps (t_twice_len + 14 + t_fourtimes_len,
+ Bk # Bk # Bk\<^bsup>lnb\<^esup> @ Oc # ires, Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rnb\<^esup>)
+ t_wcode_main stpc =
+ (Suc 0, Bk # Bk\<^bsup>lnc\<^esup> @ Oc # ires, Bk # Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rnc\<^esup>)"
+ 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 add: steps_add)
+ 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\<^bsup>ml\<^esup> @ Oc # Bk # Bk # ires \<and>
+ r = Bk\<^bsup>mr\<^esup> @ Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+fun wcode_stop :: "bin_inv_t"
+ where
+ "wcode_stop ires rs (l, r) =
+ (\<exists> ln rn. l = Bk # ires \<and>
+ r = Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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 :: "t_conf \<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 :: "t_conf \<Rightarrow> nat"
+ where
+ "wcode_halt_case_step (st, l, r) =
+ (if st = 1 then length l
+ else 0)"
+
+fun wcode_halt_case_measure :: "t_conf \<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 :: "(t_conf \<times> t_conf) 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 intro:wf_inv_image 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 [simp]: "fetch t_wcode_main 7 Bk = (R, 0)"
+apply(simp add: fetch.simps t_wcode_main_def nth_append nth_of.simps
+ t_wcode_main_first_part_def)
+done
+
+lemma [simp]: "wcode_on_left_moving_3 ires rs (b, []) = False"
+apply(simp only: wcode_halt_invs)
+apply(simp add: exp_ind_def)
+done
+
+lemma [simp]: "wcode_on_checking_3 ires rs (b, []) = False"
+apply(simp add: wcode_halt_invs)
+done
+
+lemma [simp]: "wcode_goon_checking_3 ires rs (b, []) = False"
+apply(simp add: wcode_halt_invs)
+done
+
+lemma [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(case_tac ml, simp)
+apply(rule_tac x = "mr - 2" in exI, rule_tac x = rn in exI)
+apply(case_tac mr, simp, simp add: exp_ind, simp add: exp_ind[THEN sym])
+apply(rule_tac disjI1)
+apply(rule_tac x = nat in exI, rule_tac x = "Suc mr" in exI,
+ rule_tac x = rn in exI, simp add: exp_ind_def)
+apply(simp)
+done
+
+lemma [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 [simp]: "wcode_on_left_moving_3 ires rs (b, Oc # list) \<Longrightarrow> b \<noteq> []"
+apply(auto simp: wcode_halt_invs)
+done
+
+lemma [simp]: "wcode_on_left_moving_3 ires rs (b, Oc # list) \<Longrightarrow>
+ wcode_on_checking_3 ires rs (tl b, hd b # Oc # list)"
+apply(simp add:wcode_halt_invs, auto)
+apply(case_tac [!] mr, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wcode_on_checking_3 ires rs (b, Oc # list) = False"
+apply(auto simp: wcode_halt_invs)
+done
+
+lemma [simp]: "wcode_on_left_moving_3 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(simp add: wcode_halt_invs, auto)
+done
+
+
+lemma [simp]: "wcode_on_checking_3 ires rs (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(auto simp: wcode_halt_invs)
+done
+
+lemma [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 [simp]: "wcode_goon_checking_3 ires rs (b, Oc # list) = False"
+apply(simp add: wcode_goon_checking_3.simps)
+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. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main 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. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main 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
+ show "\<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"
+ apply(rule_tac allI, rule_tac impI, case_tac "?f na")
+ apply(simp add: tstep_red tstep.simps)
+ apply(case_tac c, simp, case_tac [2] aa)
+ apply(simp_all split: if_splits add: new_tape.simps wcode_halt_case_le_def lex_pair_def)
+ done
+ next
+ show "?Q (?f 0)"
+ apply(simp add: steps.simps wcode_halt_invs)
+ apply(rule_tac x = "Suc m" in exI, simp add: exp_ind_def)
+ 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 [intro]: "\<exists> xs. (<rev list @ [aa::nat]> :: block list) = Oc # xs"
+apply(case_tac "rev list", simp)
+apply(simp add: tape_of_nat_abv tape_of_nat_list.simps exp_ind_def)
+apply(case_tac list, simp, simp)
+done
+
+lemma wcode_halt_case:
+ "\<exists>stp ln rn. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ t_wcode_main stp = (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ using t_halt_case_correctness[of ires rs m n]
+apply(simp)
+apply(erule_tac exE)
+apply(case_tac "steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main na")
+apply(auto simp: wcode_halt_case_inv.simps wcode_stop.simps)
+apply(rule_tac x = na in exI, rule_tac x = ln in exI,
+ rule_tac x = rn in exI, simp)
+done
+
+lemma bl_bin_one: "bl_bin [Oc] = Suc 0"
+apply(simp add: bl_bin.simps)
+done
+
+lemma t_wcode_main_lemma_pre:
+ "\<lbrakk>args \<noteq> []; lm = <args::nat list>\<rbrakk> \<Longrightarrow>
+ \<exists> stp ln rn. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ rev lm @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main
+ stp
+ = (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin lm + rs * 2^(length lm - 1) \<^esup> @ Bk\<^bsup>rn\<^esup>)"
+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.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ rev lm @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin lm + rs * 2 ^ (length lm - 1)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+ 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.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ rev lm @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin lm + rs * 2 ^ (length lm - 1)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ proof(case_tac "xs::nat list", simp)
+ show "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ rev (<a>) @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<a>) + rs * 2 ^ a\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ proof(induct "a" arbitrary: m n rs ires, simp)
+ fix m n rs ires
+ show "\<exists>stp ln rn. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>)
+ t_wcode_main stp = (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin [Oc] + rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(simp add: bl_bin_one)
+ 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.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ rev (<a>) @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<a>) + rs * 2 ^ a\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ show "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ rev (<Suc a>) @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<Suc a>) + rs * 2 ^ Suc a\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ proof -
+ have "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ rev (<Suc a>) @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (Suc 0, Bk # Bk\<^bsup>ln\<^esup> @ rev (<a>) @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc (2 * rs + 2)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(simp add: tape_of_nat)
+ using wcode_double_case[of m "Oc\<^bsup>a\<^esup> @ Bk # Bk # ires" rs n]
+ apply(simp add: exp_ind_def)
+ done
+ from this obtain stpa lna rna where stp1:
+ "steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ rev (<Suc a>) @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stpa =
+ (Suc 0, Bk # Bk\<^bsup>lna\<^esup> @ rev (<a>) @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc (2 * rs + 2)\<^esup> @ Bk\<^bsup>rna\<^esup>)" by blast
+ moreover have
+ "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>lna\<^esup> @ rev (<a>) @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc (2 * rs + 2)\<^esup> @ Bk\<^bsup>rna\<^esup>) t_wcode_main stp =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<a>) + (2*rs + 2) * 2 ^ a\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ using ind2[of lna ires "2*rs + 2" rna] by simp
+ from this obtain stpb lnb rnb where stp2:
+ "steps (Suc 0, Bk # Bk\<^bsup>lna\<^esup> @ rev (<a>) @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc (2 * rs + 2)\<^esup> @ Bk\<^bsup>rna\<^esup>) t_wcode_main stpb =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>lnb\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<a>) + (2*rs + 2) * 2 ^ a\<^esup> @ Bk\<^bsup>rnb\<^esup>)"
+ 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)
+ apply(simp add: steps_add bl_bin_nat_Suc exponent_def)
+ 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. steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ rev lm @ Bk # Bk # ires, Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin lm + rs * 2 ^ (length lm - 1)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ proof(induct a arbitrary: m n rs args lm, simp_all add: tape_of_nl_rev,
+ simp only: tape_of_nl_cons_app1, simp)
+ fix m n rs args lm
+ have "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # rev (<(aa::nat) # list>) @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (Suc 0, Bk # Bk\<^bsup>ln\<^esup> @ rev (<aa # list>) @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ 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.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # <rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (Suc 0, Bk # Bk\<^bsup>ln\<^esup> @ <rev list @ [aa]> @ Bk # Bk # ires, Bk # Oc\<^bsup>5 + 4 * rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ 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:
+ "steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # rev (<aa # list>) @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stpa =
+ (Suc 0, Bk # Bk\<^bsup>lna\<^esup> @ rev (<aa # list>) @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rna\<^esup>)" by blast
+ from g have
+ "\<exists> stp ln rn. steps (Suc 0, Bk # Bk\<^bsup>lna\<^esup> @ rev (<(aa::nat) # list>) @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rna\<^esup>) t_wcode_main stp = (0, Bk # ires,
+ Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<aa#list>)+ (4*rs + 4) * 2^(length (<aa#list>) - 1) \<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(rule_tac args = "(aa::nat)#list" in ind, simp_all)
+ done
+ from this obtain stpb lnb rnb where stp2:
+ "steps (Suc 0, Bk # Bk\<^bsup>lna\<^esup> @ rev (<(aa::nat) # list>) @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc (4*rs + 4)\<^esup> @ Bk\<^bsup>rna\<^esup>) t_wcode_main stpb = (0, Bk # ires,
+ Bk # Oc # Bk\<^bsup>lnb\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<aa#list>)+ (4*rs + 4) * 2^(length (<aa#list>) - 1) \<^esup> @ Bk\<^bsup>rnb\<^esup>)"
+ by blast
+ from stp1 and stp2 and h
+ show "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc # Bk # <rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk #
+ Bk # Oc\<^bsup>bl_bin (Oc\<^bsup>Suc aa\<^esup> @ Bk # <list @ [0]>) + rs * (2 * 2 ^ (aa + length (<list @ [0]>)))\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(rule_tac x = "stpa + stpb" in exI, rule_tac x = lnb in exI,
+ rule_tac x = rnb in exI, simp add: steps_add tape_of_nl_rev)
+ 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.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ <ab # rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk #
+ Bk # Oc\<^bsup>bl_bin (<aa # list @ [ab]>) + rs * 2 ^ (length (<aa # list @ [ab]>) - Suc 0)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ and k: "args = aa # list @ [Suc ab]" "lm = <aa # list @ [Suc ab]>"
+ show "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ <Suc ab # rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (0, Bk # ires,Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk #
+ Bk # Oc\<^bsup>bl_bin (<aa # list @ [Suc ab]>) + rs * 2 ^ (length (<aa # list @ [Suc ab]>) - Suc 0)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ proof(simp add: tape_of_nl_cons_app1)
+ have "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc\<^bsup>Suc (Suc ab)\<^esup> @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc # Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp
+ = (Suc 0, Bk # Bk\<^bsup>ln\<^esup> @ Oc\<^bsup>Suc ab\<^esup> @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc (2*rs + 2)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ using wcode_double_case[of m "Oc\<^bsup>ab\<^esup> @ Bk # <rev list @ [aa]> @ Bk # Bk # ires"
+ rs n]
+ apply(simp add: exp_ind_def)
+ done
+ from this obtain stpa lna rna where stp1:
+ "steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc\<^bsup>Suc (Suc ab)\<^esup> @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc # Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stpa
+ = (Suc 0, Bk # Bk\<^bsup>lna\<^esup> @ Oc\<^bsup>Suc ab\<^esup> @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc (2*rs + 2)\<^esup> @ Bk\<^bsup>rna\<^esup>)" by blast
+ from k have
+ "\<exists> stp ln rn. steps (Suc 0, Bk # Bk\<^bsup>lna\<^esup> @ <ab # rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc (2*rs + 2)\<^esup> @ Bk\<^bsup>rna\<^esup>) t_wcode_main stp
+ = (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk #
+ Bk # Oc\<^bsup>bl_bin (<aa # list @ [ab]> ) + (2*rs + 2)* 2^(length (<aa # list @ [ab]>) - Suc 0)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(rule_tac ind2, simp_all)
+ done
+ from this obtain stpb lnb rnb where stp2:
+ "steps (Suc 0, Bk # Bk\<^bsup>lna\<^esup> @ <ab # rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc (2*rs + 2)\<^esup> @ Bk\<^bsup>rna\<^esup>) t_wcode_main stpb
+ = (0, Bk # ires, Bk # Oc # Bk\<^bsup>lnb\<^esup> @ Bk #
+ Bk # Oc\<^bsup>bl_bin (<aa # list @ [ab]> ) + (2*rs + 2)* 2^(length (<aa # list @ [ab]>) - Suc 0)\<^esup> @ Bk\<^bsup>rnb\<^esup>)"
+ by blast
+ from stp1 and stp2 show
+ "\<exists>stp ln rn.
+ steps (Suc 0, Bk # Bk\<^bsup>m\<^esup> @ Oc\<^bsup>Suc (Suc ab)\<^esup> @ Bk # <rev list @ [aa]> @ Bk # Bk # ires,
+ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>) t_wcode_main stp =
+ (0, Bk # ires, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk #
+ Oc\<^bsup>bl_bin (Oc\<^bsup>Suc aa\<^esup> @ Bk # <list @ [Suc ab]>) + rs * (2 * 2 ^ (aa + length (<list @ [Suc ab]>)))\<^esup>
+ @ Bk\<^bsup>rn\<^esup>)"
+ apply(rule_tac x = "stpa + stpb" in exI, rule_tac x = lnb in exI,
+ rule_tac x = rnb in exI, simp add: steps_add tape_of_nl_cons_app1 exp_ind_def)
+ done
+ qed
+ qed
+ qed
+ qed
+
+
+
+(* turing_shift can be used*)
+term t_wcode_main
+definition t_wcode_prepare :: "tprog"
+ where
+ "t_wcode_prepare \<equiv>
+ [(W1, 2), (L, 1), (L, 3), (R, 2), (R, 4), (W0, 3),
+ (R, 4), (R, 5), (R, 6), (R, 5), (R, 7), (R, 5),
+ (W1, 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\<^bsup>rn\<^esup> \<or>
+ r = Bk # <m # lm> @ Bk\<^bsup>rn\<^esup>))"
+
+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\<^bsup>ml\<^esup> \<and>
+ r = Oc\<^bsup>mr\<^esup> @ Bk # <lm> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>Suc m\<^esup> \<and>
+ tl r = Bk # <lm> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>Suc m\<^esup> \<and>
+ r = Bk # <lm> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>Suc m\<^esup> \<and>
+ r = <lm> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>Suc m\<^esup> @ Bk # Bk # <lm> @ Bk\<^bsup>rn\<^esup> \<and> l \<noteq> [] \<and>
+ r = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>Suc m\<^esup> @ Bk # Bk # <lm> @ Bk\<^bsup>rn\<^esup> \<and> l \<noteq> [] \<and>
+ r = Oc\<^bsup>mr\<^esup> @ Bk # <lm1> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>Suc m\<^esup> \<and>
+ r = Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>Suc m\<^esup> @ Bk # Bk # <lm> @ Bk\<^bsup>rn\<^esup> \<and> l \<noteq> [] \<and>
+ (if lm1 = [] then r = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup>
+ else r = Oc\<^bsup>mr\<^esup> @ Bk # <lm1> @ Bk\<^bsup>rn\<^esup>) \<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\<^bsup>Suc m\<^esup> \<and>
+ (r = [] \<or> tl r = Bk\<^bsup>rn\<^esup>))"
+
+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\<^bsup>Suc m\<^esup> \<and>
+ r = Bk # Oc # Bk\<^bsup>rn\<^esup>)"
+
+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 :: "t_conf \<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 :: "t_conf \<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 :: "t_conf \<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 :: "t_conf \<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 :: "(t_conf \<times> t_conf) set"
+ where "wcode_prepare_le \<equiv> (inv_image lex_triple wcode_prepare_measure)"
+
+lemma [intro]: "wf lex_pair"
+by(auto intro:wf_lex_prod simp:lex_pair_def)
+
+lemma wf_wcode_prepare_le[intro]: "wf wcode_prepare_le"
+by(auto intro:wf_inv_image simp: wcode_prepare_le_def
+ recursive.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 [simp]: "fetch t_wcode_prepare (Suc 0) Bk = (W1, 2)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare (Suc 0) Oc = (L, 1)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare (Suc (Suc 0)) Bk = (L, 3)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare (Suc (Suc 0)) Oc = (R, 2)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare (Suc (Suc (Suc 0))) Bk = (R, 4)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare (Suc (Suc (Suc 0))) Oc = (W0, 3)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare 4 Bk = (R, 4)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare 4 Oc = (R, 5)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare 5 Oc = (R, 5)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare 5 Bk = (R, 6)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare 6 Oc = (R, 5)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare 6 Bk = (R, 7)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare 7 Oc = (L, 0)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_prepare 7 Bk = (W1, 7)"
+apply(simp add: fetch.simps t_wcode_prepare_def nth_of.simps)
+done
+
+lemma tape_of_nl_not_null: "lm \<noteq> [] \<Longrightarrow> <lm::nat list> \<noteq> []"
+apply(case_tac lm, auto)
+apply(case_tac list, auto simp: tape_of_nl_abv tape_of_nat_list.simps exp_ind_def)
+done
+
+lemma [simp]: "lm \<noteq> [] \<Longrightarrow> wprepare_add_one m lm (b, []) = False"
+apply(simp add: wprepare_invs)
+apply(simp add: tape_of_nl_not_null)
+done
+
+lemma [simp]: "lm \<noteq> [] \<Longrightarrow> wprepare_goto_first_end m lm (b, []) = False"
+apply(simp add: wprepare_invs)
+done
+
+lemma [simp]: "lm \<noteq> [] \<Longrightarrow> wprepare_erase m lm (b, []) = False"
+apply(simp add: wprepare_invs)
+done
+
+
+
+lemma [simp]: "lm \<noteq> [] \<Longrightarrow> wprepare_goto_start_pos m lm (b, []) = False"
+apply(simp add: wprepare_invs tape_of_nl_not_null)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_start m lm (b, [])\<rbrakk> \<Longrightarrow> b \<noteq> []"
+apply(simp add: wprepare_invs tape_of_nl_not_null, auto)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_start m lm (b, [])\<rbrakk> \<Longrightarrow>
+ wprepare_loop_goon m lm (Bk # b, [])"
+apply(simp only: wprepare_invs tape_of_nl_not_null)
+apply(erule_tac disjE)
+apply(rule_tac disjI2)
+apply(simp add: wprepare_loop_start_on_rightmost.simps
+ wprepare_loop_goon_on_rightmost.simps, auto)
+apply(rule_tac rev_eq, simp add: tape_of_nl_rev)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_goon m lm (b, [])\<rbrakk> \<Longrightarrow> b \<noteq> []"
+apply(simp only: wprepare_invs tape_of_nl_not_null, auto)
+done
+
+lemma [simp]:"\<lbrakk>lm \<noteq> []; wprepare_loop_goon m lm (b, [])\<rbrakk> \<Longrightarrow>
+ wprepare_add_one2 m lm (Bk # b, [])"
+apply(simp only: wprepare_invs tape_of_nl_not_null, auto split: if_splits)
+apply(case_tac mr, simp, simp add: exp_ind_def)
+done
+
+lemma [simp]: "wprepare_add_one2 m lm (b, []) \<Longrightarrow> b \<noteq> []"
+apply(simp only: wprepare_invs tape_of_nl_not_null, auto)
+done
+
+lemma [simp]: "wprepare_add_one2 m lm (b, []) \<Longrightarrow> wprepare_add_one2 m lm (b, [Oc])"
+apply(simp only: wprepare_invs tape_of_nl_not_null, auto)
+done
+
+lemma [simp]: "Bk # list = <(m::nat) # lm> @ ys = False"
+apply(case_tac lm, auto simp: tape_of_nl_abv tape_of_nat_list.simps exp_ind_def)
+done
+
+lemma [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, auto)
+apply(rule_tac x = 0 in exI, simp add: exp_ind_def)
+apply(case_tac lm, simp, simp add: tape_of_nl_abv tape_of_nat_list.simps exp_ind_def)
+apply(rule_tac x = rn in exI, simp)
+done
+
+lemma [simp]: "wprepare_goto_first_end m lm (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(simp only: wprepare_invs tape_of_nl_not_null, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wprepare_goto_first_end m lm (b, Bk # list) \<Longrightarrow>
+ wprepare_erase m lm (tl b, hd b # Bk # list)"
+apply(simp only: wprepare_invs tape_of_nl_not_null, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+apply(case_tac mr, auto simp: exp_ind_def)
+done
+
+lemma [simp]: "wprepare_erase m lm (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(simp only: wprepare_invs exp_ind_def, auto)
+done
+
+lemma [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 [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_nl_abv
+ tape_of_nat_list.simps exp_ind_def, auto)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_goto_first_end m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> list \<noteq> []"
+apply(simp only: wprepare_invs, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+apply(simp add: tape_of_nl_not_null)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_goto_first_end m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> b \<noteq> []"
+apply(simp only: wprepare_invs, auto)
+apply(case_tac mr, simp_all add: exp_ind_def tape_of_nl_not_null)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_erase m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> list \<noteq> []"
+apply(simp only: wprepare_invs, auto)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_erase m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> b \<noteq> []"
+apply(simp only: wprepare_invs, auto simp: exp_ind_def)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_goto_start_pos m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> list \<noteq> []"
+apply(simp only: wprepare_invs, auto)
+apply(simp add: tape_of_nl_not_null)
+apply(case_tac lm, simp, case_tac list)
+apply(simp_all add: tape_of_nl_abv tape_of_nat_list.simps exp_ind_def)
+done
+
+lemma [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 [simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_goon m lm (b, Bk # list)\<rbrakk> \<Longrightarrow> b \<noteq> []"
+apply(simp only: wprepare_invs, auto)
+done
+
+lemma [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))"
+apply(simp only: wprepare_invs, simp)
+apply(case_tac list, simp_all split: if_splits, auto)
+apply(case_tac [1-3] mr, simp_all add: exp_ind_def)
+apply(case_tac mr, simp_all add: exp_ind_def tape_of_nl_not_null)
+apply(case_tac [1-2] mr, simp_all add: exp_ind_def)
+apply(case_tac rn, simp, case_tac nat, auto simp: exp_ind_def)
+done
+
+lemma [simp]: "wprepare_add_one2 m lm (b, Bk # list) \<Longrightarrow> b \<noteq> []"
+apply(simp only: wprepare_invs, simp)
+done
+
+lemma [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 [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(case_tac mr, simp_all add: exp_ind_def)
+apply(case_tac ml, simp_all add: exp_ind_def)
+apply(rule_tac x = rn in exI, simp)
+apply(rule_tac x = "Suc ml" in exI, simp_all add: exp_ind_def)
+apply(rule_tac x = "mr - 1" in exI, simp)
+apply(case_tac mr, simp_all add: exp_ind_def, auto)
+done
+
+lemma [simp]: "wprepare_erase m lm (b, Oc # list) \<Longrightarrow> b \<noteq> []"
+apply(simp only: wprepare_invs, auto simp: exp_ind_def)
+done
+
+lemma [simp]: "wprepare_erase m lm (b, Oc # list)
+ \<Longrightarrow> wprepare_erase m lm (b, Bk # list)"
+apply(simp only:wprepare_invs, auto simp: exp_ind_def)
+done
+
+lemma [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 [simp]: "wprepare_loop_start m lm (b, aa) \<Longrightarrow> b \<noteq> []"
+apply(simp only:wprepare_invs, auto)
+done
+lemma [elim]: "Bk # list = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<Longrightarrow> \<exists>rn. list = Bk\<^bsup>rn\<^esup>"
+apply(case_tac mr, simp_all)
+apply(case_tac rn, simp_all add: exp_ind_def, auto)
+done
+
+lemma rev_equal_iff: "x = y \<Longrightarrow> rev x = rev y"
+by simp
+
+lemma tape_of_nl_false1:
+ "lm \<noteq> [] \<Longrightarrow> rev b @ [Bk] \<noteq> Bk\<^bsup>ln\<^esup> @ Oc # Oc\<^bsup>m\<^esup> @ Bk # Bk # <lm::nat list>"
+apply(auto)
+apply(drule_tac rev_equal_iff, simp add: tape_of_nl_rev)
+apply(case_tac "rev lm")
+apply(case_tac [2] list, auto simp: tape_of_nl_abv tape_of_nat_list.simps exp_ind_def)
+done
+
+lemma [simp]: "wprepare_loop_start_in_middle m lm (b, [Bk]) = False"
+apply(simp add: wprepare_loop_start_in_middle.simps, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+apply(case_tac lm1, simp, simp add: tape_of_nl_not_null)
+done
+
+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 [simp]: "wprepare_loop_goon_in_middle m lm (Bk # b, []) = False"
+apply(simp add: wprepare_loop_goon_in_middle.simps, auto)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_start m lm (b, [Bk])\<rbrakk> \<Longrightarrow>
+ wprepare_loop_goon m lm (Bk # b, [])"
+apply(simp only: wprepare_invs, simp)
+apply(simp add: wprepare_loop_goon_on_rightmost.simps
+ wprepare_loop_start_on_rightmost.simps, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+apply(rule_tac rev_eq)
+apply(simp add: tape_of_nl_rev)
+apply(simp add: exp_ind_def[THEN sym] exp_ind)
+done
+
+lemma [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)
+apply(case_tac [!] mr, simp_all add: exp_ind_def)
+done
+
+lemma [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)
+apply(case_tac mr, simp_all add: exp_ind_def)
+apply(simp add: tape_of_nl_rev)
+apply(simp add: exp_ind_def[THEN sym] exp_ind)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_loop_start_in_middle m lm (b, Bk # a # lista)\<rbrakk>
+ \<Longrightarrow> wprepare_loop_goon_on_rightmost m lm (Bk # b, a # lista) = False"
+apply(simp add: wprepare_loop_start_in_middle.simps
+ wprepare_loop_goon_on_rightmost.simps, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+apply(case_tac "lm1::nat list", simp_all, case_tac list, simp)
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps tape_of_nat_abv exp_ind_def)
+apply(case_tac [!] rna, simp_all add: exp_ind_def)
+apply(case_tac mr, simp_all add: exp_ind_def)
+apply(case_tac lm1, simp, case_tac list, simp)
+apply(simp_all add: tape_of_nl_abv tape_of_nat_list.simps exp_ind_def tape_of_nat_abv)
+done
+
+lemma [simp]:
+ "\<lbrakk>lm \<noteq> []; wprepare_loop_start_in_middle m lm (b, Bk # a # lista)\<rbrakk>
+ \<Longrightarrow> wprepare_loop_goon_in_middle m lm (Bk # b, a # lista)"
+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: exp_ind_def)
+apply(case_tac lm1, simp)
+apply(rule_tac x = "Suc aa" in exI, simp)
+apply(rule_tac x = list in exI)
+apply(case_tac list, simp_all add: tape_of_nl_abv tape_of_nat_list.simps)
+done
+
+lemma [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)))"
+apply(simp only: wprepare_add_one.simps, auto)
+done
+
+lemma [simp]: "wprepare_loop_start m lm (b, Oc # list) \<Longrightarrow> b \<noteq> []"
+apply(simp)
+done
+
+lemma [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, auto)
+apply(rule_tac x = rn in exI, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+apply(case_tac rn, auto simp: exp_ind_def)
+done
+
+lemma [simp]: "wprepare_loop_start_in_middle m lm (b, Oc # list) \<Longrightarrow>
+ wprepare_loop_start_in_middle m lm (Oc # b, list)"
+apply(simp add: wprepare_loop_start_in_middle.simps, auto)
+apply(rule_tac x = rn in exI, auto)
+apply(case_tac mr, simp, simp add: exp_ind_def)
+apply(rule_tac x = nat in exI, simp)
+apply(rule_tac x = lm1 in exI, simp)
+done
+
+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 [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 [simp]: "wprepare_goto_start_pos m lm (b, Oc # list) \<Longrightarrow> b \<noteq> []"
+apply(simp add: wprepare_goto_start_pos.simps)
+done
+
+lemma [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\<^bsup>mr\<^esup> = Oc\<^bsup>Suc m\<^esup> @ Bk # Bk # <lm>;
+ b \<noteq> []; 0 < mr; Oc # list = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup>\<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 add: exp_ind_def, auto)
+done
+
+lemma wprepare_loop2: "\<lbrakk>rev b @ Oc\<^bsup>mr\<^esup> @ Bk # <a # lista> = Oc\<^bsup>Suc m\<^esup> @ Bk # Bk # <lm>;
+ b \<noteq> []; Oc # list = Oc\<^bsup>mr\<^esup> @ Bk # <(a::nat) # lista> @ Bk\<^bsup>rn\<^esup>\<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: exp_ind_def)
+apply(rule_tac x = nat in exI, simp)
+apply(rule_tac x = "a#lista" in exI, simp)
+done
+
+lemma [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(case_tac lm1, simp_all add: wprepare_loop1 wprepare_loop2)
+done
+
+lemma [simp]: "wprepare_loop_goon m lm (b, Oc # list)
+ \<Longrightarrow> wprepare_loop_start m lm (Oc # b, list)"
+apply(simp add: wprepare_loop_goon.simps
+ wprepare_loop_start.simps)
+done
+
+lemma [simp]: "wprepare_add_one m lm (b, Oc # list)
+ \<Longrightarrow> b = [] \<longrightarrow> wprepare_add_one m lm ([], Bk # Oc # list)"
+apply(auto)
+apply(simp add: wprepare_add_one.simps)
+done
+
+lemma [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(rule_tac x = rn in exI, simp)
+apply(simp add: tape_of_nat_abv tape_of_nat_list.simps exp_ind_def, auto)
+done
+
+lemma [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(rule_tac x = rn in exI, simp)
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps exp_ind_def)
+apply(rule_tac x = a in exI, rule_tac x = "aa#listaa" in exI, simp)
+done
+
+lemma [simp]: "\<lbrakk>lm \<noteq> []; wprepare_goto_start_pos m lm (b, Oc # list)\<rbrakk>
+ \<Longrightarrow> wprepare_loop_start m lm (Oc # b, list)"
+apply(case_tac lm, simp_all)
+apply(case_tac lista, simp_all add: wprepare_loop_start.simps)
+done
+
+lemma [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_stop.simps 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. steps (Suc 0, [], (<m # lm>)) t_wcode_prepare 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. steps (Suc 0, [], (<m # lm>)) t_wcode_prepare stp)"
+ have "\<exists> n. ?P (?f n) \<and> ?Q (?f n)"
+ proof(rule_tac halt_lemma2)
+ show "wf wcode_prepare_le" by auto
+ next
+ 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, case_tac "?f n",
+ simp add: tstep_red tstep.simps)
+ apply(case_tac c, simp, case_tac [2] aa)
+ apply(simp_all add: wprepare_inv.simps wcode_prepare_le_def new_tape.simps
+ lex_triple_def lex_pair_def
+
+ split: if_splits)
+ 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
+ next
+ show "?Q (?f 0)"
+ apply(simp add: steps.simps wprepare_inv.simps wprepare_invs)
+ done
+ next
+ show "\<not> ?P (?f 0)"
+ apply(simp add: steps.simps)
+ done
+ qed
+ thus "?thesis"
+ apply(auto)
+ done
+qed
+
+lemma [intro]: "t_correct t_wcode_prepare"
+apply(simp add: t_correct.simps t_wcode_prepare_def iseven_def)
+apply(rule_tac x = 7 in exI, simp)
+done
+
+lemma twice_len_even: "length (tm_of abc_twice) mod 2 = 0"
+apply(simp add: tm_even)
+done
+
+lemma fourtimes_len_even: "length (tm_of abc_fourtimes) mod 2 = 0"
+apply(simp add: tm_even)
+done
+
+lemma t_correct_termi: "t_correct tp \<Longrightarrow>
+ list_all (\<lambda>(acn, st). (st \<le> Suc (length tp div 2))) (change_termi_state tp)"
+apply(auto simp: t_correct.simps List.list_all_length)
+apply(erule_tac x = n in allE, simp)
+apply(case_tac "tp!n", auto simp: change_termi_state.simps split: if_splits)
+done
+
+
+lemma t_correct_shift:
+ "list_all (\<lambda>(acn, st). (st \<le> y)) tp \<Longrightarrow>
+ list_all (\<lambda>(acn, st). (st \<le> y + off)) (tshift tp off) "
+apply(auto simp: t_correct.simps List.list_all_length)
+apply(erule_tac x = n in allE, simp add: shift_length)
+apply(case_tac "tp!n", auto simp: tshift.simps)
+done
+
+lemma [intro]:
+ "t_correct (tm_of abc_twice @ tMp (Suc 0)
+ (start_of twice_ly (length abc_twice) - Suc 0))"
+apply(rule_tac t_compiled_correct, simp_all)
+apply(simp add: twice_ly_def)
+done
+
+lemma [intro]: "t_correct (tm_of abc_fourtimes @ tMp (Suc 0)
+ (start_of fourtimes_ly (length abc_fourtimes) - Suc 0))"
+apply(rule_tac t_compiled_correct, simp_all)
+apply(simp add: fourtimes_ly_def)
+done
+
+
+lemma [intro]: "t_correct t_wcode_main"
+apply(auto simp: t_wcode_main_def t_correct.simps shift_length
+ t_twice_def t_fourtimes_def)
+proof -
+ show "iseven (60 + (length (tm_of abc_twice) +
+ length (tm_of abc_fourtimes)))"
+ using twice_len_even fourtimes_len_even
+ apply(auto simp: iseven_def)
+ apply(rule_tac x = "30 + q + qa" in exI, simp)
+ done
+next
+ show " list_all (\<lambda>(acn, s). s \<le> (60 + (length (tm_of abc_twice) +
+ length (tm_of abc_fourtimes))) div 2) t_wcode_main_first_part"
+ apply(auto simp: t_wcode_main_first_part_def shift_length t_twice_def)
+ done
+next
+ have "list_all (\<lambda>(acn, s). s \<le> Suc (length (tm_of abc_twice @ tMp (Suc 0)
+ (start_of twice_ly (length abc_twice) - Suc 0)) div 2))
+ (change_termi_state (tm_of abc_twice @ tMp (Suc 0)
+ (start_of twice_ly (length abc_twice) - Suc 0)))"
+ apply(rule_tac t_correct_termi, auto)
+ done
+ hence "list_all (\<lambda>(acn, s). s \<le> Suc (length (tm_of abc_twice @ tMp (Suc 0)
+ (start_of twice_ly (length abc_twice) - Suc 0)) div 2) + 12)
+ (abacus.tshift (change_termi_state (tm_of abc_twice @ tMp (Suc 0)
+ (start_of twice_ly (length abc_twice) - Suc 0))) 12)"
+ apply(rule_tac t_correct_shift, simp)
+ done
+ thus "list_all (\<lambda>(acn, s). s \<le>
+ (60 + (length (tm_of abc_twice) + length (tm_of abc_fourtimes))) div 2)
+ (abacus.tshift (change_termi_state (tm_of abc_twice @ tMp (Suc 0)
+ (start_of twice_ly (length abc_twice) - Suc 0))) 12)"
+ apply(simp)
+ apply(simp add: list_all_length, auto)
+ done
+next
+ have "list_all (\<lambda>(acn, s). s \<le> Suc (length (tm_of abc_fourtimes @ tMp (Suc 0)
+ (start_of fourtimes_ly (length abc_fourtimes) - Suc 0)) div 2))
+ (change_termi_state (tm_of abc_fourtimes @ tMp (Suc 0)
+ (start_of fourtimes_ly (length abc_fourtimes) - Suc 0))) "
+ apply(rule_tac t_correct_termi, auto)
+ done
+ hence "list_all (\<lambda>(acn, s). s \<le> Suc (length (tm_of abc_fourtimes @ tMp (Suc 0)
+ (start_of fourtimes_ly (length abc_fourtimes) - Suc 0)) div 2) + (t_twice_len + 13))
+ (abacus.tshift (change_termi_state (tm_of abc_fourtimes @ tMp (Suc 0)
+ (start_of fourtimes_ly (length abc_fourtimes) - Suc 0))) (t_twice_len + 13))"
+ apply(rule_tac t_correct_shift, simp)
+ done
+ thus "list_all (\<lambda>(acn, s). s \<le> (60 + (length (tm_of abc_twice) + length (tm_of abc_fourtimes))) div 2)
+ (abacus.tshift (change_termi_state (tm_of abc_fourtimes @ tMp (Suc 0)
+ (start_of fourtimes_ly (length abc_fourtimes) - Suc 0))) (t_twice_len + 13))"
+ apply(simp add: t_twice_len_def t_twice_def)
+ using twice_len_even fourtimes_len_even
+ apply(auto simp: list_all_length)
+ done
+qed
+
+lemma [intro]: "t_correct (t_wcode_prepare |+| t_wcode_main)"
+apply(auto intro: t_correct_add)
+done
+
+lemma prepare_mainpart_lemma:
+ "args \<noteq> [] \<Longrightarrow>
+ \<exists> stp ln rn. steps (Suc 0, [], <m # args>) (t_wcode_prepare |+| t_wcode_main) stp
+ = (0, Bk # Oc\<^bsup>Suc m\<^esup>, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<args>)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+proof -
+ let ?P1 = "\<lambda> (l, r). l = [] \<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\<^bsup>Suc m\<^esup> \<and>
+ r = Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<args>)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ let ?P3 = "\<lambda> tp. False"
+ assume h: "args \<noteq> []"
+ have "?P1 \<turnstile>-> \<lambda> tp. (\<exists> stp tp'. steps (Suc 0, tp)
+ (t_wcode_prepare |+| t_wcode_main) stp = (0, tp') \<and> ?Q2 tp')"
+ proof(rule_tac turing_merge.t_merge_halt[of t_wcode_prepare t_wcode_main ?P1 ?P2 ?P3 ?P3 ?Q1 ?Q2],
+ auto simp: turing_merge_def)
+ show "\<exists>stp. case steps (Suc 0, [], <m # args>) t_wcode_prepare stp of (st, tp')
+ \<Rightarrow> st = 0 \<and> wprepare_stop m args tp'"
+ using wprepare_correctness[of args m] h
+ apply(simp, auto)
+ apply(rule_tac x = n in exI, simp add: wprepare_inv.simps)
+ done
+ next
+ fix a b
+ assume "wprepare_stop m args (a, b)"
+ thus "\<exists>stp. case steps (Suc 0, a, b) t_wcode_main stp of
+ (st, tp') \<Rightarrow> (st = 0) \<and> (case tp' of (l, r) \<Rightarrow> l = Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ (\<exists>ln rn. r = Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<args>)\<^esup> @ Bk\<^bsup>rn\<^esup>))"
+ proof(simp only: wprepare_stop.simps, erule_tac exE)
+ fix rn
+ assume "a = Bk # <rev args> @ Bk # Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ b = Bk # Oc # Bk\<^bsup>rn\<^esup>"
+ thus "?thesis"
+ using t_wcode_main_lemma_pre[of "args" "<args>" 0 "Oc\<^bsup>Suc m\<^esup>" 0 rn] h
+ apply(simp)
+ apply(erule_tac exE)+
+ apply(rule_tac x = stp in exI, simp add: tape_of_nl_rev, auto)
+ done
+ qed
+ next
+ show "wprepare_stop m args \<turnstile>-> wprepare_stop m args"
+ by(simp add: t_imply_def)
+ qed
+ thus "\<exists> stp ln rn. steps (Suc 0, [], <m # args>) (t_wcode_prepare |+| t_wcode_main) stp
+ = (0, Bk # Oc\<^bsup>Suc m\<^esup>, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<args>)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(simp add: t_imply_def)
+ apply(erule_tac exE)+
+ apply(auto)
+ done
+qed
+
+
+lemma [simp]: "tinres r r' \<Longrightarrow>
+ fetch t ss (case r of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x) =
+ fetch t ss (case r' of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)"
+apply(simp add: fetch.simps, auto split: if_splits simp: tinres_def)
+apply(case_tac [!] r', simp_all)
+apply(case_tac [!] n, simp_all add: exp_ind_def)
+apply(case_tac [!] r, simp_all)
+done
+
+lemma [intro]: "\<exists> n. (a::block)\<^bsup>n\<^esup> = []"
+by auto
+
+lemma [simp]: "\<lbrakk>tinres r r'; r \<noteq> []; r' \<noteq> []\<rbrakk> \<Longrightarrow> hd r = hd r'"
+apply(auto simp: tinres_def)
+done
+
+lemma [intro]: "hd (Bk\<^bsup>Suc n\<^esup>) = Bk"
+apply(simp add: exp_ind_def)
+done
+
+lemma [simp]: "\<lbrakk>tinres r []; r \<noteq> []\<rbrakk> \<Longrightarrow> hd r = Bk"
+apply(auto simp: tinres_def)
+apply(case_tac n, auto)
+done
+
+lemma [simp]: "\<lbrakk>tinres [] r'; r' \<noteq> []\<rbrakk> \<Longrightarrow> hd r' = Bk"
+apply(auto simp: tinres_def)
+done
+
+lemma [intro]: "\<exists>na. tl r = tl (r @ Bk\<^bsup>n\<^esup>) @ Bk\<^bsup>na\<^esup> \<or> tl (r @ Bk\<^bsup>n\<^esup>) = tl r @ Bk\<^bsup>na\<^esup>"
+apply(case_tac r, simp)
+apply(case_tac n, simp)
+apply(rule_tac x = 0 in exI, simp)
+apply(rule_tac x = nat in exI, simp add: exp_ind_def)
+apply(simp)
+apply(rule_tac x = n in exI, simp)
+done
+
+lemma [simp]: "tinres r r' \<Longrightarrow> tinres (tl r) (tl r')"
+apply(auto simp: tinres_def)
+apply(case_tac r', simp_all)
+apply(case_tac n, simp_all add: exp_ind_def)
+apply(rule_tac x = 0 in exI, simp)
+apply(rule_tac x = nat in exI, simp_all)
+apply(rule_tac x = n in exI, simp)
+done
+
+lemma [simp]: "\<lbrakk>tinres r []; r \<noteq> []\<rbrakk> \<Longrightarrow> tinres (tl r) []"
+apply(case_tac r, auto simp: tinres_def)
+apply(case_tac n, simp_all add: exp_ind_def)
+apply(rule_tac x = nat in exI, simp)
+done
+
+lemma [simp]: "\<lbrakk>tinres [] r'\<rbrakk> \<Longrightarrow> tinres [] (tl r')"
+apply(case_tac r', auto simp: tinres_def)
+apply(case_tac n, simp_all add: exp_ind_def)
+apply(rule_tac x = nat in exI, simp)
+done
+
+lemma [simp]: "tinres r r' \<Longrightarrow> tinres (b # r) (b # r')"
+apply(auto simp: tinres_def)
+done
+
+lemma tinres_step2:
+ "\<lbrakk>tinres r r'; tstep (ss, l, r) t = (sa, la, ra); tstep (ss, l, r') t = (sb, lb, rb)\<rbrakk>
+ \<Longrightarrow> la = lb \<and> tinres ra rb \<and> sa = sb"
+apply(case_tac "ss = 0", simp add: tstep_0)
+apply(simp add: tstep.simps [simp del])
+apply(case_tac "fetch t ss (case r of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)", simp)
+apply(auto simp: new_tape.simps)
+apply(simp_all split: taction.splits if_splits)
+apply(auto)
+done
+
+
+lemma tinres_steps2:
+ "\<lbrakk>tinres r r'; steps (ss, l, r) t stp = (sa, la, ra); steps (ss, l, r') t stp = (sb, lb, rb)\<rbrakk>
+ \<Longrightarrow> la = lb \<and> tinres ra rb \<and> sa = sb"
+apply(induct stp arbitrary: sa la ra sb lb rb, simp add: steps.simps)
+apply(simp add: tstep_red)
+apply(case_tac "(steps (ss, l, r) t stp)")
+apply(case_tac "(steps (ss, l, r') t 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 stp = (sa, la, ra);
+ steps (ss, l, r') t stp = (sb, lb, rb)\<rbrakk> \<Longrightarrow> la = lb \<and> tinres ra rb \<and> sa = sb"
+ and h: " tinres r r'" "tstep (steps (ss, l, r) t stp) t = (sa, la, ra)"
+ "tstep (steps (ss, l, r') t stp) t = (sb, lb, rb)" "steps (ss, l, r) t stp = (a, b, c)"
+ "steps (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
+
+
+text{**************Begin: adjust***************************}
+definition t_wcode_adjust :: "tprog"
+ where
+ "t_wcode_adjust = [(W1, 1), (R, 2), (Nop, 2), (R, 3), (R, 3), (R, 4),
+ (L, 8), (L, 5), (L, 6), (W0, 5), (L, 6), (R, 7),
+ (W1, 2), (Nop, 7), (L, 9), (W0, 8), (L, 9), (L, 10),
+ (L, 11), (L, 10), (R, 0), (L, 11)]"
+
+lemma [simp]: "fetch t_wcode_adjust (Suc 0) Bk = (W1, 1)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust (Suc 0) Oc = (R, 2)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust (Suc (Suc 0)) Oc = (R, 3)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust (Suc (Suc (Suc 0))) Oc = (R, 4)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust (Suc (Suc (Suc 0))) Bk = (R, 3)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 4 Bk = (L, 8)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 4 Oc = (L, 5)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 5 Oc = (W0, 5)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 5 Bk = (L, 6)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 6 Oc = (R, 7)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 6 Bk = (L, 6)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 7 Bk = (W1, 2)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 8 Bk = (L, 9)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 8 Oc = (W0, 8)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 9 Oc = (L, 10)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 9 Bk = (L, 9)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 10 Bk = (L, 11)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 10 Oc = (L, 10)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 11 Oc = (L, 11)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+lemma [simp]: "fetch t_wcode_adjust 11 Bk = (R, 0)"
+apply(simp add: fetch.simps t_wcode_adjust_def nth_of.simps)
+done
+
+fun wadjust_start :: "nat \<Rightarrow> nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "wadjust_start m rs (l, r) =
+ (\<exists> ln rn. l = Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ tl r = Oc # Bk\<^bsup>ln\<^esup> @ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ml\<^esup> @ Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ r = Oc # Bk\<^bsup>ln\<^esup> @ Bk # Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>nl\<^esup> @ Oc # Oc\<^bsup>ml\<^esup> @ Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ r = Bk\<^bsup>nr\<^esup> @ Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ln\<^esup> @ Bk # Oc # Oc\<^bsup>ml\<^esup> @ Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ r = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ln\<^esup> @ Bk # Oc # Oc\<^bsup>ml\<^esup> @ Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ tl r = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ml\<^esup> @ Bk # Oc\<^bsup>Suc m \<^esup>\<and>
+ r = Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>nl\<^esup> @ Oc # Oc\<^bsup>ml\<^esup> @ Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ r = Bk\<^bsup>nr\<^esup> @ Bk # Bk # Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ml\<^esup> @ Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ r = Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>ln\<^esup> @ Bk # Oc # Oc\<^bsup>Suc rs\<^esup> @ Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ tl r = Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>Suc rs\<^esup> @ Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ r = Oc # Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ln\<^esup> @ Oc # Oc\<^bsup>Suc rs\<^esup> @ Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ r = Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>Suc m\<^esup> \<and>
+ r = Bk # Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ml\<^esup> @ Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ r = Oc\<^bsup>mr\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>Suc m \<^esup>@ Bk # Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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\<^bsup>ml\<^esup> \<and>
+ r = Oc\<^bsup>mr\<^esup> @ Bk # Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rn\<^esup> \<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\<^bsup>Suc m \<^esup>@ Bk # Oc\<^bsup>Suc (Suc rs)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+
+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> t_conf \<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)"
+
+thm dropWhile.simps
+
+fun wadjust_stage :: "nat \<Rightarrow> t_conf \<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> t_conf \<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> t_conf \<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> t_conf) \<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> t_conf) \<times> nat \<times> t_conf) set"
+ where "wadjust_le \<equiv> (inv_image lex_square wadjust_measure)"
+
+lemma [intro]: "wf lex_square"
+by(auto intro:wf_lex_prod simp: abacus.lex_pair_def lex_square_def
+ abacus.lex_triple_def)
+
+lemma wf_wadjust_le[intro]: "wf wadjust_le"
+by(auto intro:wf_inv_image simp: wadjust_le_def
+ abacus.lex_triple_def abacus.lex_pair_def)
+
+lemma [simp]: "wadjust_start m rs (c, []) = False"
+apply(auto simp: wadjust_start.simps)
+done
+
+lemma [simp]: "wadjust_loop_right_move m rs (c, []) \<Longrightarrow> c \<noteq> []"
+apply(auto simp: wadjust_loop_right_move.simps)
+done
+
+lemma [simp]: "wadjust_loop_right_move m rs (c, [])
+ \<Longrightarrow> wadjust_loop_check m rs (Bk # c, [])"
+apply(simp only: wadjust_loop_right_move.simps wadjust_loop_check.simps)
+apply(auto)
+apply(case_tac [!] mr, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_loop_check m rs (c, []) \<Longrightarrow> c \<noteq> []"
+apply(simp only: wadjust_loop_check.simps, auto)
+done
+
+lemma [simp]: "wadjust_loop_start m rs (c, []) = False"
+apply(simp add: wadjust_loop_start.simps)
+done
+
+lemma [simp]: "wadjust_loop_right_move m rs (c, []) \<Longrightarrow>
+ wadjust_loop_right_move m rs (Bk # c, [])"
+apply(simp only: wadjust_loop_right_move.simps)
+apply(erule_tac exE)+
+apply(auto)
+apply(case_tac [!] mr, simp_all add: exp_ind_def)
+done
+
+lemma [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)
+apply(case_tac mr, simp_all add: exp_ind_def, auto)
+done
+
+lemma [simp]: " wadjust_loop_erase m rs (c, [])
+ \<Longrightarrow> (c = [] \<longrightarrow> wadjust_loop_on_left_moving m rs ([], [Bk])) \<and>
+ (c \<noteq> [] \<longrightarrow> wadjust_loop_on_left_moving m rs (tl c, [hd c]))"
+apply(simp add: wadjust_loop_erase.simps, auto)
+apply(case_tac [!] mr, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_loop_on_left_moving m rs (c, []) = False"
+apply(auto simp: wadjust_loop_on_left_moving.simps)
+done
+
+
+lemma [simp]: "wadjust_loop_right_move2 m rs (c, []) = False"
+apply(auto simp: wadjust_loop_right_move2.simps)
+done
+
+lemma [simp]: "wadjust_erase2 m rs ([], []) = False"
+apply(auto simp: wadjust_erase2.simps)
+done
+
+lemma [simp]: "wadjust_on_left_moving_B m rs
+ (Oc # Oc # Oc\<^bsup>rs\<^esup> @ Bk # Oc # Oc\<^bsup>m\<^esup>, [Bk])"
+apply(simp add: wadjust_on_left_moving_B.simps, auto)
+apply(rule_tac x = 0 in exI, simp add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_on_left_moving_B m rs
+ (Bk\<^bsup>n\<^esup> @ Bk # Oc # Oc # Oc\<^bsup>rs\<^esup> @ Bk # Oc # Oc\<^bsup>m\<^esup>, [Bk])"
+apply(simp add: wadjust_on_left_moving_B.simps exp_ind_def, auto)
+apply(rule_tac x = "Suc n" in exI, simp add: exp_ind)
+done
+
+lemma [simp]: "\<lbrakk>wadjust_erase2 m rs (c, []); c \<noteq> []\<rbrakk> \<Longrightarrow>
+ wadjust_on_left_moving m rs (tl c, [hd c])"
+apply(simp only: wadjust_erase2.simps)
+apply(erule_tac exE)+
+apply(case_tac ln, simp_all add: exp_ind_def wadjust_on_left_moving.simps)
+done
+
+lemma [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 [simp]: "wadjust_on_left_moving m rs ([], []) = False"
+apply(simp add: wadjust_on_left_moving.simps
+ wadjust_on_left_moving_O.simps wadjust_on_left_moving_B.simps)
+done
+
+lemma [simp]: "wadjust_on_left_moving_O m rs (c, []) = False"
+apply(simp add: wadjust_on_left_moving_O.simps)
+done
+
+lemma [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(simp add: wadjust_on_left_moving_B.simps, auto)
+apply(case_tac [!] ln, simp_all add: exp_ind_def, auto)
+done
+
+lemma [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(simp add: wadjust_on_left_moving_B.simps wadjust_on_left_moving_O.simps, auto)
+apply(case_tac [!] ln, simp_all add: exp_ind_def)
+done
+
+lemma [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 [simp]: "wadjust_on_left_moving 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 [simp]: "wadjust_goon_left_moving m rs (c, []) = False"
+apply(auto simp: wadjust_goon_left_moving.simps wadjust_goon_left_moving_B.simps
+ wadjust_goon_left_moving_O.simps)
+done
+
+lemma [simp]: "wadjust_backto_standard_pos m rs (c, []) = False"
+apply(auto simp: wadjust_backto_standard_pos.simps
+ wadjust_backto_standard_pos_B.simps wadjust_backto_standard_pos_O.simps)
+done
+
+lemma [simp]:
+ "wadjust_start m rs (c, Bk # list) \<Longrightarrow>
+ (c = [] \<longrightarrow> wadjust_start m rs ([], Oc # list)) \<and>
+ (c \<noteq> [] \<longrightarrow> wadjust_start m rs (c, Oc # list))"
+apply(auto simp: wadjust_start.simps)
+done
+
+lemma [simp]: "wadjust_loop_start m rs (c, Bk # list) = False"
+apply(auto simp: wadjust_loop_start.simps)
+done
+
+lemma [simp]: "wadjust_loop_right_move m rs (c, b) \<Longrightarrow> c \<noteq> []"
+apply(simp only: wadjust_loop_right_move.simps, auto)
+done
+
+lemma [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(rule_tac x = ml in exI, simp)
+apply(rule_tac x = mr in exI, simp)
+apply(rule_tac x = "Suc nl" in exI, simp add: exp_ind_def)
+apply(case_tac nr, simp, case_tac mr, simp_all add: exp_ind_def)
+apply(rule_tac x = nat in exI, auto)
+done
+
+lemma [simp]: "wadjust_loop_check m rs (c, b) \<Longrightarrow> c \<noteq> []"
+apply(simp only: wadjust_loop_check.simps, auto)
+done
+
+lemma [simp]: "wadjust_loop_check m rs (c, Bk # list)
+ \<Longrightarrow> wadjust_erase2 m rs (tl c, hd c # Bk # list)"
+apply(auto simp: wadjust_loop_check.simps wadjust_erase2.simps)
+apply(case_tac [!] mr, simp_all add: exp_ind_def, auto)
+done
+
+lemma [simp]: "wadjust_loop_erase m rs (c, b) \<Longrightarrow> c \<noteq> []"
+apply(simp only: wadjust_loop_erase.simps, auto)
+done
+
+declare wadjust_loop_on_left_moving_O.simps[simp del]
+ wadjust_loop_on_left_moving_B.simps[simp del]
+
+lemma [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)"
+apply(simp only: wadjust_loop_erase.simps
+ wadjust_loop_on_left_moving_B.simps)
+apply(erule_tac exE)+
+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, simp)
+apply(case_tac ln, simp_all add: exp_ind_def, auto)
+apply(simp add: exp_ind exp_ind_def[THEN sym])
+done
+
+lemma [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(simp only: wadjust_loop_erase.simps wadjust_loop_on_left_moving_O.simps,
+ auto)
+apply(case_tac [!] ln, simp_all add: exp_ind_def)
+done
+
+lemma [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 [simp]: "wadjust_loop_on_left_moving m rs (c, b) \<Longrightarrow> c \<noteq> []"
+apply(simp add: wadjust_loop_on_left_moving.simps
+wadjust_loop_on_left_moving_O.simps wadjust_loop_on_left_moving_B.simps, auto)
+done
+
+lemma [simp]: "wadjust_loop_on_left_moving_O m rs (c, Bk # list) = False"
+apply(simp add: wadjust_loop_on_left_moving_O.simps)
+done
+
+lemma [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)+
+apply(rule_tac x = ml in exI, rule_tac x = mr in exI)
+apply(case_tac nl, simp_all add: exp_ind_def, auto)
+apply(rule_tac x = "Suc nr" in exI, auto simp: exp_ind_def)
+done
+
+lemma [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)
+apply(erule_tac exE)+
+apply(rule_tac x = ml in exI, rule_tac x = mr in exI)
+apply(case_tac nl, simp_all add: exp_ind_def, auto)
+done
+
+lemma [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 [simp]: "wadjust_loop_right_move2 m rs (c, b) \<Longrightarrow> c \<noteq> []"
+apply(simp only: wadjust_loop_right_move2.simps, auto)
+done
+
+lemma [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)
+apply(case_tac ln, simp_all add: exp_ind_def)
+apply(rule_tac x = 0 in exI, simp)
+apply(rule_tac x = rn in exI, simp)
+apply(rule_tac x = "Suc ml" in exI, simp add: exp_ind_def, auto)
+apply(rule_tac x = "Suc nat" in exI, simp add: exp_ind)
+apply(rule_tac x = rn in exI, auto)
+apply(rule_tac x = "Suc ml" in exI, auto simp: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_erase2 m rs (c, Bk # list) \<Longrightarrow> c \<noteq> []"
+apply(auto simp:wadjust_erase2.simps )
+done
+
+lemma [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)
+apply(case_tac ln, simp_all add: exp_ind_def wadjust_on_left_moving.simps
+ wadjust_on_left_moving_O.simps wadjust_on_left_moving_B.simps)
+apply(auto)
+apply(rule_tac x = "(Suc (Suc rn))" in exI, simp add: exp_ind_def)
+apply(rule_tac x = "Suc nat" in exI, simp add: exp_ind)
+apply(rule_tac x = "(Suc (Suc rn))" in exI, simp add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_on_left_moving m rs (c,b) \<Longrightarrow> c \<noteq> []"
+apply(simp only:wadjust_on_left_moving.simps
+ wadjust_on_left_moving_O.simps
+ wadjust_on_left_moving_B.simps
+ , auto)
+done
+
+lemma [simp]: "wadjust_on_left_moving_O m rs (c, Bk # list) = False"
+apply(simp add: wadjust_on_left_moving_O.simps)
+done
+
+lemma [simp]: "\<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)
+apply(case_tac ln, simp_all add: exp_ind_def, auto)
+done
+
+lemma [simp]: "\<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)
+apply(case_tac ln, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_on_left_moving m rs (c, Bk # list) \<Longrightarrow>
+ wadjust_on_left_moving m rs (tl c, hd c # Bk # list)"
+apply(simp add: wadjust_on_left_moving.simps)
+apply(case_tac "hd c", simp_all)
+done
+
+lemma [simp]: "wadjust_goon_left_moving m rs (c, b) \<Longrightarrow> c \<noteq> []"
+apply(simp add: wadjust_goon_left_moving.simps
+ wadjust_goon_left_moving_B.simps
+ wadjust_goon_left_moving_O.simps exp_ind_def, auto)
+done
+
+lemma [simp]: "wadjust_goon_left_moving_O m rs (c, Bk # list) = False"
+apply(simp add: wadjust_goon_left_moving_O.simps, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "\<lbrakk>wadjust_goon_left_moving_B m rs (c, Bk # list); hd c = Bk\<rbrakk>
+ \<Longrightarrow> wadjust_backto_standard_pos_B m rs (tl c, Bk # Bk # list)"
+apply(auto simp: wadjust_goon_left_moving_B.simps
+ wadjust_backto_standard_pos_B.simps exp_ind_def)
+done
+
+lemma [simp]: "\<lbrakk>wadjust_goon_left_moving_B m rs (c, Bk # list); hd c = Oc\<rbrakk>
+ \<Longrightarrow> wadjust_backto_standard_pos_O m rs (tl c, Oc # Bk # list)"
+apply(auto simp: wadjust_goon_left_moving_B.simps
+ wadjust_backto_standard_pos_O.simps exp_ind_def)
+apply(rule_tac x = m in exI, simp, auto)
+done
+
+lemma [simp]: "wadjust_goon_left_moving m rs (c, Bk # list) \<Longrightarrow>
+ wadjust_backto_standard_pos m rs (tl c, hd c # Bk # list)"
+apply(case_tac "hd c", simp_all add: wadjust_backto_standard_pos.simps
+ wadjust_goon_left_moving.simps)
+done
+
+lemma [simp]: "wadjust_backto_standard_pos m rs (c, Bk # list) \<Longrightarrow>
+ (c = [] \<longrightarrow> wadjust_stop m rs ([Bk], list)) \<and> (c \<noteq> [] \<longrightarrow> wadjust_stop m rs (Bk # c, list))"
+apply(auto simp: wadjust_backto_standard_pos.simps
+ wadjust_backto_standard_pos_B.simps
+ wadjust_backto_standard_pos_O.simps wadjust_stop.simps)
+apply(case_tac [!] mr, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_start m rs (c, Oc # list)
+ \<Longrightarrow> (c = [] \<longrightarrow> wadjust_loop_start m rs ([Oc], list)) \<and>
+ (c \<noteq> [] \<longrightarrow> wadjust_loop_start m rs (Oc # c, list))"
+apply(auto simp:wadjust_loop_start.simps wadjust_start.simps )
+apply(rule_tac x = ln in exI, rule_tac x = rn in exI,
+ rule_tac x = "Suc 0" in exI, simp)
+done
+
+lemma [simp]: "wadjust_loop_start m rs (c, b) \<Longrightarrow> c \<noteq> []"
+apply(simp add: wadjust_loop_start.simps, auto)
+done
+
+lemma [simp]: "wadjust_loop_start m rs (c, Oc # list)
+ \<Longrightarrow> wadjust_loop_right_move m rs (Oc # c, list)"
+apply(simp add: wadjust_loop_start.simps wadjust_loop_right_move.simps, auto)
+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, auto)
+done
+
+lemma [simp]: "wadjust_loop_right_move m rs (c, Oc # list) \<Longrightarrow>
+ wadjust_loop_check m rs (Oc # c, list)"
+apply(simp add: wadjust_loop_right_move.simps
+ wadjust_loop_check.simps, auto)
+apply(rule_tac [!] x = ml in exI, simp_all, auto)
+apply(case_tac nl, auto simp: exp_ind_def)
+apply(rule_tac x = "mr - 1" in exI, case_tac mr, simp_all add: exp_ind_def)
+apply(case_tac [!] nr, simp_all add: exp_ind_def, auto)
+done
+
+lemma [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)+
+apply(rule_tac x = ml in exI, rule_tac x = mr in exI, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+apply(case_tac rn, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_loop_erase m rs (c, Oc # list) \<Longrightarrow>
+ wadjust_loop_erase m rs (c, Bk # list)"
+apply(auto simp: wadjust_loop_erase.simps)
+done
+
+lemma [simp]: "wadjust_loop_on_left_moving_B m rs (c, Oc # list) = False"
+apply(auto simp: wadjust_loop_on_left_moving_B.simps)
+apply(case_tac nr, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_loop_on_left_moving m rs (c, Oc # list)
+ \<Longrightarrow> wadjust_loop_right_move2 m rs (Oc # c, list)"
+apply(simp add:wadjust_loop_on_left_moving.simps)
+apply(auto simp: wadjust_loop_on_left_moving_O.simps
+ wadjust_loop_right_move2.simps)
+done
+
+lemma [simp]: "wadjust_loop_right_move2 m rs (c, Oc # list) = False"
+apply(auto simp: wadjust_loop_right_move2.simps )
+apply(case_tac ln, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_erase2 m rs (c, Oc # list)
+ \<Longrightarrow> (c = [] \<longrightarrow> wadjust_erase2 m rs ([], Bk # list))
+ \<and> (c \<noteq> [] \<longrightarrow> wadjust_erase2 m rs (c, Bk # list))"
+apply(auto simp: wadjust_erase2.simps )
+done
+
+lemma [simp]: "wadjust_on_left_moving_B m rs (c, Oc # list) = False"
+apply(auto simp: wadjust_on_left_moving_B.simps)
+done
+
+lemma [simp]: "\<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 exp_ind_def)
+done
+
+lemma [simp]: "\<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 exp_ind_def)
+apply(rule_tac x = rs in exI, simp)
+apply(auto simp: exp_ind_def numeral_2_eq_2)
+done
+
+
+lemma [simp]: "wadjust_on_left_moving m rs (c, Oc # list) \<Longrightarrow>
+ wadjust_goon_left_moving m rs (tl c, hd c # Oc # list)"
+apply(simp add: wadjust_on_left_moving.simps
+ wadjust_goon_left_moving.simps)
+apply(case_tac "hd c", simp_all)
+done
+
+lemma [simp]: "wadjust_on_left_moving m rs (c, Oc # list) \<Longrightarrow>
+ wadjust_goon_left_moving m rs (tl c, hd c # Oc # list)"
+apply(simp add: wadjust_on_left_moving.simps
+ wadjust_goon_left_moving.simps)
+apply(case_tac "hd c", simp_all)
+done
+
+lemma [simp]: "wadjust_goon_left_moving_B m rs (c, Oc # list) = False"
+apply(auto simp: wadjust_goon_left_moving_B.simps)
+done
+
+lemma [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)
+apply(case_tac [!] ml, auto simp: exp_ind_def)
+done
+
+lemma [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(rule_tac x = "ml - 1" in exI, simp)
+apply(case_tac ml, simp_all add: exp_ind_def)
+apply(rule_tac x = "Suc mr" in exI, auto simp: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_goon_left_moving m rs (c, Oc # list) \<Longrightarrow>
+ wadjust_goon_left_moving m rs (tl c, hd c # Oc # list)"
+apply(simp add: wadjust_goon_left_moving.simps)
+apply(case_tac "hd c", simp_all)
+done
+
+lemma [simp]: "wadjust_backto_standard_pos_B m rs (c, Oc # list) = False"
+apply(simp add: wadjust_backto_standard_pos_B.simps)
+done
+
+lemma [simp]: "wadjust_backto_standard_pos_O m rs (c, Bk # xs) = False"
+apply(simp add: wadjust_backto_standard_pos_O.simps, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+done
+
+
+
+lemma [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)
+apply(rule_tac x = rn in exI, simp)
+apply(case_tac ml, simp_all add: exp_ind_def)
+done
+
+
+lemma [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)
+apply(case_tac [!] ml, simp_all add: exp_ind_def)
+done
+
+lemma [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)
+apply(case_tac ml, simp_all add: exp_ind_def, auto)
+apply(rule_tac x = nat in exI, auto simp: exp_ind_def)
+done
+
+lemma [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
+thm wadjust_loop_right_move.simps
+
+lemma [simp]: "wadjust_loop_right_move m rs (c, []) = False"
+apply(simp only: wadjust_loop_right_move.simps)
+apply(rule_tac iffI)
+apply(erule_tac exE)+
+apply(case_tac nr, simp_all add: exp_ind_def)
+apply(case_tac mr, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_loop_erase m rs (c, []) = False"
+apply(simp only: wadjust_loop_erase.simps, auto)
+apply(case_tac mr, simp_all add: exp_ind_def)
+done
+
+lemma [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 [simp]:
+ "\<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 dropWhile_exp1: "dropWhile (\<lambda>a. a = Oc) (Oc\<^bsup>n\<^esup> @ xs) = dropWhile (\<lambda>a. a = Oc) xs"
+apply(induct n, simp_all add: exp_ind_def)
+done
+lemma takeWhile_exp1: "takeWhile (\<lambda>a. a = Oc) (Oc\<^bsup>n\<^esup> @ xs) = Oc\<^bsup>n\<^esup> @ takeWhile (\<lambda>a. a = Oc) xs"
+apply(induct n, simp_all add: exp_ind_def)
+done
+
+lemma [simp]: "\<lbrakk>Suc (Suc rs) = a; wadjust_loop_right_move2 m rs (c, Bk # list)\<rbrakk>
+ \<Longrightarrow> 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))))"
+apply(simp add: wadjust_loop_right_move2.simps, auto)
+apply(simp add: dropWhile_exp1 takeWhile_exp1)
+apply(case_tac ln, simp, simp add: exp_ind_def)
+done
+
+lemma [simp]: "wadjust_loop_check m rs ([], b) = False"
+apply(simp add: wadjust_loop_check.simps)
+done
+
+lemma [simp]: "\<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 [simp]:
+ "\<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
+
+declare numeral_2_eq_2[simp del]
+
+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), steps (Suc 0, Bk # Oc\<^bsup>Suc m\<^esup>,
+ Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>) t_wcode_adjust 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), steps (Suc 0, Bk # Oc\<^bsup>Suc m\<^esup>,
+ Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>) t_wcode_adjust stp)"
+ have "\<exists> n. ?P (?f n) \<and> ?Q (?f n)"
+ proof(rule_tac halt_lemma2)
+ show "wf wadjust_le" by auto
+ next
+ show "\<forall> n. \<not> ?P (?f n) \<and> ?Q (?f n) \<longrightarrow>
+ ?Q (?f (Suc n)) \<and> (?f (Suc n), ?f n) \<in> wadjust_le"
+ proof(rule_tac allI, rule_tac impI, case_tac "?f n",
+ simp add: tstep_red tstep.simps, rule_tac conjI, erule_tac conjE,
+ erule_tac conjE)
+ fix n a b c d
+ assume "0 < b" "wadjust_inv b m rs (c, d)" "Suc (Suc rs) = a"
+ thus "case case fetch t_wcode_adjust b (case d of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)
+ of (ac, ns) \<Rightarrow> (ns, new_tape ac (c, d)) of (st, x) \<Rightarrow> wadjust_inv st m rs x"
+ apply(case_tac d, simp, case_tac [2] aa)
+ apply(simp_all add: wadjust_inv.simps wadjust_le_def new_tape.simps
+ abacus.lex_triple_def abacus.lex_pair_def lex_square_def
+ split: if_splits)
+ done
+ next
+ fix n a b c d
+ assume "0 < b \<and> wadjust_inv b m rs (c, d)"
+ "Suc (Suc rs) = a \<and> steps (Suc 0, Bk # Oc\<^bsup>Suc m\<^esup>,
+ Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>rn\<^esup>) t_wcode_adjust n = (b, c, d)"
+ thus "((a, case fetch t_wcode_adjust b (case d of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)
+ of (ac, ns) \<Rightarrow> (ns, new_tape ac (c, d))), a, b, c, d) \<in> wadjust_le"
+ proof(erule_tac conjE, erule_tac conjE, erule_tac conjE)
+ assume "0 < b" "wadjust_inv b m rs (c, d)" "Suc (Suc rs) = a"
+ thus "?thesis"
+ apply(case_tac d, case_tac [2] aa)
+ apply(simp_all add: wadjust_inv.simps wadjust_le_def new_tape.simps
+ abacus.lex_triple_def abacus.lex_pair_def lex_square_def
+ split: if_splits)
+ done
+ qed
+ qed
+ next
+ show "?Q (?f 0)"
+ apply(simp add: steps.simps wadjust_inv.simps wadjust_start.simps)
+ apply(rule_tac x = ln in exI,auto)
+ done
+ next
+ show "\<not> ?P (?f 0)"
+ apply(simp add: steps.simps)
+ done
+ qed
+ thus "?thesis"
+ apply(auto)
+ done
+qed
+
+lemma [intro]: "t_correct t_wcode_adjust"
+apply(auto simp: t_wcode_adjust_def t_correct.simps iseven_def)
+apply(rule_tac x = 11 in exI, simp)
+done
+
+lemma wcode_lemma_pre':
+ "args \<noteq> [] \<Longrightarrow>
+ \<exists> stp rn. steps (Suc 0, [], <m # args>)
+ ((t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust) stp
+ = (0, [Bk], Oc\<^bsup>Suc m\<^esup> @ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+proof -
+ let ?P1 = "\<lambda> (l, r). l = [] \<and> r = <m # args>"
+ let ?Q1 = "\<lambda>(l, r). l = Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ (\<exists>ln rn. r = Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<args>)\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ 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> []"
+ have "?P1 \<turnstile>-> \<lambda> tp. (\<exists> stp tp'. steps (Suc 0, tp)
+ ((t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust) stp = (0, tp') \<and> ?Q2 tp')"
+ proof(rule_tac turing_merge.t_merge_halt[of "t_wcode_prepare |+| t_wcode_main"
+ t_wcode_adjust ?P1 ?P2 ?P3 ?P3 ?Q1 ?Q2],
+ auto simp: turing_merge_def)
+
+ show "\<exists>stp. case steps (Suc 0, [], <m # args>) (t_wcode_prepare |+| t_wcode_main) stp of
+ (st, tp') \<Rightarrow> st = 0 \<and> (case tp' of (l, r) \<Rightarrow> l = Bk # Oc\<^bsup>Suc m\<^esup> \<and>
+ (\<exists>ln rn. r = Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk # Oc\<^bsup>bl_bin (<args>)\<^esup> @ Bk\<^bsup>rn\<^esup>))"
+ using h prepare_mainpart_lemma[of args m]
+ apply(auto)
+ apply(rule_tac x = stp in exI, simp)
+ apply(rule_tac x = ln in exI, auto)
+ done
+ next
+ fix ln rn
+ show "\<exists>stp. case steps (Suc 0, Bk # Oc\<^bsup>Suc m\<^esup>, Bk # Oc # Bk\<^bsup>ln\<^esup> @ Bk # Bk #
+ Oc\<^bsup>bl_bin (<args>)\<^esup> @ Bk\<^bsup>rn\<^esup>) t_wcode_adjust stp of
+ (st, tp') \<Rightarrow> st = 0 \<and> wadjust_stop m (bl_bin (<args>) - Suc 0) tp'"
+ using wadjust_correctness[of m "bl_bin (<args>) - 1" "Suc ln" rn]
+ apply(subgoal_tac "bl_bin (<args>) > 0", auto simp: wadjust_inv.simps)
+ apply(rule_tac x = n in exI, simp add: exp_ind)
+ using h
+ apply(case_tac args, simp_all, case_tac list,
+ simp_all add: tape_of_nl_abv tape_of_nat_list.simps exp_ind_def
+ bl_bin.simps)
+ done
+ next
+ show "?Q1 \<turnstile>-> ?P2"
+ by(simp add: t_imply_def)
+ qed
+ thus "\<exists>stp rn. steps (Suc 0, [], <m # args>) ((t_wcode_prepare |+| t_wcode_main) |+|
+ t_wcode_adjust) stp = (0, [Bk], Oc\<^bsup>Suc m\<^esup> @ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ apply(simp add: t_imply_def)
+ apply(erule_tac exE)+
+ apply(subgoal_tac "bl_bin (<args>) > 0", auto simp: wadjust_stop.simps)
+ using h
+ apply(case_tac args, simp_all, case_tac list,
+ simp_all add: tape_of_nl_abv tape_of_nat_list.simps exp_ind_def
+ bl_bin.simps)
+ done
+qed
+
+text {*
+ The initialization TM @{text "t_wcode"}.
+ *}
+definition t_wcode :: "tprog"
+ where
+ "t_wcode = (t_wcode_prepare |+| t_wcode_main) |+| t_wcode_adjust"
+
+
+text {*
+ The correctness of @{text "t_wcode"}.
+ *}
+lemma wcode_lemma_1:
+ "args \<noteq> [] \<Longrightarrow>
+ \<exists> stp ln rn. steps (Suc 0, [], <m # args>) (t_wcode) stp =
+ (0, [Bk], Oc\<^bsup>Suc m\<^esup> @ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+apply(simp add: wcode_lemma_pre' t_wcode_def)
+done
+
+lemma wcode_lemma:
+ "args \<noteq> [] \<Longrightarrow>
+ \<exists> stp ln rn. steps (Suc 0, [], <m # args>) (t_wcode) stp =
+ (0, [Bk], <[m ,bl_bin (<args>)]> @ Bk\<^bsup>rn\<^esup>)"
+using wcode_lemma_1[of args m]
+apply(simp add: t_wcode_def tape_of_nl_abv tape_of_nat_list.simps)
+done
+
+section {* The universal TM @{text "UTM"} *}
+
+text {*
+ This section gives the explicit construction of {\em Universal Turing Machine}, defined as @{text "UTM"} and proves its
+ correctness. It is pretty easy by composing the partial results we have got so far.
+ *}
+
+
+definition UTM :: "tprog"
+ where
+ "UTM = (let (aprog, rs_pos, a_md) = rec_ci rec_F in
+ let abc_F = aprog [+] dummy_abc (Suc (Suc 0)) in
+ (t_wcode |+| (tm_of abc_F @ tMp (Suc (Suc 0)) (start_of (layout_of abc_F)
+ (length abc_F) - Suc 0))))"
+
+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 :: "tprog"
+ where
+ "F_tprog = tm_of (F_aprog)"
+
+definition t_utm :: "tprog"
+ where
+ "t_utm \<equiv>
+ (F_tprog) @ tMp (Suc (Suc 0)) (start_of (layout_of (F_aprog))
+ (length (F_aprog)) - Suc 0)"
+
+definition UTM_pre :: "tprog"
+ where
+ "UTM_pre = t_wcode |+| t_utm"
+
+lemma F_abc_halt_eq:
+ "\<lbrakk>turing_basic.t_correct tp;
+ length lm = k;
+ steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup>@Bk\<^bsup>n\<^esup>);
+ rs > 0\<rbrakk>
+ \<Longrightarrow> \<exists> stp m. abc_steps_l (0, [code tp, bl2wc (<lm>)]) (F_aprog) stp =
+ (length (F_aprog), code tp # bl2wc (<lm>) # (rs - 1) # 0\<^bsup>m\<^esup>)"
+apply(drule_tac F_t_halt_eq, simp, simp, simp)
+apply(case_tac "rec_ci rec_F")
+apply(frule_tac abc_append_dummy_complie, simp, simp, erule_tac exE,
+ erule_tac exE)
+apply(rule_tac x = stp in exI, rule_tac x = m in exI)
+apply(simp add: F_aprog_def dummy_abc_def)
+done
+
+lemma F_abc_utm_halt_eq:
+ "\<lbrakk>rs > 0;
+ abc_steps_l (0, [code tp, bl2wc (<lm>)]) F_aprog stp =
+ (length F_aprog, code tp # bl2wc (<lm>) # (rs - 1) # 0\<^bsup>m\<^esup>)\<rbrakk>
+ \<Longrightarrow> \<exists>stp m n.(steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm stp =
+ (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>))"
+ thm abacus_turing_eq_halt
+ using abacus_turing_eq_halt
+ [of "layout_of F_aprog" "F_aprog" "F_tprog" "length (F_aprog)"
+ "[code tp, bl2wc (<lm>)]" stp "code tp # bl2wc (<lm>) # (rs - 1) # 0\<^bsup>m\<^esup>" "Suc (Suc 0)"
+ "start_of (layout_of (F_aprog)) (length (F_aprog))" "[]" 0]
+apply(simp add: F_tprog_def t_utm_def abc_lm_v.simps nth_append)
+apply(erule_tac exE)+
+apply(rule_tac x = stpa in exI, rule_tac x = "Suc (Suc ma)" in exI,
+ rule_tac x = l in exI, simp add: exp_ind)
+done
+
+declare tape_of_nl_abv_cons[simp del]
+
+lemma t_utm_halt_eq':
+ "\<lbrakk>turing_basic.t_correct tp;
+ 0 < rs;
+ steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm::nat list>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup>@Bk\<^bsup>n\<^esup>)\<rbrakk>
+ \<Longrightarrow> \<exists>stp m n. steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm stp =
+ (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+apply(drule_tac l = l in F_abc_halt_eq, simp, simp, simp)
+apply(erule_tac exE, erule_tac exE)
+apply(rule_tac F_abc_utm_halt_eq, simp_all)
+done
+
+lemma [simp]: "tinres xs (xs @ Bk\<^bsup>i\<^esup>)"
+apply(auto simp: tinres_def)
+done
+
+lemma [elim]: "\<lbrakk>rs > 0; Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>na\<^esup> = c @ Bk\<^bsup>n\<^esup>\<rbrakk>
+ \<Longrightarrow> \<exists>n. c = Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>"
+apply(case_tac "na > n")
+apply(subgoal_tac "\<exists> d. na = d + n", auto simp: exp_add)
+apply(rule_tac x = "na - n" in exI, simp)
+apply(subgoal_tac "\<exists> d. n = d + na", auto simp: exp_add)
+apply(case_tac rs, simp_all add: exp_ind, case_tac d,
+ simp_all add: exp_ind)
+apply(rule_tac x = "n - na" in exI, simp)
+done
+
+
+lemma t_utm_halt_eq'':
+ "\<lbrakk>turing_basic.t_correct tp;
+ 0 < rs;
+ steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm::nat list>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup>@Bk\<^bsup>n\<^esup>)\<rbrakk>
+ \<Longrightarrow> \<exists>stp m n. steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>) t_utm stp =
+ (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+apply(drule_tac t_utm_halt_eq', simp_all)
+apply(erule_tac exE)+
+proof -
+ fix stpa ma na
+ assume "steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm stpa = (0, Bk\<^bsup>ma\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>na\<^esup>)"
+ and gr: "rs > 0"
+ thus "\<exists>stp m n. steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>) t_utm stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+ apply(rule_tac x = stpa in exI, rule_tac x = ma in exI, simp)
+ proof(case_tac "steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>) t_utm stpa", simp)
+ fix a b c
+ assume "steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm stpa = (0, Bk\<^bsup>ma\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>na\<^esup>)"
+ "steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>) t_utm stpa = (a, b, c)"
+ thus " a = 0 \<and> b = Bk\<^bsup>ma\<^esup> \<and> (\<exists>n. c = Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+ using tinres_steps2[of "<[code tp, bl2wc (<lm>)]>" "<[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>"
+ "Suc 0" " [Bk, Bk]" t_utm stpa 0 "Bk\<^bsup>ma\<^esup>" "Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>na\<^esup>" a b c]
+ apply(simp)
+ using gr
+ apply(simp only: tinres_def, auto)
+ apply(rule_tac x = "na + n" in exI, simp add: exp_add)
+ done
+ qed
+qed
+
+lemma [simp]: "tinres [Bk, Bk] [Bk]"
+apply(auto simp: tinres_def)
+done
+
+lemma [elim]: "Bk\<^bsup>ma\<^esup> = b @ Bk\<^bsup>n\<^esup> \<Longrightarrow> \<exists>m. b = Bk\<^bsup>m\<^esup>"
+apply(subgoal_tac "ma = length b + n")
+apply(rule_tac x = "ma - n" in exI, simp add: exp_add)
+apply(drule_tac length_equal)
+apply(simp)
+done
+
+lemma t_utm_halt_eq:
+ "\<lbrakk>turing_basic.t_correct tp;
+ 0 < rs;
+ steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm::nat list>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup>@Bk\<^bsup>n\<^esup>)\<rbrakk>
+ \<Longrightarrow> \<exists>stp m n. steps (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>) t_utm stp =
+ (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+apply(drule_tac i = i in t_utm_halt_eq'', simp_all)
+apply(erule_tac exE)+
+proof -
+ fix stpa ma na
+ assume "steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>) t_utm stpa = (0, Bk\<^bsup>ma\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>na\<^esup>)"
+ and gr: "rs > 0"
+ thus "\<exists>stp m n. steps (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>) t_utm stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+ apply(rule_tac x = stpa in exI)
+ proof(case_tac "steps (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>) t_utm stpa", simp)
+ fix a b c
+ assume "steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>) t_utm stpa = (0, Bk\<^bsup>ma\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>na\<^esup>)"
+ "steps (Suc 0, [Bk], <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>) t_utm stpa = (a, b, c)"
+ thus "a = 0 \<and> (\<exists>m. b = Bk\<^bsup>m\<^esup>) \<and> (\<exists>n. c = Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+ using tinres_steps[of "[Bk, Bk]" "[Bk]" "Suc 0" "<[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>i\<^esup>" t_utm stpa 0
+ "Bk\<^bsup>ma\<^esup>" "Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>na\<^esup>" a b c]
+ apply(simp)
+ apply(auto simp: tinres_def)
+ apply(rule_tac x = "ma + n" in exI, simp add: exp_add)
+ done
+ qed
+qed
+
+lemma [intro]: "t_correct t_wcode"
+apply(simp add: t_wcode_def)
+apply(auto)
+done
+
+lemma [intro]: "t_correct t_utm"
+apply(simp add: t_utm_def F_tprog_def)
+apply(rule_tac t_compiled_correct, auto)
+done
+
+lemma UTM_halt_lemma_pre:
+ "\<lbrakk>turing_basic.t_correct tp;
+ 0 < rs;
+ args \<noteq> [];
+ steps (Suc 0, Bk\<^bsup>i\<^esup>, <args::nat list>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup>@Bk\<^bsup>k\<^esup>)\<rbrakk>
+ \<Longrightarrow> \<exists>stp m n. steps (Suc 0, [], <code tp # args>) UTM_pre stp =
+ (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+proof -
+ let ?Q2 = "\<lambda> (l, r). (\<exists> ln rn. l = Bk\<^bsup>ln\<^esup> \<and> r = Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>rn\<^esup>)"
+ term ?Q2
+ let ?P1 = "\<lambda> (l, r). l = [] \<and> r = <code tp # args>"
+ let ?Q1 = "\<lambda> (l, r). (l = [Bk] \<and>
+ (\<exists> rn. r = Oc\<^bsup>Suc (code tp)\<^esup> @ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>))"
+ let ?P2 = ?Q1
+ let ?P3 = "\<lambda> (l, r). False"
+ assume h: "turing_basic.t_correct tp" "0 < rs"
+ "args \<noteq> []" "steps (Suc 0, Bk\<^bsup>i\<^esup>, <args::nat list>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup>@Bk\<^bsup>k\<^esup>)"
+ have "?P1 \<turnstile>-> \<lambda> tp. (\<exists> stp tp'. steps (Suc 0, tp)
+ (t_wcode |+| t_utm) stp = (0, tp') \<and> ?Q2 tp')"
+ proof(rule_tac turing_merge.t_merge_halt [of "t_wcode" "t_utm"
+ ?P1 ?P2 ?P3 ?P3 ?Q1 ?Q2], auto simp: turing_merge_def)
+ show "\<exists>stp. case steps (Suc 0, [], <code tp # args>) t_wcode stp of (st, tp') \<Rightarrow>
+ st = 0 \<and> (case tp' of (l, r) \<Rightarrow> l = [Bk] \<and>
+ (\<exists>rn. r = Oc\<^bsup>Suc (code tp)\<^esup> @ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>))"
+ using wcode_lemma_1[of args "code tp"] h
+ apply(simp, auto)
+ apply(rule_tac x = stpa in exI, auto)
+ done
+ next
+ fix rn
+ show "\<exists>stp. case steps (Suc 0, [Bk], Oc\<^bsup>Suc (code tp)\<^esup> @
+ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>) t_utm stp of
+ (st, tp') \<Rightarrow> st = 0 \<and> (case tp' of (l, r) \<Rightarrow>
+ (\<exists>ln. l = Bk\<^bsup>ln\<^esup>) \<and> (\<exists>rn. r = Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>rn\<^esup>))"
+ using t_utm_halt_eq[of tp rs i args stp m k rn] h
+ apply(auto)
+ apply(rule_tac x = stpa in exI, simp add: bin_wc_eq
+ tape_of_nat_list.simps tape_of_nl_abv)
+ apply(auto)
+ done
+ next
+ show "?Q1 \<turnstile>-> ?P2"
+ apply(simp add: t_imply_def)
+ done
+ qed
+ thus "?thesis"
+ apply(simp add: t_imply_def)
+ apply(auto simp: UTM_pre_def)
+ done
+qed
+
+text {*
+ The correctness of @{text "UTM"}, the halt case.
+*}
+theorem UTM_halt_lemma:
+ "\<lbrakk>turing_basic.t_correct tp;
+ 0 < rs;
+ args \<noteq> [];
+ steps (Suc 0, Bk\<^bsup>i\<^esup>, <args::nat list>) tp stp = (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup>@Bk\<^bsup>k\<^esup>)\<rbrakk>
+ \<Longrightarrow> \<exists>stp m n. steps (Suc 0, [], <code tp # args>) UTM stp =
+ (0, Bk\<^bsup>m\<^esup>, Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>)"
+using UTM_halt_lemma_pre[of tp rs args i stp m k]
+apply(simp add: UTM_pre_def t_utm_def UTM_def F_aprog_def F_tprog_def)
+apply(case_tac "rec_ci rec_F", simp)
+done
+
+definition TSTD:: "t_conf \<Rightarrow> bool"
+ where
+ "TSTD c = (let (st, l, r) = c in
+ st = 0 \<and> (\<exists> m. l = Bk\<^bsup>m\<^esup>) \<and> (\<exists> rs n. r = Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>))"
+
+thm abacus_turing_eq_uhalt
+
+lemma nstd_case1: "0 < a \<Longrightarrow> NSTD (trpl_code (a, b, c))"
+apply(simp add: NSTD.simps trpl_code.simps)
+done
+
+lemma [simp]: "\<forall>m. b \<noteq> Bk\<^bsup>m\<^esup> \<Longrightarrow> 0 < bl2wc b"
+apply(rule classical, simp)
+apply(induct b, erule_tac x = 0 in allE, simp)
+apply(simp add: bl2wc.simps, case_tac a, simp_all
+ add: bl2nat.simps bl2nat_double)
+apply(case_tac "\<exists> m. b = Bk\<^bsup>m\<^esup>", erule exE)
+apply(erule_tac x = "Suc m" in allE, simp add: exp_ind_def, simp)
+done
+lemma nstd_case2: "\<forall>m. b \<noteq> Bk\<^bsup>m\<^esup> \<Longrightarrow> NSTD (trpl_code (a, b, c))"
+apply(simp add: NSTD.simps trpl_code.simps)
+done
+
+thm lg.simps
+thm lgR.simps
+
+lemma [elim]: "Suc (2 * x) = 2 * y \<Longrightarrow> RR"
+apply(induct x arbitrary: y, simp, simp)
+apply(case_tac y, simp, simp)
+done
+
+lemma bl2nat_zero_eq[simp]: "(bl2nat c 0 = 0) = (\<exists>n. c = Bk\<^bsup>n\<^esup>)"
+apply(auto)
+apply(induct c, simp add: bl2nat.simps)
+apply(rule_tac x = 0 in exI, simp)
+apply(case_tac a, auto simp: bl2nat.simps bl2nat_double)
+done
+
+lemma bl2wc_exp_ex:
+ "\<lbrakk>Suc (bl2wc c) = 2 ^ m\<rbrakk> \<Longrightarrow> \<exists> rs n. c = Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>"
+apply(induct c arbitrary: m, simp add: bl2wc.simps bl2nat.simps)
+apply(case_tac a, auto)
+apply(case_tac m, simp_all add: bl2wc.simps, auto)
+apply(rule_tac x = 0 in exI, rule_tac x = "Suc n" in exI,
+ simp add: exp_ind_def)
+apply(simp add: bl2wc.simps bl2nat.simps bl2nat_double)
+apply(case_tac m, simp, simp)
+proof -
+ fix c m nat
+ assume ind:
+ "\<And>m. Suc (bl2nat c 0) = 2 ^ m \<Longrightarrow> \<exists>rs n. c = Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>"
+ and h:
+ "Suc (Suc (2 * bl2nat c 0)) = 2 * 2 ^ nat"
+ have "\<exists>rs n. c = Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>"
+ apply(rule_tac m = nat in ind)
+ using h
+ apply(simp)
+ done
+ from this obtain rs n where " c = Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>" by blast
+ thus "\<exists>rs n. Oc # c = Oc\<^bsup>rs\<^esup> @ Bk\<^bsup>n\<^esup>"
+ apply(rule_tac x = "Suc rs" in exI, simp add: exp_ind_def)
+ apply(rule_tac x = n in exI, simp)
+ done
+qed
+
+lemma [elim]:
+ "\<lbrakk>\<forall>rs n. c \<noteq> Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup>;
+ bl2wc c = 2 ^ lg (Suc (bl2wc c)) 2 - Suc 0\<rbrakk> \<Longrightarrow> bl2wc c = 0"
+apply(subgoal_tac "\<exists> m. Suc (bl2wc c) = 2^m", erule_tac exE)
+apply(drule_tac bl2wc_exp_ex, simp, erule_tac exE, erule_tac exE)
+apply(case_tac rs, simp, simp, erule_tac x = nat in allE,
+ erule_tac x = n in allE, simp)
+using bl2wc_exp_ex[of c "lg (Suc (bl2wc c)) 2"]
+apply(case_tac "(2::nat) ^ lg (Suc (bl2wc c)) 2",
+ simp, simp, erule_tac exE, erule_tac exE, simp)
+apply(simp add: bl2wc.simps)
+apply(rule_tac x = rs in exI)
+apply(case_tac "(2::nat)^rs", simp, simp)
+done
+
+lemma nstd_case3:
+ "\<forall>rs n. c \<noteq> Oc\<^bsup>Suc rs\<^esup> @ Bk\<^bsup>n\<^esup> \<Longrightarrow> NSTD (trpl_code (a, b, c))"
+apply(simp add: NSTD.simps trpl_code.simps)
+apply(rule_tac impI)
+apply(rule_tac disjI2, rule_tac disjI2, auto)
+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>turing_basic.t_correct tp;
+ steps (Suc 0, Bk\<^bsup>l\<^esup>, <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>turing_basic.t_correct tp;
+ \<forall> stp. (\<not> TSTD (steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp))\<rbrakk>
+ \<Longrightarrow> \<forall>y. rec_calc_rel rec_nonstop
+ ([code tp, bl2wc (<lm>), y]) (Suc 0)"
+apply(rule_tac allI, erule_tac x = y in allE)
+apply(case_tac "steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp y", simp)
+apply(rule_tac nonstop_t_uhalt_eq, simp_all)
+done
+
+(*
+lemma [simp]:
+ "\<forall>j<Suc k. Ex (rec_calc_rel (get_fstn_args (Suc k) (Suc k) ! j)
+ (code tp # lm))"
+apply(auto simp: get_fstn_args_nth)
+apply(rule_tac x = "(code tp # lm) ! j" in exI)
+apply(rule_tac calc_id, simp_all)
+done
+*)
+declare ci_cn_para_eq[simp]
+
+lemma F_aprog_uhalt:
+ "\<lbrakk>turing_basic.t_correct tp;
+ \<forall> stp. (\<not> TSTD (steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp));
+ rec_ci rec_F = (F_ap, rs_pos, a_md)\<rbrakk>
+ \<Longrightarrow> \<forall> stp. case abc_steps_l (0, [code tp, bl2wc (<lm>)] @ 0\<^bsup>a_md - rs_pos \<^esup>
+ @ suflm) (F_ap) stp of (ss, e) \<Rightarrow> ss < length (F_ap)"
+apply(case_tac "rec_ci (Cn (Suc (Suc 0)) rec_right [Cn (Suc (Suc 0)) rec_conf
+ ([id (Suc (Suc 0)) 0, id (Suc (Suc 0)) (Suc 0), rec_halt])])")
+apply(simp only: rec_F_def, rule_tac i = 0 and ga = a and gb = b and
+ gc = c in cn_gi_uhalt, simp, simp, simp, simp, simp, simp, simp)
+apply(simp add: ci_cn_para_eq)
+apply(case_tac "rec_ci (Cn (Suc (Suc 0)) rec_conf
+ ([id (Suc (Suc 0)) 0, id (Suc (Suc 0)) (Suc 0), rec_halt]))")
+apply(rule_tac rf = "(Cn (Suc (Suc 0)) rec_right [Cn (Suc (Suc 0)) rec_conf
+ ([id (Suc (Suc 0)) 0, id (Suc (Suc 0)) (Suc 0), rec_halt])])"
+ and n = "Suc (Suc 0)" and f = rec_right and
+ gs = "[Cn (Suc (Suc 0)) rec_conf
+ ([id (Suc (Suc 0)) 0, id (Suc (Suc 0)) (Suc 0), rec_halt])]"
+ and i = 0 and ga = aa and gb = ba and gc = ca in
+ cn_gi_uhalt)
+apply(simp, simp, simp, simp, simp, simp, simp,
+ simp add: ci_cn_para_eq)
+apply(case_tac "rec_ci rec_halt")
+apply(rule_tac rf = "(Cn (Suc (Suc 0)) rec_conf
+ ([id (Suc (Suc 0)) 0, id (Suc (Suc 0)) (Suc 0), rec_halt]))"
+ and n = "Suc (Suc 0)" and f = "rec_conf" and
+ gs = "([id (Suc (Suc 0)) 0, id (Suc (Suc 0)) (Suc 0), rec_halt])" and
+ i = "Suc (Suc 0)" and gi = "rec_halt" and ga = ab and gb = bb and
+ gc = cb in cn_gi_uhalt)
+apply(simp, simp, simp, simp, simp add: nth_append, simp,
+ simp add: nth_append, simp add: rec_halt_def)
+apply(simp only: rec_halt_def)
+apply(case_tac [!] "rec_ci ((rec_nonstop))")
+apply(rule_tac allI, rule_tac impI, simp)
+apply(case_tac j, simp)
+apply(rule_tac x = "code tp" in exI, rule_tac calc_id, simp, simp, simp, simp)
+apply(rule_tac x = "bl2wc (<lm>)" in exI, rule_tac calc_id, simp, simp, simp)
+apply(rule_tac rf = "Mn (Suc (Suc 0)) (rec_nonstop)"
+ and f = "(rec_nonstop)" and n = "Suc (Suc 0)"
+ and aprog' = ac and rs_pos' = bc and a_md' = cc in Mn_unhalt)
+apply(simp, simp add: rec_halt_def , simp, simp)
+apply(drule_tac nonstop_true, simp_all)
+apply(rule_tac allI)
+apply(erule_tac x = y in allE)+
+apply(simp)
+done
+
+thm abc_list_crsp_steps
+
+lemma uabc_uhalt':
+ "\<lbrakk>turing_basic.t_correct tp;
+ \<forall> stp. (\<not> TSTD (steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp));
+ rec_ci rec_F = (ap, pos, md)\<rbrakk>
+ \<Longrightarrow> \<forall> stp. case abc_steps_l (0, [code tp, bl2wc (<lm>)]) ap stp of (ss, e)
+ \<Rightarrow> ss < length ap"
+proof(frule_tac F_ap = ap and rs_pos = pos and a_md = md
+ and suflm = "[]" in F_aprog_uhalt, auto)
+ fix stp a b
+ assume h:
+ "\<forall>stp. case abc_steps_l (0, code tp # bl2wc (<lm>) # 0\<^bsup>md - pos\<^esup>) ap stp of
+ (ss, e) \<Rightarrow> ss < length ap"
+ "abc_steps_l (0, [code tp, bl2wc (<lm>)]) ap stp = (a, b)"
+ "turing_basic.t_correct tp"
+ "rec_ci rec_F = (ap, pos, md)"
+ moreover have "ap \<noteq> []"
+ using h apply(rule_tac rec_ci_not_null, simp)
+ done
+ ultimately show "a < length ap"
+ proof(erule_tac x = stp in allE,
+ case_tac "abc_steps_l (0, code tp # bl2wc (<lm>) # 0\<^bsup>md - pos\<^esup>) ap stp", simp)
+ fix aa ba
+ assume g: "aa < length ap"
+ "abc_steps_l (0, code tp # bl2wc (<lm>) # 0\<^bsup>md - pos\<^esup>) ap stp = (aa, ba)"
+ "ap \<noteq> []"
+ thus "?thesis"
+ using abc_list_crsp_steps[of "[code tp, bl2wc (<lm>)]"
+ "md - pos" ap stp aa ba] h
+ apply(simp)
+ done
+ qed
+qed
+
+lemma uabc_uhalt:
+ "\<lbrakk>turing_basic.t_correct tp;
+ \<forall> stp. (\<not> TSTD (steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp))\<rbrakk>
+ \<Longrightarrow> \<forall> stp. case abc_steps_l (0, [code tp, bl2wc (<lm>)]) F_aprog
+ stp of (ss, e) \<Rightarrow> ss < length F_aprog"
+apply(case_tac "rec_ci rec_F", simp add: F_aprog_def)
+thm uabc_uhalt'
+apply(drule_tac ap = a and pos = b and md = c in uabc_uhalt', simp_all)
+proof -
+ fix a b c
+ assume
+ "\<forall>stp. case abc_steps_l (0, [code tp, bl2wc (<lm>)]) a stp of (ss, e)
+ \<Rightarrow> ss < length a"
+ "rec_ci rec_F = (a, b, c)"
+ thus
+ "\<forall>stp. case abc_steps_l (0, [code tp, bl2wc (<lm>)])
+ (a [+] dummy_abc (Suc (Suc 0))) stp of (ss, e) \<Rightarrow>
+ ss < Suc (Suc (Suc (length a)))"
+ using abc_append_uhalt1[of a "[code tp, bl2wc (<lm>)]"
+ "a [+] dummy_abc (Suc (Suc 0))" "[]" "dummy_abc (Suc (Suc 0))"]
+ apply(simp)
+ done
+qed
+
+thm abacus_turing_eq_uhalt
+lemma tutm_uhalt':
+ "\<lbrakk>turing_basic.t_correct tp;
+ \<forall> stp. (\<not> TSTD (steps (Suc 0, Bk\<^bsup>l\<^esup>, <lm>) tp stp))\<rbrakk>
+ \<Longrightarrow> \<forall> stp. \<not> isS0 (steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm stp)"
+ using abacus_turing_eq_uhalt[of "layout_of (F_aprog)"
+ "F_aprog" "F_tprog" "[code tp, bl2wc (<lm>)]"
+ "start_of (layout_of (F_aprog )) (length (F_aprog))"
+ "Suc (Suc 0)"]
+apply(simp add: F_tprog_def)
+apply(subgoal_tac "\<forall>stp. case abc_steps_l (0, [code tp, bl2wc (<lm>)])
+ (F_aprog) stp of (as, am) \<Rightarrow> as < length (F_aprog)", simp)
+thm abacus_turing_eq_uhalt
+apply(simp add: t_utm_def F_tprog_def)
+apply(rule_tac uabc_uhalt, simp_all)
+done
+
+lemma tinres_commute: "tinres r r' \<Longrightarrow> tinres r' r"
+apply(auto simp: tinres_def)
+done
+
+lemma inres_tape:
+ "\<lbrakk>steps (st, l, r) tp stp = (a, b, c); steps (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 "steps (st, l', r) tp stp")
+ fix aa ba ca
+ assume h: "steps (st, l, r) tp stp = (a, b, c)"
+ "steps (st, l', r') tp stp = (a', b', c')"
+ "tinres l l'" "tinres r r'"
+ "steps (st, l', r) tp stp = (aa, ba, ca)"
+ have "tinres b ba \<and> c = ca \<and> a = aa"
+ using h
+ apply(rule_tac tinres_steps, auto)
+ done
+
+ thm tinres_steps2
+ 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: "\<forall> stp. \<not> isS0 (steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm stp)
+ \<Longrightarrow> \<forall> stp. \<not> isS0 (steps (Suc 0, Bk\<^bsup>m\<^esup>, <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>n\<^esup>) t_utm stp)"
+apply(rule_tac allI, case_tac "(steps (Suc 0, Bk\<^bsup>m\<^esup>,
+ <[code tp, bl2wc (<lm>)]> @ Bk\<^bsup>n\<^esup>) t_utm stp)", simp add: isS0_def)
+apply(erule_tac x = stp in allE)
+apply(case_tac "steps (Suc 0, [Bk, Bk], <[code tp, bl2wc (<lm>)]>) t_utm 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 add: exp_ind_def, case_tac nat, simp_all add: exp_ind_def)
+apply(rule_tac x = "2 - m" in exI, simp add: exp_ind_def[THEN sym] exp_add[THEN sym])
+apply(simp only: numeral_2_eq_2, simp add: exp_ind_def)
+done
+
+lemma tutm_uhalt:
+ "\<lbrakk>turing_basic.t_correct tp;
+ \<forall> stp. (\<not> TSTD (steps (Suc 0, Bk\<^bsup>l\<^esup>, <args>) tp stp))\<rbrakk>
+ \<Longrightarrow> \<forall> stp. \<not> isS0 (steps (Suc 0, Bk\<^bsup>m\<^esup>, <[code tp, bl2wc (<args>)]> @ Bk\<^bsup>n\<^esup>) t_utm stp)"
+apply(rule_tac tape_normalize)
+apply(rule_tac tutm_uhalt', simp_all)
+done
+
+lemma UTM_uhalt_lemma_pre:
+ "\<lbrakk>turing_basic.t_correct tp;
+ \<forall> stp. (\<not> TSTD (steps (Suc 0, Bk\<^bsup>l\<^esup>, <args>) tp stp));
+ args \<noteq> []\<rbrakk>
+ \<Longrightarrow> \<forall> stp. \<not> isS0 (steps (Suc 0, [], <code tp # args>) UTM_pre 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\<^bsup>Suc (code tp)\<^esup> @ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>))"
+ let ?P4 = ?Q1
+ let ?P3 = "\<lambda> (l, r). False"
+ assume h: "turing_basic.t_correct tp" "\<forall>stp. \<not> TSTD (steps (Suc 0, Bk\<^bsup>l\<^esup>, <args>) tp stp)"
+ "args \<noteq> []"
+ have "?P1 \<turnstile>-> \<lambda> tp. \<not> (\<exists> stp. isS0 (steps (Suc 0, tp) (t_wcode |+| t_utm) stp))"
+ proof(rule_tac turing_merge.t_merge_uhalt [of "t_wcode" "t_utm"
+ ?P1 ?P3 ?P3 ?P4 ?Q1 ?P3], auto simp: turing_merge_def)
+ show "\<exists>stp. case steps (Suc 0, [], <code tp # args>) t_wcode stp of (st, tp') \<Rightarrow>
+ st = 0 \<and> (case tp' of (l, r) \<Rightarrow> l = [Bk] \<and>
+ (\<exists>rn. r = Oc\<^bsup>Suc (code tp)\<^esup> @ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>))"
+ using wcode_lemma_1[of args "code tp"] h
+ apply(simp, auto)
+ apply(rule_tac x = stp in exI, auto)
+ done
+ next
+ fix rn stp
+ show " isS0 (steps (Suc 0, [Bk], Oc\<^bsup>Suc (code tp)\<^esup> @ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>) t_utm stp)
+ \<Longrightarrow> False"
+ using tutm_uhalt[of tp l args "Suc 0" rn] h
+ apply(simp)
+ apply(erule_tac x = stp in allE)
+ apply(simp add: tape_of_nl_abv tape_of_nat_list.simps bin_wc_eq)
+ done
+ next
+ fix rn stp
+ show "isS0 (steps (Suc 0, [Bk], Oc\<^bsup>Suc (code tp)\<^esup> @ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>) t_utm stp) \<Longrightarrow>
+ isS0 (steps (Suc 0, [Bk], Oc\<^bsup>Suc (code tp)\<^esup> @ Bk # Oc\<^bsup>Suc (bl_bin (<args>))\<^esup> @ Bk\<^bsup>rn\<^esup>) t_utm stp)"
+ by simp
+ next
+ show "?Q1 \<turnstile>-> ?P4"
+ apply(simp add: t_imply_def)
+ done
+ qed
+ thus "?thesis"
+ apply(simp add: t_imply_def UTM_pre_def)
+ done
+qed
+
+text {*
+ The correctness of @{text "UTM"}, the unhalt case.
+ *}
+
+theorem UTM_uhalt_lemma:
+ "\<lbrakk>turing_basic.t_correct tp;
+ \<forall> stp. (\<not> TSTD (steps (Suc 0, Bk\<^bsup>l\<^esup>, <args>) tp stp));
+ args \<noteq> []\<rbrakk>
+ \<Longrightarrow> \<forall> stp. \<not> isS0 (steps (Suc 0, [], <code tp # args>) UTM stp)"
+using UTM_uhalt_lemma_pre[of tp l args]
+apply(simp add: UTM_pre_def t_utm_def UTM_def F_aprog_def F_tprog_def)
+apply(case_tac "rec_ci rec_F", simp)
+done
+
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/utm/abacus.thy Sat Sep 29 12:38:12 2012 +0000
@@ -0,0 +1,7005 @@
+header {*
+ {\em Abacus} (a kind of register machine)
+*}
+
+theory abacus
+imports Main turing_basic
+begin
+
+text {*
+ {\em Abacus} instructions:
+*}
+
+datatype abc_inst =
+ -- {* @{text "Inc n"} increments the memory cell (or register) with address @{text "n"} by one.
+ *}
+ Inc nat
+ -- {*
+ @{text "Dec n label"} decrements the memory cell with address @{text "n"} by one.
+ If cell @{text "n"} is already zero, no decrements happens and the executio jumps to
+ the instruction labeled by @{text "label"}.
+ *}
+ | Dec nat nat
+ -- {*
+ @{text "Goto label"} unconditionally jumps to the instruction labeled by @{text "label"}.
+ *}
+ | Goto nat
+
+
+text {*
+ Abacus programs are defined as lists of Abacus instructions.
+*}
+type_synonym abc_prog = "abc_inst list"
+
+section {*
+ Sample Abacus programs
+ *}
+
+text {*
+ Abacus for addition and clearance.
+*}
+fun plus_clear :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> abc_prog"
+ where
+ "plus_clear m n e = [Dec m e, Inc n, Goto 0]"
+
+text {*
+ Abacus for clearing memory untis.
+*}
+fun clear :: "nat \<Rightarrow> nat \<Rightarrow> abc_prog"
+ where
+ "clear n e = [Dec n e, Goto 0]"
+
+fun plus:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> abc_prog"
+ where
+ "plus m n p e = [Dec m 4, Inc n, Inc p,
+ Goto 0, Dec p e, Inc m, Goto 4]"
+
+fun mult :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> abc_prog"
+ where
+ "mult m1 m2 n p e = [Dec m1 e]@ plus m1 m2 p 1"
+
+fun expo :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> abc_prog"
+ where
+ "expo n m1 m2 p e = [Inc n, Dec m1 e] @ mult m2 n n p 2"
+
+
+text {*
+ The state of Abacus machine.
+ *}
+type_synonym abc_state = nat
+
+(* text {*
+ The memory of Abacus machine is defined as a function from address to contents.
+*}
+type_synonym abc_mem = "nat \<Rightarrow> nat" *)
+
+text {*
+ The memory of Abacus machine is defined as a list of contents, with
+ every units addressed by index into the list.
+ *}
+type_synonym abc_lm = "nat list"
+
+text {*
+ Fetching contents out of memory. Units not represented by list elements are considered
+ as having content @{text "0"}.
+*}
+fun abc_lm_v :: "abc_lm \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_lm_v lm n = (if (n < length lm) then (lm!n) else 0)"
+
+(*
+fun abc_l2m :: "abc_lm \<Rightarrow> abc_mem"
+ where
+ "abc_l2m lm = abc_lm_v lm"
+*)
+
+text {*
+ Set the content of memory unit @{text "n"} to value @{text "v"}.
+ @{text "am"} is the Abacus memory before setting.
+ If address @{text "n"} is outside to scope of @{text "am"}, @{text "am"}
+ is extended so that @{text "n"} becomes in scope.
+*}
+fun abc_lm_s :: "abc_lm \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> abc_lm"
+ where
+ "abc_lm_s am n v = (if (n < length am) then (am[n:=v]) else
+ am@ (replicate (n - length am) 0) @ [v])"
+
+
+text {*
+ The configuration of Abaucs machines consists of its current state and its
+ current memory:
+*}
+type_synonym abc_conf_l = "abc_state \<times> abc_lm"
+
+text {*
+ Fetch instruction out of Abacus program:
+*}
+
+fun abc_fetch :: "nat \<Rightarrow> abc_prog \<Rightarrow> abc_inst option"
+ where
+ "abc_fetch s p = (if (s < length p) then Some (p ! s)
+ else None)"
+
+text {*
+ Single step execution of Abacus machine. If no instruction is feteched,
+ configuration does not change.
+*}
+fun abc_step_l :: "abc_conf_l \<Rightarrow> abc_inst option \<Rightarrow> abc_conf_l"
+ where
+ "abc_step_l (s, lm) a = (case a of
+ None \<Rightarrow> (s, lm) |
+ Some (Inc n) \<Rightarrow> (let nv = abc_lm_v lm n in
+ (s + 1, abc_lm_s lm n (nv + 1))) |
+ Some (Dec n e) \<Rightarrow> (let nv = abc_lm_v lm n in
+ if (nv = 0) then (e, abc_lm_s lm n 0)
+ else (s + 1, abc_lm_s lm n (nv - 1))) |
+ Some (Goto n) \<Rightarrow> (n, lm)
+ )"
+
+text {*
+ Multi-step execution of Abacus machine.
+*}
+fun abc_steps_l :: "abc_conf_l \<Rightarrow> abc_prog \<Rightarrow> nat \<Rightarrow> abc_conf_l"
+ where
+ "abc_steps_l (s, lm) p 0 = (s, lm)" |
+ "abc_steps_l (s, lm) p (Suc n) = abc_steps_l (abc_step_l (s, lm) (abc_fetch s p)) p n"
+
+section {*
+ Compiling Abacus machines into Truing machines
+*}
+
+
+subsection {*
+ Compiling functions
+*}
+
+text {*
+ @{text "findnth n"} returns the TM which locates the represention of
+ memory cell @{text "n"} on the tape and changes representation of zero
+ on the way.
+*}
+
+fun findnth :: "nat \<Rightarrow> tprog"
+ where
+ "findnth 0 = []" |
+ "findnth (Suc n) = (findnth n @ [(W1, 2 * n + 1),
+ (R, 2 * n + 2), (R, 2 * n + 3), (R, 2 * n + 2)])"
+
+text {*
+ @{text "tinc_b"} returns the TM which increments the representation
+ of the memory cell under rw-head by one and move the representation
+ of cells afterwards to the right accordingly.
+ *}
+
+definition tinc_b :: "tprog"
+ where
+ "tinc_b \<equiv> [(W1, 1), (R, 2), (W1, 3), (R, 2), (W1, 3), (R, 4),
+ (L, 7), (W0, 5), (R, 6), (W0, 5), (W1, 3), (R, 6),
+ (L, 8), (L, 7), (R, 9), (L, 7), (R, 10), (W0, 9)]"
+
+text {*
+ @{text "tshift tm off"} shifts @{text "tm"} by offset @{text "off"}, leaving
+ instructions concerning state @{text "0"} unchanged, because state @{text "0"}
+ is the end state, which needs not be changed with shift operation.
+ *}
+
+fun tshift :: "tprog \<Rightarrow> nat \<Rightarrow> tprog"
+ where
+ "tshift tp off = (map (\<lambda> (action, state).
+ (action, (if state = 0 then 0
+ else state + off))) tp)"
+
+text {*
+ @{text "tinc ss n"} returns the TM which simulates the execution of
+ Abacus instruction @{text "Inc n"}, assuming that TM is located at
+ location @{text "ss"} in the final TM complied from the whole
+ Abacus program.
+*}
+
+fun tinc :: "nat \<Rightarrow> nat \<Rightarrow> tprog"
+ where
+ "tinc ss n = tshift (findnth n @ tshift tinc_b (2 * n)) (ss - 1)"
+
+text {*
+ @{text "tinc_b"} returns the TM which decrements the representation
+ of the memory cell under rw-head by one and move the representation
+ of cells afterwards to the left accordingly.
+ *}
+
+definition tdec_b :: "tprog"
+ where
+ "tdec_b \<equiv> [(W1, 1), (R, 2), (L, 14), (R, 3), (L, 4), (R, 3),
+ (R, 5), (W0, 4), (R, 6), (W0, 5), (L, 7), (L, 8),
+ (L, 11), (W0, 7), (W1, 8), (R, 9), (L, 10), (R, 9),
+ (R, 5), (W0, 10), (L, 12), (L, 11), (R, 13), (L, 11),
+ (R, 17), (W0, 13), (L, 15), (L, 14), (R, 16), (L, 14),
+ (R, 0), (W0, 16)]"
+
+text {*
+ @{text "sete tp e"} attaches the termination edges (edges leading to state @{text "0"})
+ of TM @{text "tp"} to the intruction labelled by @{text "e"}.
+ *}
+
+fun sete :: "tprog \<Rightarrow> nat \<Rightarrow> tprog"
+ where
+ "sete tp e = map (\<lambda> (action, state). (action, if state = 0 then e else state)) tp"
+
+text {*
+ @{text "tdec ss n label"} returns the TM which simulates the execution of
+ Abacus instruction @{text "Dec n label"}, assuming that TM is located at
+ location @{text "ss"} in the final TM complied from the whole
+ Abacus program.
+*}
+
+fun tdec :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> tprog"
+ where
+ "tdec ss n e = sete (tshift (findnth n @ tshift tdec_b (2 * n))
+ (ss - 1)) e"
+
+text {*
+ @{text "tgoto f(label)"} returns the TM simulating the execution of Abacus instruction
+ @{text "Goto label"}, where @{text "f(label)"} is the corresponding location of
+ @{text "label"} in the final TM compiled from the overall Abacus program.
+*}
+
+fun tgoto :: "nat \<Rightarrow> tprog"
+ where
+ "tgoto n = [(Nop, n), (Nop, n)]"
+
+text {*
+ The layout of the final TM compiled from an Abacus program is represented
+ as a list of natural numbers, where the list element at index @{text "n"} represents the
+ starting state of the TM simulating the execution of @{text "n"}-th instruction
+ in the Abacus program.
+*}
+
+type_synonym layout = "nat list"
+
+text {*
+ @{text "length_of i"} is the length of the
+ TM simulating the Abacus instruction @{text "i"}.
+*}
+fun length_of :: "abc_inst \<Rightarrow> nat"
+ where
+ "length_of i = (case i of
+ Inc n \<Rightarrow> 2 * n + 9 |
+ Dec n e \<Rightarrow> 2 * n + 16 |
+ Goto n \<Rightarrow> 1)"
+
+text {*
+ @{text "layout_of ap"} returns the layout of Abacus program @{text "ap"}.
+*}
+fun layout_of :: "abc_prog \<Rightarrow> layout"
+ where "layout_of ap = map length_of ap"
+
+
+text {*
+ @{text "start_of layout n"} looks out the starting state of @{text "n"}-th
+ TM in the finall TM.
+*}
+
+fun start_of :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "start_of ly 0 = Suc 0" |
+ "start_of ly (Suc as) =
+ (if as < length ly then start_of ly as + (ly ! as)
+ else start_of ly as)"
+
+text {*
+ @{text "ci lo ss i"} complies Abacus instruction @{text "i"}
+ assuming the TM of @{text "i"} starts from state @{text "ss"}
+ within the overal layout @{text "lo"}.
+*}
+
+fun ci :: "layout \<Rightarrow> nat \<Rightarrow> abc_inst \<Rightarrow> tprog"
+ where
+ "ci ly ss i = (case i of
+ Inc n \<Rightarrow> tinc ss n |
+ Dec n e \<Rightarrow> tdec ss n (start_of ly e) |
+ Goto n \<Rightarrow> tgoto (start_of ly n))"
+
+text {*
+ @{text "tpairs_of ap"} transfroms Abacus program @{text "ap"} pairing
+ every instruction with its starting state.
+*}
+fun tpairs_of :: "abc_prog \<Rightarrow> (nat \<times> abc_inst) list"
+ where "tpairs_of ap = (zip (map (start_of (layout_of ap))
+ [0..<(length ap)]) ap)"
+
+
+text {*
+ @{text "tms_of ap"} returns the list of TMs, where every one of them simulates
+ the corresponding Abacus intruction in @{text "ap"}.
+*}
+
+fun tms_of :: "abc_prog \<Rightarrow> tprog list"
+ where "tms_of ap = map (\<lambda> (n, tm). ci (layout_of ap) n tm)
+ (tpairs_of ap)"
+
+text {*
+ @{text "tm_of ap"} returns the final TM machine compiled from Abacus program @{text "ap"}.
+*}
+fun tm_of :: "abc_prog \<Rightarrow> tprog"
+ where "tm_of ap = concat (tms_of ap)"
+
+text {*
+ The following two functions specify the well-formedness of complied TM.
+*}
+fun t_ncorrect :: "tprog \<Rightarrow> bool"
+ where
+ "t_ncorrect tp = (length tp mod 2 = 0)"
+
+fun abc2t_correct :: "abc_prog \<Rightarrow> bool"
+ where
+ "abc2t_correct ap = list_all (\<lambda> (n, tm).
+ t_ncorrect (ci (layout_of ap) n tm)) (tpairs_of ap)"
+
+lemma findnth_length: "length (findnth n) div 2 = 2 * n"
+apply(induct n, simp, simp)
+done
+
+lemma ci_length : "length (ci ns n ai) div 2 = length_of ai"
+apply(auto simp: ci.simps tinc_b_def tdec_b_def findnth_length
+ split: abc_inst.splits)
+done
+
+subsection {*
+ Representation of Abacus memory by TM tape
+*}
+
+consts tape_of :: "'a \<Rightarrow> block list" ("<_>" 100)
+
+text {*
+ @{text "tape_of_nat_list am"} returns the TM tape representing
+ Abacus memory @{text "am"}.
+ *}
+
+fun tape_of_nat_list :: "nat list \<Rightarrow> block list"
+ where
+ "tape_of_nat_list [] = []" |
+ "tape_of_nat_list [n] = Oc\<^bsup>n+1\<^esup>" |
+ "tape_of_nat_list (n#ns) = (Oc\<^bsup>n+1\<^esup>) @ [Bk] @ (tape_of_nat_list ns)"
+
+defs (overloaded)
+ tape_of_nl_abv: "<am> \<equiv> tape_of_nat_list am"
+ tape_of_nat_abv : "<(n::nat)> \<equiv> Oc\<^bsup>n+1\<^esup>"
+
+text {*
+ @{text "crsp_l acf tcf"} meams the abacus configuration @{text "acf"}
+ is corretly represented by the TM configuration @{text "tcf"}.
+*}
+
+fun crsp_l :: "layout \<Rightarrow> abc_conf_l \<Rightarrow> t_conf \<Rightarrow> block list \<Rightarrow> bool"
+ where
+ "crsp_l ly (as, lm) (ts, (l, r)) inres =
+ (ts = start_of ly as \<and> (\<exists> rn. r = <lm> @ Bk\<^bsup>rn\<^esup>)
+ \<and> l = Bk # Bk # inres)"
+
+declare crsp_l.simps[simp del]
+
+subsection {*
+ A more general definition of TM execution.
+*}
+
+(*
+fun nnth_of :: "(taction \<times> nat) list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (taction \<times> nat)"
+ where
+ "nnth_of p s b = (if 2*s < length p
+ then (p ! (2*s + b)) else (Nop, 0))"
+
+thm nth_of.simps
+
+fun nfetch :: "tprog \<Rightarrow> nat \<Rightarrow> block \<Rightarrow> taction \<times> nat"
+ where
+ "nfetch p 0 b = (Nop, 0)" |
+ "nfetch p (Suc s) b =
+ (case b of
+ Bk \<Rightarrow> nnth_of p s 0 |
+ Oc \<Rightarrow> nnth_of p s 1)"
+*)
+
+text {*
+ @{text "t_step tcf (tp, ss)"} returns the result of one step exection of TM @{text "tp"}
+ assuming @{text "tp"} starts from instial state @{text "ss"}.
+*}
+
+fun t_step :: "t_conf \<Rightarrow> (tprog \<times> nat) \<Rightarrow> t_conf"
+ where
+ "t_step c (p, off) =
+ (let (state, leftn, rightn) = c in
+ let (action, next_state) = fetch p (state-off)
+ (case rightn of
+ [] \<Rightarrow> Bk |
+ Bk # xs \<Rightarrow> Bk |
+ Oc # xs \<Rightarrow> Oc
+ )
+ in
+ (next_state, new_tape action (leftn, rightn)))"
+
+
+text {*
+ @{text "t_steps tcf (tp, ss) n"} returns the result of @{text "n"}-step exection
+ of TM @{text "tp"} assuming @{text "tp"} starts from instial state @{text "ss"}.
+*}
+
+fun t_steps :: "t_conf \<Rightarrow> (tprog \<times> nat) \<Rightarrow> nat \<Rightarrow> t_conf"
+ where
+ "t_steps c (p, off) 0 = c" |
+ "t_steps c (p, off) (Suc n) = t_steps
+ (t_step c (p, off)) (p, off) n"
+
+lemma stepn: "t_steps c (p, off) (Suc n) =
+ t_step (t_steps c (p, off) n) (p, off)"
+apply(induct n arbitrary: c, simp add: t_steps.simps)
+apply(simp add: t_steps.simps)
+done
+
+text {*
+ The type of invarints expressing correspondence between
+ Abacus configuration and TM configuration.
+*}
+
+type_synonym inc_inv_t = "abc_conf_l \<Rightarrow> t_conf \<Rightarrow> block list \<Rightarrow> bool"
+
+declare tms_of.simps[simp del] tm_of.simps[simp del]
+ layout_of.simps[simp del] abc_fetch.simps [simp del]
+ t_step.simps[simp del] t_steps.simps[simp del]
+ tpairs_of.simps[simp del] start_of.simps[simp del]
+ fetch.simps [simp del] t_ncorrect.simps[simp del]
+ new_tape.simps [simp del] ci.simps [simp del] length_of.simps[simp del]
+ layout_of.simps[simp del] crsp_l.simps[simp del]
+ abc2t_correct.simps[simp del]
+
+lemma tct_div2: "t_ncorrect tp \<Longrightarrow> (length tp) mod 2 = 0"
+apply(simp add: t_ncorrect.simps)
+done
+
+lemma t_shift_fetch:
+ "\<lbrakk>t_ncorrect tp1; t_ncorrect tp;
+ length tp1 div 2 < a \<and> a \<le> length tp1 div 2 + length tp div 2\<rbrakk>
+ \<Longrightarrow> fetch tp (a - length tp1 div 2) b =
+ fetch (tp1 @ tp @ tp2) a b"
+apply(subgoal_tac "\<exists> x. a = length tp1 div 2 + x", erule exE, simp)
+apply(case_tac x, simp)
+apply(subgoal_tac "length tp1 div 2 + Suc nat =
+ Suc (length tp1 div 2 + nat)")
+apply(simp only: fetch.simps nth_of.simps, auto)
+apply(case_tac b, simp)
+apply(subgoal_tac "2 * (length tp1 div 2) = length tp1", simp)
+apply(subgoal_tac "2 * nat < length tp", simp add: nth_append, simp)
+apply(simp add: t_ncorrect.simps, auto)
+apply(subgoal_tac "2 * (length tp1 div 2) = length tp1", simp)
+apply(subgoal_tac "2 * nat < length tp", simp add: nth_append, auto)
+apply(simp add: t_ncorrect.simps, auto)
+apply(rule_tac x = "a - length tp1 div 2" in exI, simp)
+done
+
+lemma t_shift_in_step:
+ "\<lbrakk>t_step (a, aa, ba) (tp, length tp1 div 2) = (s, l, r);
+ t_ncorrect tp1; t_ncorrect tp;
+ length tp1 div 2 < a \<and> a \<le> length tp1 div 2 + length tp div 2\<rbrakk>
+ \<Longrightarrow> t_step (a, aa, ba) (tp1 @ tp @ tp2, 0) = (s, l, r)"
+apply(simp add: t_step.simps)
+apply(subgoal_tac "fetch tp (a - length tp1 div 2) (case ba of [] \<Rightarrow>
+ Bk | x # xs \<Rightarrow> x)
+ = fetch (tp1 @ tp @ tp2) a (case ba of [] \<Rightarrow> Bk | x # xs
+ \<Rightarrow> x)")
+apply(case_tac "fetch tp (a - length tp1 div 2) (case ba of [] \<Rightarrow> Bk
+ | x # xs \<Rightarrow> x)")
+apply(auto intro: t_shift_fetch)
+apply(case_tac ba, simp, simp)
+apply(case_tac aaa, simp, simp)
+done
+
+declare add_Suc_right[simp del]
+lemma t_step_add: "t_steps c (p, off) (m + n) =
+ t_steps (t_steps c (p, off) m) (p, off) n"
+apply(induct m arbitrary: n, simp add: t_steps.simps, simp)
+apply(subgoal_tac "t_steps c (p, off) (Suc (m + n)) =
+ t_steps c (p, off) (m + Suc n)", simp)
+apply(subgoal_tac "t_steps (t_steps c (p, off) m) (p, off) (Suc n) =
+ t_steps (t_step (t_steps c (p, off) m) (p, off))
+ (p, off) n")
+apply(simp, simp add: stepn)
+apply(simp only: t_steps.simps)
+apply(simp only: add_Suc_right)
+done
+declare add_Suc_right[simp]
+
+lemma s_out_fetch: "\<lbrakk>t_ncorrect tp;
+ \<not> (length tp1 div 2 < a \<and> a \<le> length tp1 div 2 +
+ length tp div 2)\<rbrakk>
+ \<Longrightarrow> fetch tp (a - length tp1 div 2) b = (Nop, 0)"
+apply(auto)
+apply(simp add: fetch.simps)
+apply(subgoal_tac "\<exists> x. a - length tp1 div 2 = length tp div 2 + x")
+apply(erule exE, simp)
+apply(case_tac x, simp)
+apply(auto simp add: fetch.simps)
+apply(subgoal_tac "2 * (length tp div 2) = length tp")
+apply(auto simp: t_ncorrect.simps split: block.splits)
+apply(rule_tac x = "a - length tp1 div 2 - length tp div 2" in exI
+ , simp)
+done
+
+lemma conf_keep_step:
+ "\<lbrakk>t_ncorrect tp;
+ \<not> (length tp1 div 2 < a \<and> a \<le> length tp1 div 2 +
+ length tp div 2)\<rbrakk>
+ \<Longrightarrow> t_step (a, aa, ba) (tp, length tp1 div 2) = (0, aa, ba)"
+apply(simp add: t_step.simps)
+apply(subgoal_tac "fetch tp (a - length tp1 div 2) (case ba of [] \<Rightarrow>
+ Bk | Bk # xs \<Rightarrow> Bk | Oc # xs \<Rightarrow> Oc) = (Nop, 0)")
+apply(simp add: new_tape.simps)
+apply(rule s_out_fetch, simp, simp)
+done
+
+lemma conf_keep:
+ "\<lbrakk>t_ncorrect tp;
+ \<not> (length tp1 div 2 < a \<and>
+ a \<le> length tp1 div 2 + length tp div 2); n > 0\<rbrakk>
+ \<Longrightarrow> t_steps (a, aa, ba) (tp, length tp1 div 2) n = (0, aa, ba)"
+apply(induct n, simp)
+apply(case_tac n, simp add: t_steps.simps)
+apply(rule_tac conf_keep_step, simp+)
+apply(subgoal_tac " t_steps (a, aa, ba)
+ (tp, length tp1 div 2) (Suc (Suc nat))
+ = t_step (t_steps (a, aa, ba)
+ (tp, length tp1 div 2) (Suc nat)) (tp, length tp1 div 2)")
+apply(simp)
+apply(rule_tac conf_keep_step, simp, simp)
+apply(rule stepn)
+done
+
+lemma state_bef_inside:
+ "\<lbrakk>t_ncorrect tp1; t_ncorrect tp;
+ t_steps (s0, l0, r0) (tp, length tp1 div 2) stp = (s, l, r);
+ length tp1 div 2 < s0 \<and>
+ s0 \<le> length tp1 div 2 + length tp div 2;
+ length tp1 div 2 < s \<and> s \<le> length tp1 div 2 + length tp div 2;
+ n < stp; t_steps (s0, l0, r0) (tp, length tp1 div 2) n =
+ (a, aa, ba)\<rbrakk>
+ \<Longrightarrow> length tp1 div 2 < a \<and>
+ a \<le> length tp1 div 2 + length tp div 2"
+apply(subgoal_tac "\<exists> x. stp = n + x", erule exE)
+apply(simp only: t_step_add)
+apply(rule classical)
+apply(subgoal_tac "t_steps (a, aa, ba)
+ (tp, length tp1 div 2) x = (0, aa, ba)")
+apply(simp)
+apply(rule conf_keep, simp, simp, simp)
+apply(rule_tac x = "stp - n" in exI, simp)
+done
+
+lemma turing_shift_inside:
+ "\<lbrakk>t_steps (s0, l0, r0) (tp, length tp1 div 2) stp = (s, l, r);
+ length tp1 div 2 < s0 \<and>
+ s0 \<le> length tp1 div 2 + length tp div 2;
+ t_ncorrect tp1; t_ncorrect tp;
+ length tp1 div 2 < s \<and>
+ s \<le> length tp1 div 2 + length tp div 2\<rbrakk>
+ \<Longrightarrow> t_steps (s0, l0, r0) (tp1 @ tp @ tp2, 0) stp = (s, l, r)"
+apply(induct stp arbitrary: s l r)
+apply(simp add: t_steps.simps)
+apply(subgoal_tac " t_steps (s0, l0, r0)
+ (tp, length tp1 div 2) (Suc stp)
+ = t_step (t_steps (s0, l0, r0)
+ (tp, length tp1 div 2) stp) (tp, length tp1 div 2)")
+apply(case_tac "t_steps (s0, l0, r0) (tp, length tp1 div 2) stp")
+apply(subgoal_tac "length tp1 div 2 < a \<and>
+ a \<le> length tp1 div 2 + length tp div 2")
+apply(subgoal_tac "t_steps (s0, l0, r0)
+ (tp1 @ tp @ tp2, 0) stp = (a, b, c)")
+apply(simp only: stepn, simp)
+apply(rule_tac t_shift_in_step, simp+)
+defer
+apply(rule stepn)
+apply(rule_tac n = stp and stp = "Suc stp" and a = a
+ and aa = b and ba = c in state_bef_inside, simp+)
+done
+
+lemma take_Suc_last[elim]: "Suc as \<le> length xs \<Longrightarrow>
+ take (Suc as) xs = take as xs @ [xs ! as]"
+apply(induct xs arbitrary: as, simp, simp)
+apply(case_tac as, simp, simp)
+done
+
+lemma concat_suc: "Suc as \<le> length xs \<Longrightarrow>
+ concat (take (Suc as) xs) = concat (take as xs) @ xs! as"
+apply(subgoal_tac "take (Suc as) xs = take as xs @ [xs ! as]", simp)
+by auto
+
+lemma concat_take_suc_iff: "Suc n \<le> length tps \<Longrightarrow>
+ concat (take n tps) @ (tps ! n) = concat (take (Suc n) tps)"
+apply(drule_tac concat_suc, simp)
+done
+
+lemma concat_drop_suc_iff:
+ "Suc n < length tps \<Longrightarrow> concat (drop (Suc n) tps) =
+ tps ! Suc n @ concat (drop (Suc (Suc n)) tps)"
+apply(induct tps arbitrary: n, simp, simp)
+apply(case_tac tps, simp, simp)
+apply(case_tac n, simp, simp)
+done
+
+declare append_assoc[simp del]
+
+lemma tm_append: "\<lbrakk>n < length tps; tp = tps ! n\<rbrakk> \<Longrightarrow>
+ \<exists> tp1 tp2. concat tps = tp1 @ tp @ tp2 \<and> tp1 =
+ concat (take n tps) \<and> tp2 = concat (drop (Suc n) tps)"
+apply(rule_tac x = "concat (take n tps)" in exI)
+apply(rule_tac x = "concat (drop (Suc n) tps)" in exI)
+apply(auto)
+apply(induct n, simp)
+apply(case_tac tps, simp, simp, simp)
+apply(subgoal_tac "concat (take n tps) @ (tps ! n) =
+ concat (take (Suc n) tps)")
+apply(simp only: append_assoc[THEN sym], simp only: append_assoc)
+apply(subgoal_tac " concat (drop (Suc n) tps) = tps ! Suc n @
+ concat (drop (Suc (Suc n)) tps)", simp)
+apply(rule_tac concat_drop_suc_iff, simp)
+apply(rule_tac concat_take_suc_iff, simp)
+done
+
+declare append_assoc[simp]
+
+lemma map_of: "n < length xs \<Longrightarrow> (map f xs) ! n = f (xs ! n)"
+by(auto)
+
+lemma [simp]: "length (tms_of aprog) = length aprog"
+apply(auto simp: tms_of.simps tpairs_of.simps)
+done
+
+lemma ci_nth: "\<lbrakk>ly = layout_of aprog; as < length aprog;
+ abc_fetch as aprog = Some ins\<rbrakk>
+ \<Longrightarrow> ci ly (start_of ly as) ins = tms_of aprog ! as"
+apply(simp add: tms_of.simps tpairs_of.simps
+ abc_fetch.simps map_of del: map_append)
+done
+
+lemma t_split:"\<lbrakk>
+ ly = layout_of aprog;
+ as < length aprog; abc_fetch as aprog = Some ins\<rbrakk>
+ \<Longrightarrow> \<exists> tp1 tp2. concat (tms_of aprog) =
+ tp1 @ (ci ly (start_of ly as) ins) @ tp2
+ \<and> tp1 = concat (take as (tms_of aprog)) \<and>
+ tp2 = concat (drop (Suc as) (tms_of aprog))"
+apply(insert tm_append[of "as" "tms_of aprog"
+ "ci ly (start_of ly as) ins"], simp)
+apply(subgoal_tac "ci ly (start_of ly as) ins = (tms_of aprog) ! as")
+apply(subgoal_tac "length (tms_of aprog) = length aprog", simp, simp)
+apply(rule_tac ci_nth, auto)
+done
+
+lemma math_sub: "\<lbrakk>x >= Suc 0; x - 1 = z\<rbrakk> \<Longrightarrow> x + y - Suc 0 = z + y"
+by auto
+
+lemma start_more_one: "as \<noteq> 0 \<Longrightarrow> start_of ly as >= Suc 0"
+apply(induct as, simp add: start_of.simps)
+apply(case_tac as, auto simp: start_of.simps)
+done
+
+lemma tm_ct: "\<lbrakk>abc2t_correct aprog; tp \<in> set (tms_of aprog)\<rbrakk> \<Longrightarrow>
+ t_ncorrect tp"
+apply(simp add: abc2t_correct.simps tms_of.simps)
+apply(auto)
+apply(simp add:list_all_iff, auto)
+done
+
+lemma div_apart: "\<lbrakk>x mod (2::nat) = 0; y mod 2 = 0\<rbrakk>
+ \<Longrightarrow> (x + y) div 2 = x div 2 + y div 2"
+apply(drule mod_eqD)+
+apply(auto)
+done
+
+lemma div_apart_iff: "\<lbrakk>x mod (2::nat) = 0; y mod 2 = 0\<rbrakk> \<Longrightarrow>
+ (x + y) mod 2 = 0"
+apply(auto)
+done
+
+lemma tms_ct: "\<lbrakk>abc2t_correct aprog; n < length aprog\<rbrakk> \<Longrightarrow>
+ t_ncorrect (concat (take n (tms_of aprog)))"
+apply(induct n, simp add: t_ncorrect.simps, simp)
+apply(subgoal_tac "concat (take (Suc n) (tms_of aprog)) =
+ concat (take n (tms_of aprog)) @ (tms_of aprog ! n)", simp)
+apply(simp add: t_ncorrect.simps)
+apply(rule_tac div_apart_iff, simp)
+apply(subgoal_tac "t_ncorrect (tms_of aprog ! n)",
+ simp add: t_ncorrect.simps)
+apply(rule_tac tm_ct, simp)
+apply(rule_tac nth_mem, simp add: tms_of.simps tpairs_of.simps)
+apply(rule_tac concat_suc, simp add: tms_of.simps tpairs_of.simps)
+done
+
+lemma tcorrect_div2: "\<lbrakk>abc2t_correct aprog; Suc as < length aprog\<rbrakk>
+ \<Longrightarrow> (length (concat (take as (tms_of aprog))) + length (tms_of aprog
+ ! as)) div 2 = length (concat (take as (tms_of aprog))) div 2 +
+ length (tms_of aprog ! as) div 2"
+apply(subgoal_tac "t_ncorrect (tms_of aprog ! as)")
+apply(subgoal_tac "t_ncorrect (concat (take as (tms_of aprog)))")
+apply(rule_tac div_apart)
+apply(rule tct_div2, simp)+
+apply(erule_tac tms_ct, simp)
+apply(rule_tac tm_ct, simp)
+apply(rule_tac nth_mem)
+apply(simp add: tms_of.simps tpairs_of.simps)
+done
+
+lemma [simp]: "length (layout_of aprog) = length aprog"
+apply(auto simp: layout_of.simps)
+done
+
+lemma start_of_ind: "\<lbrakk>as < length aprog; ly = layout_of aprog\<rbrakk> \<Longrightarrow>
+ start_of ly (Suc as) = start_of ly as +
+ length ((tms_of aprog) ! as) div 2"
+apply(simp only: start_of.simps, simp)
+apply(auto simp: start_of.simps tms_of.simps layout_of.simps
+ tpairs_of.simps)
+apply(simp add: ci_length)
+done
+
+lemma concat_take_suc: "Suc n \<le> length xs \<Longrightarrow>
+ concat (take (Suc n) xs) = concat (take n xs) @ (xs ! n)"
+apply(subgoal_tac "take (Suc n) xs =
+ take n xs @ [xs ! n]")
+apply(auto)
+done
+
+lemma ci_length_not0: "Suc 0 <= length (ci ly as i) div 2"
+apply(subgoal_tac "length (ci ly as i) div 2 = length_of i")
+apply(simp add: length_of.simps split: abc_inst.splits)
+apply(rule ci_length)
+done
+
+lemma findnth_length2: "length (findnth n) = 4 * n"
+apply(induct n, simp)
+apply(simp)
+done
+
+lemma ci_length2: "length (ci ly as i) = 2 * (length_of i)"
+apply(simp add: ci.simps length_of.simps tinc_b_def tdec_b_def
+ split: abc_inst.splits, auto)
+apply(simp add: findnth_length2)+
+done
+
+lemma tm_mod2: "as < length aprog \<Longrightarrow>
+ length (tms_of aprog ! as) mod 2 = 0"
+apply(simp add: tms_of.simps)
+apply(subgoal_tac "map (\<lambda>(x, y). ci (layout_of aprog) x y)
+ (tpairs_of aprog) ! as
+ = (\<lambda>(x, y). ci (layout_of aprog) x y)
+ ((tpairs_of aprog) ! as)", simp)
+apply(case_tac "(tpairs_of aprog ! as)", simp)
+apply(subgoal_tac "length (ci (layout_of aprog) a b) =
+ 2 * (length_of b)", simp)
+apply(rule ci_length2)
+apply(rule map_of, simp add: tms_of.simps tpairs_of.simps)
+done
+
+lemma tms_mod2: "as \<le> length aprog \<Longrightarrow>
+ length (concat (take as (tms_of aprog))) mod 2 = 0"
+apply(induct as, simp, simp)
+apply(subgoal_tac "concat (take (Suc as) (tms_of aprog))
+ = concat (take as (tms_of aprog)) @
+ (tms_of aprog ! as)", auto)
+apply(rule div_apart_iff, simp, rule tm_mod2, simp)
+apply(rule concat_take_suc, simp add: tms_of.simps tpairs_of.simps)
+done
+
+lemma [simp]: "\<lbrakk>as < length aprog; (abc_fetch as aprog) = Some ins\<rbrakk>
+ \<Longrightarrow> ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (ins) \<in> set (tms_of aprog)"
+apply(insert ci_nth[of "layout_of aprog" aprog as], simp)
+done
+
+lemma startof_not0: "start_of ly as > 0"
+apply(induct as, simp add: start_of.simps)
+apply(case_tac as, auto simp: start_of.simps)
+done
+
+declare abc_step_l.simps[simp del]
+lemma pre_lheq: "\<lbrakk>tp = concat (take as (tms_of aprog));
+ abc2t_correct aprog; as \<le> length aprog\<rbrakk> \<Longrightarrow>
+ start_of (layout_of aprog) as - Suc 0 = length tp div 2"
+apply(induct as arbitrary: tp, simp add: start_of.simps, simp)
+proof -
+ fix as tp
+ assume h1: "\<And>tp. tp = concat (take as (tms_of aprog)) \<Longrightarrow>
+ start_of (layout_of aprog) as - Suc 0 =
+ length (concat (take as (tms_of aprog))) div 2"
+ and h2: " abc2t_correct aprog" "Suc as \<le> length aprog"
+ from h2 show "start_of (layout_of aprog) (Suc as) - Suc 0 =
+ length (concat (take (Suc as) (tms_of aprog))) div 2"
+ apply(insert h1[of "concat (take as (tms_of aprog))"], simp)
+ apply(insert start_of_ind[of as aprog "layout_of aprog"], simp)
+ apply(subgoal_tac "(take (Suc as) (tms_of aprog)) =
+ take as (tms_of aprog) @ [(tms_of aprog) ! as]", simp)
+ apply(subgoal_tac "(length (concat (take as (tms_of aprog))) +
+ length (tms_of aprog ! as)) div 2
+ = length (concat (take as (tms_of aprog))) div 2 +
+ length (tms_of aprog ! as) div 2", simp)
+ apply(subgoal_tac "start_of (layout_of aprog) as =
+ length (concat (take as (tms_of aprog))) div 2 + Suc 0", simp)
+ apply(subgoal_tac "start_of (layout_of aprog) as > 0", simp,
+ rule_tac startof_not0)
+ apply(insert tm_mod2[of as aprog], simp)
+ apply(insert tms_mod2[of as aprog], simp, arith)
+ apply(rule take_Suc_last, simp)
+ done
+qed
+
+lemma crsp2stateq:
+ "\<lbrakk>as < length aprog; abc2t_correct aprog;
+ crsp_l (layout_of aprog) (as, am) (a, aa, ba) inres\<rbrakk> \<Longrightarrow>
+ a = length (concat (take as (tms_of aprog))) div 2 + 1"
+apply(simp add: crsp_l.simps)
+apply(insert pre_lheq[of "(concat (take as (tms_of aprog)))" as aprog]
+, simp)
+apply(subgoal_tac "start_of (layout_of aprog) as > 0",
+ auto intro: startof_not0)
+done
+
+lemma turing_shift_outside:
+ "\<lbrakk>t_steps (s0, l0, r0) (tp, length tp1 div 2) stp = (s, l, r);
+ s \<noteq> 0; stp > 0;
+ length tp1 div 2 < s0 \<and>
+ s0 \<le> length tp1 div 2 + length tp div 2;
+ t_ncorrect tp1; t_ncorrect tp;
+ \<not> (length tp1 div 2 < s \<and>
+ s \<le> length tp1 div 2 + length tp div 2)\<rbrakk>
+ \<Longrightarrow> \<exists>stp' > 0. t_steps (s0, l0, r0) (tp1 @ tp @ tp2, 0) stp'
+ = (s, l, r)"
+apply(rule_tac x = stp in exI)
+apply(case_tac stp, simp add: t_steps.simps)
+apply(simp only: stepn)
+apply(case_tac "t_steps (s0, l0, r0) (tp, length tp1 div 2) nat")
+apply(subgoal_tac "length tp1 div 2 < a \<and>
+ a \<le> length tp1 div 2 + length tp div 2")
+apply(subgoal_tac "t_steps (s0, l0, r0) (tp1 @ tp @ tp2, 0) nat
+ = (a, b, c)", simp)
+apply(rule_tac t_shift_in_step, simp+)
+apply(rule_tac turing_shift_inside, simp+)
+apply(rule classical)
+apply(subgoal_tac "t_step (a,b,c)
+ (tp, length tp1 div 2) = (0, b, c)", simp)
+apply(rule_tac conf_keep_step, simp+)
+done
+
+lemma turing_shift:
+ "\<lbrakk>t_steps (s0, (l0, r0)) (tp, (length tp1 div 2)) stp
+ = (s, (l, r)); s \<noteq> 0; stp > 0;
+ (length tp1 div 2 < s0 \<and> s0 <= length tp1 div 2 + length tp div 2);
+ t_ncorrect tp1; t_ncorrect tp\<rbrakk> \<Longrightarrow>
+ \<exists> stp' > 0. t_steps (s0, (l0, r0)) (tp1 @ tp @ tp2, 0) stp' =
+ (s, (l, r))"
+apply(case_tac "s > length tp1 div 2 \<and>
+ s <= length tp1 div 2 + length tp div 2")
+apply(subgoal_tac " t_steps (s0, l0, r0) (tp1 @ tp @ tp2, 0) stp =
+ (s, l, r)")
+apply(rule_tac x = stp in exI, simp)
+apply(rule_tac turing_shift_inside, simp+)
+apply(rule_tac turing_shift_outside, simp+)
+done
+
+lemma inc_startof_not0: "start_of ly as \<ge> Suc 0"
+apply(induct as, simp add: start_of.simps)
+apply(simp add: start_of.simps)
+done
+
+lemma s_crsp:
+ "\<lbrakk>as < length aprog; abc_fetch as aprog = Some ins;
+ abc2t_correct aprog;
+ crsp_l (layout_of aprog) (as, am) (a, aa, ba) inres\<rbrakk> \<Longrightarrow>
+ length (concat (take as (tms_of aprog))) div 2 < a
+ \<and> a \<le> length (concat (take as (tms_of aprog))) div 2 +
+ length (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ ins) div 2"
+apply(subgoal_tac "a = length (concat (take as (tms_of aprog))) div
+ 2 + 1", simp)
+apply(rule_tac ci_length_not0)
+apply(rule crsp2stateq, simp+)
+done
+
+lemma tms_out_ex:
+ "\<lbrakk>ly = layout_of aprog; tprog = tm_of aprog;
+ abc2t_correct aprog;
+ crsp_l ly (as, am) tc inres; as < length aprog;
+ abc_fetch as aprog = Some ins;
+ t_steps tc (ci ly (start_of ly as) ins,
+ (start_of ly as) - 1) n = (s, l, r);
+ n > 0;
+ abc_step_l (as, am) (abc_fetch as aprog) = (as', am');
+ s = start_of ly as'
+ \<rbrakk>
+ \<Longrightarrow> \<exists> stp > 0. (t_steps tc (tprog, 0) stp = (s, (l, r)))"
+apply(simp only: tm_of.simps)
+apply(subgoal_tac "\<exists> tp1 tp2. concat (tms_of aprog) =
+ tp1 @ (ci ly (start_of ly as) ins) @ tp2
+ \<and> tp1 = concat (take as (tms_of aprog)) \<and>
+ tp2 = concat (drop (Suc as) (tms_of aprog))")
+apply(erule exE, erule exE, erule conjE, erule conjE,
+ case_tac tc, simp)
+apply(rule turing_shift)
+apply(subgoal_tac "start_of (layout_of aprog) as - Suc 0
+ = length tp1 div 2", simp)
+apply(rule_tac pre_lheq, simp, simp, simp)
+apply(simp add: startof_not0, simp)
+apply(rule_tac s_crsp, simp, simp, simp, simp)
+apply(rule tms_ct, simp, simp)
+apply(rule tm_ct, simp)
+apply(subgoal_tac "ci (layout_of aprog)
+ (start_of (layout_of aprog) as) ins
+ = (tms_of aprog ! as)", simp)
+apply(simp add: tms_of.simps tpairs_of.simps)
+apply(simp add: tms_of.simps tpairs_of.simps abc_fetch.simps)
+apply(erule_tac t_split, auto simp: tm_of.simps)
+done
+
+subsubsection {* The compilation of @{text "Inc n"} *}
+
+text {*
+ The lemmas in this section lead to the correctness of
+ the compilation of @{text "Inc n"} instruction.
+*}
+
+(*****Begin: inc crsp*******)
+fun at_begin_fst_bwtn :: "inc_inv_t"
+ where
+ "at_begin_fst_bwtn (as, lm) (s, l, r) ires =
+ (\<exists> lm1 tn rn. lm1 = (lm @ (0\<^bsup>tn\<^esup>)) \<and> length lm1 = s \<and>
+ (if lm1 = [] then l = Bk # Bk # ires
+ else l = [Bk]@<rev lm1>@Bk#Bk#ires) \<and> r = (Bk\<^bsup>rn\<^esup>))"
+
+
+fun at_begin_fst_awtn :: "inc_inv_t"
+ where
+ "at_begin_fst_awtn (as, lm) (s, l, r) ires =
+ (\<exists> lm1 tn rn. lm1 = (lm @ (0\<^bsup>tn\<^esup>)) \<and> length lm1 = s \<and>
+ (if lm1 = [] then l = Bk # Bk # ires
+ else l = [Bk]@<rev lm1>@Bk#Bk#ires) \<and> r = [Oc]@Bk\<^bsup>rn\<^esup>
+ )"
+
+fun at_begin_norm :: "inc_inv_t"
+ where
+ "at_begin_norm (as, lm) (s, l, r) ires=
+ (\<exists> lm1 lm2 rn. lm = lm1 @ lm2 \<and> length lm1 = s \<and>
+ (if lm1 = [] then l = Bk # Bk # ires
+ else l = Bk # <rev lm1> @ Bk# Bk # ires ) \<and> r = <lm2> @ (Bk\<^bsup>rn\<^esup>))"
+
+fun in_middle :: "inc_inv_t"
+ where
+ "in_middle (as, lm) (s, l, r) ires =
+ (\<exists> lm1 lm2 tn m ml mr rn. lm @ 0\<^bsup>tn\<^esup> = lm1 @ [m] @ lm2
+ \<and> length lm1 = s \<and> m + 1 = ml + mr \<and>
+ ml \<noteq> 0 \<and> tn = s + 1 - length lm \<and>
+ (if lm1 = [] then l = Oc\<^bsup>ml\<^esup> @ Bk # Bk # ires
+ else l = (Oc\<^bsup>ml\<^esup>)@[Bk]@<rev lm1>@
+ Bk # Bk # ires) \<and> (r = (Oc\<^bsup>mr\<^esup>) @ [Bk] @ <lm2>@ (Bk\<^bsup>rn\<^esup>) \<or>
+ (lm2 = [] \<and> r = (Oc\<^bsup>mr\<^esup>)))
+ )"
+
+fun inv_locate_a :: "inc_inv_t"
+ where "inv_locate_a (as, lm) (s, l, r) ires =
+ (at_begin_norm (as, lm) (s, l, r) ires \<or>
+ at_begin_fst_bwtn (as, lm) (s, l, r) ires \<or>
+ at_begin_fst_awtn (as, lm) (s, l, r) ires
+ )"
+
+fun inv_locate_b :: "inc_inv_t"
+ where "inv_locate_b (as, lm) (s, l, r) ires =
+ (in_middle (as, lm) (s, l, r)) ires "
+
+fun inv_after_write :: "inc_inv_t"
+ where "inv_after_write (as, lm) (s, l, r) ires =
+ (\<exists> rn m lm1 lm2. lm = lm1 @ m # lm2 \<and>
+ (if lm1 = [] then l = Oc\<^bsup>m\<^esup> @ Bk # Bk # ires
+ else Oc # l = Oc\<^bsup>Suc m \<^esup>@ Bk # <rev lm1> @
+ Bk # Bk # ires) \<and> r = [Oc] @ <lm2> @ (Bk\<^bsup>rn\<^esup>))"
+
+fun inv_after_move :: "inc_inv_t"
+ where "inv_after_move (as, lm) (s, l, r) ires =
+ (\<exists> rn m lm1 lm2. lm = lm1 @ m # lm2 \<and>
+ (if lm1 = [] then l = Oc\<^bsup>Suc m\<^esup> @ Bk # Bk # ires
+ else l = Oc\<^bsup>Suc m\<^esup>@ Bk # <rev lm1> @ Bk # Bk # ires) \<and>
+ r = <lm2> @ (Bk\<^bsup>rn\<^esup>))"
+
+fun inv_after_clear :: "inc_inv_t"
+ where "inv_after_clear (as, lm) (s, l, r) ires =
+ (\<exists> rn m lm1 lm2 r'. lm = lm1 @ m # lm2 \<and>
+ (if lm1 = [] then l = Oc\<^bsup>Suc m\<^esup> @ Bk # Bk # ires
+ else l = Oc\<^bsup>Suc m\<^esup>@ Bk # <rev lm1> @ Bk # Bk # ires) \<and>
+ r = Bk # r' \<and> Oc # r' = <lm2> @ (Bk\<^bsup>rn\<^esup>))"
+
+fun inv_on_right_moving :: "inc_inv_t"
+ where "inv_on_right_moving (as, lm) (s, l, r) ires =
+ (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and>
+ ml + mr = m \<and>
+ (if lm1 = [] then l = Oc\<^bsup>ml\<^esup> @ Bk # Bk # ires
+ else l = (Oc\<^bsup>ml\<^esup>) @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and>
+ ((r = (Oc\<^bsup>mr\<^esup>) @ [Bk] @ <lm2> @ (Bk\<^bsup>rn\<^esup>)) \<or>
+ (r = (Oc\<^bsup>mr\<^esup>) \<and> lm2 = [])))"
+
+fun inv_on_left_moving_norm :: "inc_inv_t"
+ where "inv_on_left_moving_norm (as, lm) (s, l, r) ires =
+ (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and>
+ ml + mr = Suc m \<and> mr > 0 \<and> (if lm1 = [] then l = Oc\<^bsup>ml\<^esup> @ Bk # Bk # ires
+ else l = (Oc\<^bsup>ml\<^esup>) @ Bk # <rev lm1> @ Bk # Bk # ires)
+ \<and> (r = (Oc\<^bsup>mr\<^esup>) @ Bk # <lm2> @ (Bk\<^bsup>rn\<^esup>) \<or>
+ (lm2 = [] \<and> r = Oc\<^bsup>mr\<^esup>)))"
+
+fun inv_on_left_moving_in_middle_B:: "inc_inv_t"
+ where "inv_on_left_moving_in_middle_B (as, lm) (s, l, r) ires =
+ (\<exists> lm1 lm2 rn. lm = lm1 @ lm2 \<and>
+ (if lm1 = [] then l = Bk # ires
+ else l = <rev lm1> @ Bk # Bk # ires) \<and>
+ r = Bk # <lm2> @ (Bk\<^bsup>rn\<^esup>))"
+
+fun inv_on_left_moving :: "inc_inv_t"
+ where "inv_on_left_moving (as, lm) (s, l, r) ires =
+ (inv_on_left_moving_norm (as, lm) (s, l, r) ires \<or>
+ inv_on_left_moving_in_middle_B (as, lm) (s, l, r) ires)"
+
+
+fun inv_check_left_moving_on_leftmost :: "inc_inv_t"
+ where "inv_check_left_moving_on_leftmost (as, lm) (s, l, r) ires =
+ (\<exists> rn. l = ires \<and> r = [Bk, Bk] @ <lm> @ (Bk\<^bsup>rn\<^esup>))"
+
+fun inv_check_left_moving_in_middle :: "inc_inv_t"
+ where "inv_check_left_moving_in_middle (as, lm) (s, l, r) ires =
+
+ (\<exists> lm1 lm2 r' rn. lm = lm1 @ lm2 \<and>
+ (Oc # l = <rev lm1> @ Bk # Bk # ires) \<and> r = Oc # Bk # r' \<and>
+ r' = <lm2> @ (Bk\<^bsup>rn\<^esup>))"
+
+fun inv_check_left_moving :: "inc_inv_t"
+ where "inv_check_left_moving (as, lm) (s, l, r) ires =
+ (inv_check_left_moving_on_leftmost (as, lm) (s, l, r) ires \<or>
+ inv_check_left_moving_in_middle (as, lm) (s, l, r) ires)"
+
+fun inv_after_left_moving :: "inc_inv_t"
+ where "inv_after_left_moving (as, lm) (s, l, r) ires=
+ (\<exists> rn. l = Bk # ires \<and> r = Bk # <lm> @ (Bk\<^bsup>rn\<^esup>))"
+
+fun inv_stop :: "inc_inv_t"
+ where "inv_stop (as, lm) (s, l, r) ires=
+ (\<exists> rn. l = Bk # Bk # ires \<and> r = <lm> @ (Bk\<^bsup>rn\<^esup>))"
+
+
+fun inc_inv :: "layout \<Rightarrow> nat \<Rightarrow> inc_inv_t"
+ where
+ "inc_inv ly n (as, lm) (s, l, r) ires =
+ (let ss = start_of ly as in
+ let lm' = abc_lm_s lm n ((abc_lm_v lm n)+1) in
+ if s = 0 then False
+ else if s < ss then False
+ else if s < ss + 2 * n then
+ if (s - ss) mod 2 = 0 then
+ inv_locate_a (as, lm) ((s - ss) div 2, l, r) ires
+ else inv_locate_b (as, lm) ((s - ss) div 2, l, r) ires
+ else if s = ss + 2 * n then
+ inv_locate_a (as, lm) (n, l, r) ires
+ else if s = ss + 2 * n + 1 then
+ inv_locate_b (as, lm) (n, l, r) ires
+ else if s = ss + 2 * n + 2 then
+ inv_after_write (as, lm') (s - ss, l, r) ires
+ else if s = ss + 2 * n + 3 then
+ inv_after_move (as, lm') (s - ss, l, r) ires
+ else if s = ss + 2 * n + 4 then
+ inv_after_clear (as, lm') (s - ss, l, r) ires
+ else if s = ss + 2 * n + 5 then
+ inv_on_right_moving (as, lm') (s - ss, l, r) ires
+ else if s = ss + 2 * n + 6 then
+ inv_on_left_moving (as, lm') (s - ss, l, r) ires
+ else if s = ss + 2 * n + 7 then
+ inv_check_left_moving (as, lm') (s - ss, l, r) ires
+ else if s = ss + 2 * n + 8 then
+ inv_after_left_moving (as, lm') (s - ss, l, r) ires
+ else if s = ss + 2 * n + 9 then
+ inv_stop (as, lm') (s - ss, l, r) ires
+ else False) "
+
+lemma fetch_intro:
+ "\<lbrakk>\<And>xs.\<lbrakk>ba = Oc # xs\<rbrakk> \<Longrightarrow> P (fetch prog i Oc);
+ \<And>xs.\<lbrakk>ba = Bk # xs\<rbrakk> \<Longrightarrow> P (fetch prog i Bk);
+ ba = [] \<Longrightarrow> P (fetch prog i Bk)
+ \<rbrakk> \<Longrightarrow> P (fetch prog i
+ (case ba of [] \<Rightarrow> Bk | Bk # xs \<Rightarrow> Bk | Oc # xs \<Rightarrow> Oc))"
+by (auto split:list.splits block.splits)
+
+lemma length_findnth[simp]: "length (findnth n) = 4 * n"
+apply(induct n, simp)
+apply(simp)
+done
+
+declare tshift.simps[simp del]
+declare findnth.simps[simp del]
+
+lemma findnth_nth:
+ "\<lbrakk>n > q; x < 4\<rbrakk> \<Longrightarrow>
+ (findnth n) ! (4 * q + x) = (findnth (Suc q) ! (4 * q + x))"
+apply(induct n, simp)
+apply(case_tac "q < n", simp add: findnth.simps, auto)
+apply(simp add: nth_append)
+apply(subgoal_tac "q = n", simp)
+apply(arith)
+done
+
+lemma Suc_pre[simp]: "\<not> a < start_of ly as \<Longrightarrow>
+ (Suc a - start_of ly as) = Suc (a - start_of ly as)"
+apply(arith)
+done
+
+lemma fetch_locate_a_o: "
+\<And>a q xs.
+ \<lbrakk>\<not> a < start_of (layout_of aprog) as;
+ a < start_of (layout_of aprog) as + 2 * n;
+ a - start_of (layout_of aprog) as = 2 * q;
+ start_of (layout_of aprog) as > 0\<rbrakk>
+ \<Longrightarrow> (fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Inc n)) (Suc (2 * q)) Oc) = (R, a+1)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append Suc_pre)
+apply(subgoal_tac "(findnth n ! Suc (4 * q)) =
+ findnth (Suc q) ! (4 * q + 1)")
+apply(simp add: findnth.simps nth_append)
+apply(subgoal_tac " findnth n !(4 * q + 1) =
+ findnth (Suc q) ! (4 * q + 1)", simp)
+apply(rule_tac findnth_nth, auto)
+done
+
+lemma fetch_locate_a_b: "
+\<And>a q xs.
+ \<lbrakk>abc_fetch as aprog = Some (Inc n);
+ \<not> a < start_of (layout_of aprog) as;
+ a < start_of (layout_of aprog) as + 2 * n;
+ a - start_of (layout_of aprog) as = 2 * q;
+ start_of (layout_of aprog) as > 0\<rbrakk>
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (Suc (2 * q)) Bk)
+ = (W1, a)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ tshift.simps nth_append)
+apply(subgoal_tac "(findnth n ! (4 * q)) =
+ findnth (Suc q) ! (4 * q )")
+apply(simp add: findnth.simps nth_append)
+apply(subgoal_tac " findnth n !(4 * q + 0) =
+ findnth (Suc q) ! (4 * q + 0)", simp)
+apply(rule_tac findnth_nth, auto)
+done
+
+lemma [intro]: "x mod 2 = Suc 0 \<Longrightarrow> \<exists> q. x = Suc (2 * q)"
+apply(drule mod_eqD, auto)
+done
+
+lemma add3_Suc: "x + 3 = Suc (Suc (Suc x))"
+apply(arith)
+done
+
+declare start_of.simps[simp]
+(*
+lemma layout_not0: "start_of ly as > 0"
+by(induct as, auto)
+*)
+lemma [simp]:
+ "\<lbrakk>\<not> a < start_of (layout_of aprog) as;
+ a - start_of (layout_of aprog) as = Suc (2 * q);
+ abc_fetch as aprog = Some (Inc n);
+ start_of (layout_of aprog) as > 0\<rbrakk>
+ \<Longrightarrow> Suc (Suc (2 * q + start_of (layout_of aprog) as - Suc 0)) = a"
+apply(subgoal_tac
+"Suc (Suc (2 * q + start_of (layout_of aprog) as - Suc 0))
+ = 2 + 2 * q + start_of (layout_of aprog) as - Suc 0",
+ simp, simp add: inc_startof_not0)
+done
+
+lemma fetch_locate_b_o: "
+\<And>a xs.
+ \<lbrakk>0 < a; \<not> a < start_of (layout_of aprog) as;
+ a < start_of (layout_of aprog) as + 2 * n;
+ (a - start_of (layout_of aprog) as) mod 2 = Suc 0;
+ start_of (layout_of aprog) as > 0\<rbrakk>
+ \<Longrightarrow> (fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Inc n)) (Suc (a - start_of (layout_of aprog) as)) Oc) = (R, a)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append)
+apply(subgoal_tac "\<exists> q. (a - start_of (layout_of aprog) as) =
+ 2 * q + 1", auto)
+apply(subgoal_tac "(findnth n ! Suc (Suc (Suc (4 * q))))
+ = findnth (Suc q) ! (4 * q + 3)")
+apply(simp add: findnth.simps nth_append)
+apply(subgoal_tac " findnth n ! (4 * q + 3) =
+ findnth (Suc q) ! (4 * q + 3)", simp add: add3_Suc)
+apply(rule_tac findnth_nth, auto)
+done
+
+lemma fetch_locate_b_b: "
+\<And>a xs.
+ \<lbrakk>0 < a; \<not> a < start_of (layout_of aprog) as;
+ a < start_of (layout_of aprog) as + 2 * n;
+ (a - start_of (layout_of aprog) as) mod 2 = Suc 0;
+ start_of (layout_of aprog) as > 0\<rbrakk>
+ \<Longrightarrow> (fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Inc n)) (Suc (a - start_of (layout_of aprog) as)) Bk)
+ = (R, a + 1)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append)
+apply(subgoal_tac "\<exists> q. (a - start_of (layout_of aprog) as) =
+ 2 * q + 1", auto)
+apply(subgoal_tac "(findnth n ! Suc ((Suc (4 * q)))) =
+ findnth (Suc q) ! (4 * q + 2)")
+apply(simp add: findnth.simps nth_append)
+apply(subgoal_tac " findnth n ! (4 * q + 2) =
+ findnth (Suc q) ! (4 * q + 2)", simp)
+apply(rule_tac findnth_nth, auto)
+done
+
+lemma fetch_locate_n_a_o:
+ "start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (Suc (2 * n)) Oc) =
+ (R, start_of (layout_of aprog) as + 2 * n + 1)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tinc_b_def)
+done
+
+lemma fetch_locate_n_a_b: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (Suc (2 * n)) Bk)
+ = (W1, start_of (layout_of aprog) as + 2 * n)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tinc_b_def)
+done
+
+lemma fetch_locate_n_b_o: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Inc n)) (Suc (Suc (2 * n))) Oc) =
+ (R, start_of (layout_of aprog) as + 2 * n + 1)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tinc_b_def)
+done
+
+lemma fetch_locate_n_b_b: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Inc n)) (Suc (Suc (2 * n))) Bk) =
+ (W1, start_of (layout_of aprog) as + 2 * n + 2)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tinc_b_def)
+done
+
+lemma fetch_after_write_o: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Inc n)) (Suc (Suc (Suc (2 * n)))) Oc) =
+ (R, start_of (layout_of aprog) as + 2*n + 3)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tinc_b_def)
+done
+
+lemma fetch_after_move_o: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (4 + 2 * n) Oc)
+ = (W0, start_of (layout_of aprog) as + 2 * n + 4)"
+apply(auto simp: ci.simps findnth.simps tshift.simps
+ tinc_b_def add3_Suc)
+apply(subgoal_tac "4 + 2*n = Suc (2*n + 3)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma fetch_after_move_b: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow>(fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (4 + 2 * n) Bk)
+ = (L, start_of (layout_of aprog) as + 2 * n + 6)"
+apply(auto simp: ci.simps findnth.simps tshift.simps
+ tinc_b_def add3_Suc)
+apply(subgoal_tac "4 + 2*n = Suc (2*n + 3)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma fetch_clear_b: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (5 + 2 * n) Bk)
+ = (R, start_of (layout_of aprog) as + 2 * n + 5)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tinc_b_def add3_Suc)
+apply(subgoal_tac "5 + 2*n = Suc (2*n + 4)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma fetch_right_move_o: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (6 + 2*n) Oc)
+ = (R, start_of (layout_of aprog) as + 2 * n + 5)"
+apply(auto simp: ci.simps findnth.simps tshift.simps
+ tinc_b_def add3_Suc)
+apply(subgoal_tac "6 + 2*n = Suc (2*n + 5)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma fetch_right_move_b: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (6 + 2*n) Bk)
+ = (W1, start_of (layout_of aprog) as + 2 * n + 2)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tinc_b_def add3_Suc)
+apply(subgoal_tac "6 + 2*n = Suc (2*n + 5)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma fetch_left_move_o: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (7 + 2*n) Oc)
+ = (L, start_of (layout_of aprog) as + 2 * n + 6)"
+apply(auto simp: ci.simps findnth.simps tshift.simps
+ tinc_b_def add3_Suc)
+apply(subgoal_tac "7 + 2*n = Suc (2*n + 6)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma fetch_left_move_b: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (7 + 2*n) Bk)
+ = (L, start_of (layout_of aprog) as + 2 * n + 7)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tinc_b_def add3_Suc)
+apply(subgoal_tac "7 + 2*n = Suc (2*n + 6)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma fetch_check_left_move_o: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (8 + 2*n) Oc)
+ = (L, start_of (layout_of aprog) as + 2 * n + 6)"
+apply(auto simp: ci.simps findnth.simps tshift.simps tinc_b_def)
+apply(subgoal_tac "8 + 2 * n = Suc (2 * n + 7)",
+ simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma fetch_check_left_move_b: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (8 + 2*n) Bk)
+ = (R, start_of (layout_of aprog) as + 2 * n + 8) "
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tinc_b_def add3_Suc)
+apply(subgoal_tac "8 + 2*n= Suc (2*n + 7)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma fetch_after_left_move: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (9 + 2*n) Bk)
+ = (R, start_of (layout_of aprog) as + 2 * n + 9)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tinc_b_def)
+done
+
+lemma fetch_stop: "
+ start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) (10 + 2 *n) b)
+ = (Nop, 0)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tinc_b_def
+ split: block.splits)
+done
+
+lemma fetch_state0: "
+ (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n)) 0 b)
+ = (Nop, 0)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tinc_b_def)
+done
+
+lemmas fetch_simps =
+ fetch_locate_a_o fetch_locate_a_b fetch_locate_b_o fetch_locate_b_b
+ fetch_locate_n_a_b fetch_locate_n_a_o fetch_locate_n_b_o
+ fetch_locate_n_b_b fetch_after_write_o fetch_after_move_o
+ fetch_after_move_b fetch_clear_b fetch_right_move_o
+ fetch_right_move_b fetch_left_move_o fetch_left_move_b
+ fetch_after_left_move fetch_check_left_move_o fetch_stop
+ fetch_state0 fetch_check_left_move_b
+
+text {* *}
+declare exponent_def[simp del] tape_of_nat_list.simps[simp del]
+ at_begin_norm.simps[simp del] at_begin_fst_bwtn.simps[simp del]
+ at_begin_fst_awtn.simps[simp del] in_middle.simps[simp del]
+ abc_lm_s.simps[simp del] abc_lm_v.simps[simp del]
+ ci.simps[simp del] t_step.simps[simp del]
+ inv_after_move.simps[simp del]
+ inv_on_left_moving_norm.simps[simp del]
+ inv_on_left_moving_in_middle_B.simps[simp del]
+ inv_after_clear.simps[simp del]
+ inv_after_write.simps[simp del] inv_on_left_moving.simps[simp del]
+ inv_on_right_moving.simps[simp del]
+ inv_check_left_moving.simps[simp del]
+ inv_check_left_moving_in_middle.simps[simp del]
+ inv_check_left_moving_on_leftmost.simps[simp del]
+ inv_after_left_moving.simps[simp del]
+ inv_stop.simps[simp del] inv_locate_a.simps[simp del]
+ inv_locate_b.simps[simp del]
+declare tms_of.simps[simp del] tm_of.simps[simp del]
+ layout_of.simps[simp del] abc_fetch.simps [simp del]
+ t_step.simps[simp del] t_steps.simps[simp del]
+ tpairs_of.simps[simp del] start_of.simps[simp del]
+ fetch.simps [simp del] new_tape.simps [simp del]
+ nth_of.simps [simp del] ci.simps [simp del]
+ length_of.simps[simp del]
+
+(*! Start point *)
+lemma [simp]: "Suc (2 * q) mod 2 = Suc 0"
+by arith
+
+lemma [simp]: "Suc (2 * q) div 2 = q"
+by arith
+
+lemma [simp]: "\<lbrakk> \<not> a < start_of ly as;
+ a < start_of ly as + 2 * n; a - start_of ly as = 2 * q\<rbrakk>
+ \<Longrightarrow> Suc a < start_of ly as + 2 * n"
+apply(arith)
+done
+
+lemma [simp]: "x mod 2 = Suc 0 \<Longrightarrow> (Suc x) mod 2 = 0"
+by arith
+
+lemma [simp]: "x mod 2 = Suc 0 \<Longrightarrow> (Suc x) div 2 = Suc (x div 2)"
+by arith
+lemma exp_def[simp]: "a\<^bsup>Suc n \<^esup>= a # a\<^bsup>n\<^esup>"
+by(simp add: exponent_def)
+lemma [intro]: "Bk # r = Oc\<^bsup>mr\<^esup> @ r' \<Longrightarrow> mr = 0"
+by(case_tac mr, auto simp: exponent_def)
+
+lemma [intro]: "Bk # r = replicate mr Oc \<Longrightarrow> mr = 0"
+by(case_tac mr, auto)
+lemma tape_of_nl_abv_cons[simp]: "xs \<noteq> [] \<Longrightarrow>
+ <x # xs> = Oc\<^bsup>Suc x\<^esup>@ Bk # <xs>"
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps)
+apply(case_tac xs, simp, simp add: tape_of_nat_list.simps)
+done
+
+lemma [simp]: "<[]::nat list> = []"
+by(auto simp: tape_of_nl_abv tape_of_nat_list.simps)
+lemma [simp]: "Oc # r = <(lm::nat list)> @ Bk\<^bsup>rn\<^esup>\<Longrightarrow> lm \<noteq> []"
+apply(auto simp: tape_of_nl_abv tape_of_nat_list.simps)
+apply(case_tac rn, auto simp: exponent_def)
+done
+lemma BkCons_nil: "Bk # xs = <lm::nat list> @ Bk\<^bsup>rn\<^esup>\<Longrightarrow> lm = []"
+apply(case_tac lm, simp)
+apply(case_tac list, auto simp: tape_of_nl_abv tape_of_nat_list.simps)
+done
+lemma BkCons_nil': "Bk # xs = <lm::nat list> @ Bk\<^bsup>ln\<^esup>\<Longrightarrow> lm = []"
+by(auto intro: BkCons_nil)
+
+lemma hd_tl_tape_of_nat_list:
+ "tl (lm::nat list) \<noteq> [] \<Longrightarrow> <lm> = <hd lm> @ Bk # <tl lm>"
+apply(frule tape_of_nl_abv_cons[of "tl lm" "hd lm"])
+apply(simp add: tape_of_nat_abv Bk_def del: tape_of_nl_abv_cons)
+apply(subgoal_tac "lm = hd lm # tl lm", auto)
+apply(case_tac lm, auto)
+done
+lemma [simp]: "Oc # xs = Oc\<^bsup>mr\<^esup> @ Bk # <lm2> @ Bk\<^bsup>rn\<^esup>\<Longrightarrow> mr > 0"
+apply(case_tac mr, auto simp: exponent_def)
+done
+
+lemma tape_of_nat_list_cons: "xs \<noteq> [] \<Longrightarrow> tape_of_nat_list (x # xs) =
+ replicate (Suc x) Oc @ Bk # tape_of_nat_list xs"
+apply(drule tape_of_nl_abv_cons[of xs x])
+apply(auto simp: tape_of_nl_abv tape_of_nat_abv Oc_def Bk_def exponent_def)
+done
+
+lemma rev_eq: "rev xs = rev ys \<Longrightarrow> xs = ys"
+by simp
+
+lemma tape_of_nat_list_eq: " xs = ys \<Longrightarrow>
+ tape_of_nat_list xs = tape_of_nat_list ys"
+by simp
+
+lemma tape_of_nl_nil_eq: "<(lm::nat list)> = [] = (lm = [])"
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps)
+apply(case_tac lm, simp add: tape_of_nat_list.simps)
+apply(case_tac "list")
+apply(auto simp: tape_of_nat_list.simps)
+done
+
+lemma rep_ind: "replicate (Suc n) a = replicate n a @ [a]"
+apply(induct n, simp, simp)
+done
+
+lemma [simp]: "Oc # r = <lm::nat list> @ replicate rn Bk \<Longrightarrow> Suc 0 \<le> length lm"
+apply(rule_tac classical, auto)
+apply(case_tac lm, simp, case_tac rn, auto)
+done
+lemma Oc_Bk_Cons: "Oc # Bk # list = <lm::nat list> @ Bk\<^bsup>ln\<^esup> \<Longrightarrow>
+ lm \<noteq> [] \<and> hd lm = 0"
+apply(case_tac lm, simp, case_tac ln, simp add: exponent_def, simp add: exponent_def, simp)
+apply(case_tac lista, auto simp: tape_of_nl_abv tape_of_nat_list.simps)
+done
+(*lemma Oc_Oc_Cons: "Oc # Oc # list = <lm::nat list> @ Bk\<^bsup>ln\<^esup> \<Longrightarrow>
+ lm \<noteq> [] \<and> hd lm > 0"
+apply(case_tac lm, simp add: exponent_def, case_tac ln, simp, simp)
+apply(case_tac lista,
+ auto simp: tape_of_nl_abv tape_of_nat_list.simps exponent_def)
+apply(case_tac [!] a, auto)
+apply(case_tac ln, auto)
+done
+*)
+lemma Oc_nil_zero[simp]: "[Oc] = <lm::nat list> @ Bk\<^bsup>ln\<^esup>
+ \<Longrightarrow> lm = [0] \<and> ln = 0"
+apply(case_tac lm, simp)
+apply(case_tac ln, auto simp: exponent_def)
+apply(case_tac [!] list,
+ auto simp: tape_of_nl_abv tape_of_nat_list.simps)
+done
+
+lemma [simp]: "Oc # r = <lm2> @ replicate rn Bk \<Longrightarrow>
+ (\<exists>rn. r = replicate (hd lm2) Oc @ Bk # <tl lm2> @
+ replicate rn Bk) \<or>
+ tl lm2 = [] \<and> r = replicate (hd lm2) Oc"
+apply(rule_tac disjCI, simp)
+apply(case_tac "tl lm2 = []", simp)
+apply(case_tac lm2, simp add: tape_of_nl_abv tape_of_nat_list.simps)
+apply(case_tac rn, simp, simp, simp)
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps exponent_def)
+apply(case_tac rn, simp, simp)
+apply(rule_tac x = rn in exI)
+apply(simp add: hd_tl_tape_of_nat_list)
+apply(simp add: tape_of_nat_abv Oc_def exponent_def)
+done
+
+(*inv: from locate_a to locate_b*)
+lemma [simp]:
+ "inv_locate_a (as, lm) (q, l, Oc # r) ires
+ \<Longrightarrow> inv_locate_b (as, lm) (q, Oc # l, r) ires"
+apply(simp only: inv_locate_a.simps inv_locate_b.simps in_middle.simps
+ at_begin_norm.simps at_begin_fst_bwtn.simps
+ at_begin_fst_awtn.simps)
+apply(erule disjE, erule exE, erule exE, erule exE)
+apply(rule_tac x = lm1 in exI, rule_tac x = "tl lm2" in exI, simp)
+apply(rule_tac x = "0" in exI, rule_tac x = "hd lm2" in exI,
+ auto simp: exponent_def)
+apply(rule_tac x = "Suc 0" in exI, simp add:exponent_def)
+apply(rule_tac x = "lm @ replicate tn 0" in exI,
+ rule_tac x = "[]" in exI,
+ rule_tac x = "Suc tn" in exI, rule_tac x = 0 in exI)
+apply(simp only: rep_ind, simp)
+apply(rule_tac x = "Suc 0" in exI, auto)
+apply(case_tac [1-3] rn, simp_all )
+apply(rule_tac x = "lm @ replicate tn 0" in exI,
+ rule_tac x = "[]" in exI,
+ rule_tac x = "Suc tn" in exI,
+ rule_tac x = 0 in exI, simp add: rep_ind del: replicate_Suc split:if_splits)
+apply(rule_tac x = "Suc 0" in exI, auto)
+apply(case_tac rn, simp, simp)
+apply(rule_tac [!] x = "Suc 0" in exI, auto)
+apply(case_tac [!] rn, simp_all)
+done
+
+(*inv: from locate_a to _locate_a*)
+lemma locate_a_2_locate_a[simp]: "inv_locate_a (as, am) (q, aaa, Bk # xs) ires
+ \<Longrightarrow> inv_locate_a (as, am) (q, aaa, Oc # xs) ires"
+apply(simp only: inv_locate_a.simps at_begin_norm.simps
+ at_begin_fst_bwtn.simps at_begin_fst_awtn.simps)
+apply(erule_tac disjE, erule exE, erule exE, erule exE,
+ rule disjI2, rule disjI2)
+defer
+apply(erule_tac disjE, erule exE, erule exE,
+ erule exE, rule disjI2, rule disjI2)
+prefer 2
+apply(simp)
+proof-
+ fix lm1 tn rn
+ assume k: "lm1 = am @ 0\<^bsup>tn\<^esup> \<and> length lm1 = q \<and> (if lm1 = [] then aaa = Bk # Bk #
+ ires else aaa = [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and> Bk # xs = Bk\<^bsup>rn\<^esup>"
+ thus "\<exists>lm1 tn rn. lm1 = am @ 0\<^bsup>tn\<^esup> \<and> length lm1 = q \<and> (if lm1 = [] then
+ aaa = Bk # Bk # ires else aaa = [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and> Oc # xs = [Oc] @ Bk\<^bsup>rn\<^esup>"
+ (is "\<exists>lm1 tn rn. ?P lm1 tn rn")
+ proof -
+ from k have "?P lm1 tn (rn - 1)"
+ apply(auto simp: Oc_def)
+ by(case_tac [!] "rn::nat", auto simp: exponent_def)
+ thus ?thesis by blast
+ qed
+next
+ fix lm1 lm2 rn
+ assume h1: "am = lm1 @ lm2 \<and> length lm1 = q \<and> (if lm1 = []
+ then aaa = Bk # Bk # ires else aaa = Bk # <rev lm1> @ Bk # Bk # ires) \<and>
+ Bk # xs = <lm2> @ Bk\<^bsup>rn\<^esup>"
+ from h1 have h2: "lm2 = []"
+ proof(rule_tac xs = xs and rn = rn in BkCons_nil, simp)
+ qed
+ from h1 and h2 show "\<exists>lm1 tn rn. lm1 = am @ 0\<^bsup>tn\<^esup> \<and> length lm1 = q \<and>
+ (if lm1 = [] then aaa = Bk # Bk # ires else aaa = [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and>
+ Oc # xs = [Oc] @ Bk\<^bsup>rn\<^esup>"
+ (is "\<exists>lm1 tn rn. ?P lm1 tn rn")
+ proof -
+ from h1 and h2 have "?P lm1 0 (rn - 1)"
+ apply(auto simp: Oc_def exponent_def
+ tape_of_nl_abv tape_of_nat_list.simps)
+ by(case_tac "rn::nat", simp, simp)
+ thus ?thesis by blast
+ qed
+qed
+
+lemma [intro]: "\<exists>rn. [a] = a\<^bsup>rn\<^esup>"
+by(rule_tac x = "Suc 0" in exI, simp add: exponent_def)
+
+lemma [intro]: "\<exists>tn. [] = a\<^bsup>tn\<^esup>"
+apply(rule_tac x = 0 in exI, simp add: exponent_def)
+done
+
+lemma [intro]: "at_begin_norm (as, am) (q, aaa, []) ires
+ \<Longrightarrow> at_begin_norm (as, am) (q, aaa, [Bk]) ires"
+apply(simp add: at_begin_norm.simps, erule_tac exE, erule_tac exE)
+apply(rule_tac x = lm1 in exI, simp, auto)
+done
+
+lemma [intro]: "at_begin_fst_bwtn (as, am) (q, aaa, []) ires
+ \<Longrightarrow> at_begin_fst_bwtn (as, am) (q, aaa, [Bk]) ires"
+apply(simp only: at_begin_fst_bwtn.simps, erule_tac exE, erule_tac exE, erule_tac exE)
+apply(rule_tac x = "am @ 0\<^bsup>tn\<^esup>" in exI, auto)
+done
+
+lemma [intro]: "at_begin_fst_awtn (as, am) (q, aaa, []) ires
+ \<Longrightarrow> at_begin_fst_awtn (as, am) (q, aaa, [Bk]) ires"
+apply(auto simp: at_begin_fst_awtn.simps)
+done
+
+lemma [intro]: "inv_locate_a (as, am) (q, aaa, []) ires
+ \<Longrightarrow> inv_locate_a (as, am) (q, aaa, [Bk]) ires"
+apply(simp only: inv_locate_a.simps)
+apply(erule disj_forward)
+defer
+apply(erule disj_forward, auto)
+done
+
+lemma [simp]: "inv_locate_a (as, am) (q, aaa, []) ires \<Longrightarrow>
+ inv_locate_a (as, am) (q, aaa, [Oc]) ires"
+apply(insert locate_a_2_locate_a [of as am q aaa "[]"])
+apply(subgoal_tac "inv_locate_a (as, am) (q, aaa, [Bk]) ires", auto)
+done
+
+(*inv: from locate_b to locate_b*)
+lemma [simp]: "inv_locate_b (as, am) (q, aaa, Oc # xs) ires
+ \<Longrightarrow> inv_locate_b (as, am) (q, Oc # aaa, xs) ires"
+apply(simp only: inv_locate_b.simps in_middle.simps)
+apply(erule exE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = tn in exI, rule_tac x = m in exI)
+apply(rule_tac x = "Suc ml" in exI, rule_tac x = "mr - 1" in exI,
+ rule_tac x = rn in exI)
+apply(case_tac mr, simp_all add: exponent_def, auto)
+done
+lemma zero_and_nil[intro]: "(Bk # Bk\<^bsup>n\<^esup> = Oc\<^bsup>mr\<^esup> @ Bk # <lm::nat list> @
+ Bk\<^bsup>rn \<^esup>) \<or> (lm2 = [] \<and> Bk # Bk\<^bsup>n\<^esup> = Oc\<^bsup>mr\<^esup>)
+ \<Longrightarrow> mr = 0 \<and> lm = []"
+apply(rule context_conjI)
+apply(case_tac mr, auto simp:exponent_def)
+apply(insert BkCons_nil[of "replicate (n - 1) Bk" lm rn])
+apply(case_tac n, auto simp: exponent_def Bk_def tape_of_nl_nil_eq)
+done
+
+lemma tape_of_nat_def: "<[m::nat]> = Oc # Oc\<^bsup>m\<^esup>"
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps)
+done
+lemma [simp]: "\<lbrakk>inv_locate_b (as, am) (q, aaa, Bk # xs) ires; \<exists>n. xs = Bk\<^bsup>n\<^esup>\<rbrakk>
+ \<Longrightarrow> inv_locate_a (as, am) (Suc q, Bk # aaa, xs) ires"
+apply(simp add: inv_locate_b.simps inv_locate_a.simps)
+apply(rule_tac disjI2, rule_tac disjI1)
+apply(simp only: in_middle.simps at_begin_fst_bwtn.simps)
+apply(erule_tac exE)+
+apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = tn in exI, simp)
+apply(subgoal_tac "mr = 0 \<and> lm2 = []")
+defer
+apply(rule_tac n = n and mr = mr and lm = "lm2"
+ and rn = rn and n = n in zero_and_nil)
+apply(auto simp: exponent_def)
+apply(case_tac "lm1 = []", auto simp: tape_of_nat_def)
+done
+
+lemma length_equal: "xs = ys \<Longrightarrow> length xs = length ys"
+by auto
+lemma [simp]: "a\<^bsup>0\<^esup> = []"
+by(simp add: exp_zero)
+(*inv: from locate_b to locate_a*)
+lemma [simp]: "length (a\<^bsup>b\<^esup>) = b"
+apply(simp add: exponent_def)
+done
+
+lemma [simp]: "\<lbrakk>inv_locate_b (as, am) (q, aaa, Bk # xs) ires;
+ \<not> (\<exists>n. xs = Bk\<^bsup>n\<^esup>)\<rbrakk>
+ \<Longrightarrow> inv_locate_a (as, am) (Suc q, Bk # aaa, xs) ires"
+apply(simp add: inv_locate_b.simps inv_locate_a.simps)
+apply(rule_tac disjI1)
+apply(simp only: in_middle.simps at_begin_norm.simps)
+apply(erule_tac exE)+
+apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = lm2 in exI, simp)
+apply(subgoal_tac "tn = 0", simp add: exponent_def , auto split: if_splits)
+apply(case_tac [!] mr, simp_all add: tape_of_nat_def, auto)
+apply(case_tac lm2, simp, erule_tac x = rn in allE, simp)
+apply(case_tac am, simp, simp)
+apply(case_tac lm2, simp, erule_tac x = rn in allE, simp)
+apply(drule_tac length_equal, simp)
+done
+
+lemma locate_b_2_a[intro]:
+ "inv_locate_b (as, am) (q, aaa, Bk # xs) ires
+ \<Longrightarrow> inv_locate_a (as, am) (Suc q, Bk # aaa, xs) ires"
+apply(case_tac "\<exists> n. xs = Bk\<^bsup>n\<^esup>", simp, simp)
+done
+
+lemma locate_b_2_locate_a[simp]:
+ "\<lbrakk>\<not> a < start_of ly as;
+ a < start_of ly as + 2 * n;
+ (a - start_of ly as) mod 2 = Suc 0;
+ inv_locate_b (as, am) ((a - start_of ly as) div 2, aaa, Bk # xs) ires\<rbrakk>
+ \<Longrightarrow> (Suc a < start_of ly as + 2 * n \<longrightarrow> inv_locate_a (as, am)
+ (Suc ((a - start_of ly as) div 2), Bk # aaa, xs) ires) \<and>
+ (\<not> Suc a < start_of ly as + 2 * n \<longrightarrow>
+ inv_locate_a (as, am) (n, Bk # aaa, xs) ires)"
+apply(auto)
+apply(subgoal_tac "n > 0")
+apply(subgoal_tac "(a - start_of ly as) div 2 = n - 1")
+apply(insert locate_b_2_a [of as am "n - 1" aaa xs], simp)
+apply(arith)
+apply(case_tac n, simp, simp)
+done
+
+lemma [simp]: "inv_locate_b (as, am) (q, l, []) ires
+ \<Longrightarrow> inv_locate_b (as, am) (q, l, [Bk]) ires"
+apply(simp only: inv_locate_b.simps in_middle.simps)
+apply(erule exE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = tn in exI, rule_tac x = m in exI,
+ rule_tac x = ml in exI, rule_tac x = mr in exI)
+apply(auto)
+done
+
+lemma locate_b_2_locate_a_B[simp]:
+ "\<lbrakk>\<not> a < start_of ly as;
+ a < start_of ly as + 2 * n;
+ (a - start_of ly as) mod 2 = Suc 0;
+ inv_locate_b (as, am) ((a - start_of ly as) div 2, aaa, []) ires\<rbrakk>
+ \<Longrightarrow> (Suc a < start_of ly as + 2 * n \<longrightarrow>
+ inv_locate_a (as, am)
+ (Suc ((a - start_of ly as) div 2), Bk # aaa, []) ires)
+ \<and> (\<not> Suc a < start_of ly as + 2 * n \<longrightarrow>
+ inv_locate_a (as, am) (n, Bk # aaa, []) ires)"
+apply(insert locate_b_2_locate_a [of a ly as n am aaa "[]"], simp)
+done
+
+(*inv: from locate_b to after_write*)
+lemma inv_locate_b_2_after_write[simp]:
+ "inv_locate_b (as, am) (n, aaa, Bk # xs) ires
+ \<Longrightarrow> inv_after_write (as, abc_lm_s am n (Suc (abc_lm_v am n)))
+ (Suc (Suc (2 * n)), aaa, Oc # xs) ires"
+apply(auto simp: in_middle.simps inv_after_write.simps
+ abc_lm_v.simps abc_lm_s.simps inv_locate_b.simps)
+apply(subgoal_tac [!] "mr = 0", auto simp: exponent_def split: if_splits)
+apply(subgoal_tac "lm2 = []", simp)
+apply(rule_tac x = rn in exI, rule_tac x = "Suc m" in exI,
+ rule_tac x = "lm1" in exI, simp, rule_tac x = "[]" in exI, simp)
+apply(case_tac "Suc (length lm1) - length am", simp, simp only: rep_ind, simp)
+apply(subgoal_tac "length lm1 - length am = nat", simp, arith)
+apply(drule_tac length_equal, simp)
+done
+
+lemma [simp]: "inv_locate_b (as, am) (n, aaa, []) ires \<Longrightarrow>
+ inv_after_write (as, abc_lm_s am n (Suc (abc_lm_v am n)))
+ (Suc (Suc (2 * n)), aaa, [Oc]) ires"
+apply(insert inv_locate_b_2_after_write [of as am n aaa "[]"])
+by(simp)
+
+(*inv: from after_write to after_move*)
+lemma [simp]: "inv_after_write (as, lm) (Suc (Suc (2 * n)), l, Oc # r) ires
+ \<Longrightarrow> inv_after_move (as, lm) (2 * n + 3, Oc # l, r) ires"
+apply(auto simp:inv_after_move.simps inv_after_write.simps split: if_splits)
+done
+
+lemma [simp]: "inv_after_write (as, abc_lm_s am n (Suc (abc_lm_v am n)
+ )) (Suc (Suc (2 * n)), aaa, Bk # xs) ires = False"
+apply(simp add: inv_after_write.simps )
+done
+
+lemma [simp]:
+ "inv_after_write (as, abc_lm_s am n (Suc (abc_lm_v am n)))
+ (Suc (Suc (2 * n)), aaa, []) ires = False"
+apply(simp add: inv_after_write.simps )
+done
+
+(*inv: from after_move to after_clear*)
+lemma [simp]: "inv_after_move (as, lm) (s, l, Oc # r) ires
+ \<Longrightarrow> inv_after_clear (as, lm) (s', l, Bk # r) ires"
+apply(auto simp: inv_after_move.simps inv_after_clear.simps split: if_splits)
+done
+
+(*inv: from after_move to on_leftmoving*)
+lemma inv_after_move_2_inv_on_left_moving[simp]:
+ "inv_after_move (as, lm) (s, l, Bk # r) ires
+ \<Longrightarrow> (l = [] \<longrightarrow>
+ inv_on_left_moving (as, lm) (s', [], Bk # Bk # r) ires) \<and>
+ (l \<noteq> [] \<longrightarrow>
+ inv_on_left_moving (as, lm) (s', tl l, hd l # Bk # r) ires)"
+apply(simp only: inv_after_move.simps inv_on_left_moving.simps)
+apply(subgoal_tac "l \<noteq> []", rule conjI, simp, rule impI,
+ rule disjI1, simp only: inv_on_left_moving_norm.simps)
+apply(erule exE)+
+apply(subgoal_tac "lm2 = []")
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, rule_tac x = m in exI,
+ rule_tac x = 1 in exI,
+ rule_tac x = "rn - 1" in exI, simp, case_tac rn)
+apply(auto simp: exponent_def intro: BkCons_nil split: if_splits)
+done
+
+lemma [elim]: "[] = <lm::nat list> \<Longrightarrow> lm = []"
+using tape_of_nl_nil_eq[of lm]
+by simp
+
+lemma inv_after_move_2_inv_on_left_moving_B[simp]:
+ "inv_after_move (as, lm) (s, l, []) ires
+ \<Longrightarrow> (l = [] \<longrightarrow> inv_on_left_moving (as, lm) (s', [], [Bk]) ires) \<and>
+ (l \<noteq> [] \<longrightarrow> inv_on_left_moving (as, lm) (s', tl l, [hd l]) ires)"
+apply(simp only: inv_after_move.simps inv_on_left_moving.simps)
+apply(subgoal_tac "l \<noteq> []", rule conjI, simp, rule impI, rule disjI1,
+ simp only: inv_on_left_moving_norm.simps)
+apply(erule exE)+
+apply(subgoal_tac "lm2 = []")
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, rule_tac x = m in exI,
+ rule_tac x = 1 in exI, rule_tac x = "rn - 1" in exI, simp, case_tac rn)
+apply(auto simp: exponent_def tape_of_nl_nil_eq intro: BkCons_nil split: if_splits)
+done
+
+(*inv: from after_clear to on_right_moving*)
+lemma [simp]: "Oc # r = replicate rn Bk = False"
+apply(case_tac rn, simp, simp)
+done
+
+lemma inv_after_clear_2_inv_on_right_moving[simp]:
+ "inv_after_clear (as, lm) (2 * n + 4, l, Bk # r) ires
+ \<Longrightarrow> inv_on_right_moving (as, lm) (2 * n + 5, Bk # l, r) ires"
+apply(auto simp: inv_after_clear.simps inv_on_right_moving.simps )
+apply(subgoal_tac "lm2 \<noteq> []")
+apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = "tl lm2" in exI,
+ rule_tac x = "hd lm2" in exI, simp)
+apply(rule_tac x = 0 in exI, rule_tac x = "hd lm2" in exI)
+apply(simp add: exponent_def, rule conjI)
+apply(case_tac [!] "lm2::nat list", auto simp: exponent_def)
+apply(case_tac rn, auto split: if_splits simp: tape_of_nat_def)
+apply(case_tac list,
+ simp add: tape_of_nl_abv tape_of_nat_list.simps exponent_def)
+apply(erule_tac x = "rn - 1" in allE,
+ case_tac rn, auto simp: exponent_def)
+apply(case_tac list,
+ simp add: tape_of_nl_abv tape_of_nat_list.simps exponent_def)
+apply(erule_tac x = "rn - 1" in allE,
+ case_tac rn, auto simp: exponent_def)
+done
+
+
+lemma [simp]: "inv_after_clear (as, lm) (2 * n + 4, l, []) ires\<Longrightarrow>
+ inv_after_clear (as, lm) (2 * n + 4, l, [Bk]) ires"
+by(auto simp: inv_after_clear.simps)
+
+lemma [simp]: "inv_after_clear (as, lm) (2 * n + 4, l, []) ires
+ \<Longrightarrow> inv_on_right_moving (as, lm) (2 * n + 5, Bk # l, []) ires"
+by(insert
+ inv_after_clear_2_inv_on_right_moving[of as lm n l "[]"], simp)
+
+(*inv: from on_right_moving to on_right_movign*)
+lemma [simp]: "inv_on_right_moving (as, lm) (2 * n + 5, l, Oc # r) ires
+ \<Longrightarrow> inv_on_right_moving (as, lm) (2 * n + 5, Oc # l, r) ires"
+apply(auto simp: inv_on_right_moving.simps)
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = "ml + mr" in exI, simp)
+apply(rule_tac x = "Suc ml" in exI,
+ rule_tac x = "mr - 1" in exI, simp)
+apply(case_tac mr, auto simp: exponent_def )
+apply(rule_tac x = lm1 in exI, rule_tac x = "[]" in exI,
+ rule_tac x = "ml + mr" in exI, simp)
+apply(rule_tac x = "Suc ml" in exI,
+ rule_tac x = "mr - 1" in exI, simp)
+apply(case_tac mr, auto split: if_splits simp: exponent_def)
+done
+
+lemma inv_on_right_moving_2_inv_on_right_moving[simp]:
+ "inv_on_right_moving (as, lm) (2 * n + 5, l, Bk # r) ires
+ \<Longrightarrow> inv_after_write (as, lm) (Suc (Suc (2 * n)), l, Oc # r) ires"
+apply(auto simp: inv_on_right_moving.simps inv_after_write.simps )
+apply(case_tac mr, auto simp: exponent_def split: if_splits)
+apply(case_tac [!] mr, simp_all)
+done
+
+lemma [simp]: "inv_on_right_moving (as, lm) (2 * n + 5, l, []) ires\<Longrightarrow>
+ inv_on_right_moving (as, lm) (2 * n + 5, l, [Bk]) ires"
+apply(auto simp: inv_on_right_moving.simps exponent_def)
+apply(rule_tac x = lm1 in exI, rule_tac x = "[]" in exI, simp)
+apply (rule_tac x = m in exI, auto split: if_splits simp: exponent_def)
+done
+
+(*inv: from on_right_moving to after_write*)
+lemma [simp]: "inv_on_right_moving (as, lm) (2 * n + 5, l, []) ires
+ \<Longrightarrow> inv_after_write (as, lm) (Suc (Suc (2 * n)), l, [Oc]) ires"
+apply(rule_tac inv_on_right_moving_2_inv_on_right_moving, simp)
+done
+
+(*inv: from on_left_moving to on_left_moving*)
+lemma [simp]: "inv_on_left_moving_in_middle_B (as, lm)
+ (s, l, Oc # r) ires = False"
+apply(auto simp: inv_on_left_moving_in_middle_B.simps )
+done
+
+lemma [simp]: "inv_on_left_moving_norm (as, lm) (s, l, Bk # r) ires
+ = False"
+apply(auto simp: inv_on_left_moving_norm.simps)
+apply(case_tac [!] mr, auto simp: )
+done
+
+lemma [intro]: "\<exists>rna. Oc # Oc\<^bsup>m\<^esup> @ Bk # <lm> @ Bk\<^bsup>rn\<^esup> = <m # lm> @ Bk\<^bsup>rna\<^esup>"
+apply(case_tac lm, simp add: tape_of_nl_abv tape_of_nat_list.simps)
+apply(rule_tac x = "Suc rn" in exI, simp)
+apply(case_tac list, simp_all add: tape_of_nl_abv tape_of_nat_list.simps, auto)
+done
+
+
+lemma [simp]:
+ "\<lbrakk>inv_on_left_moving_norm (as, lm) (s, l, Oc # r) ires;
+ hd l = Bk; l \<noteq> []\<rbrakk> \<Longrightarrow>
+ inv_on_left_moving_in_middle_B (as, lm) (s, tl l, Bk # Oc # r) ires"
+apply(case_tac l, simp, simp)
+apply(simp only: inv_on_left_moving_norm.simps
+ inv_on_left_moving_in_middle_B.simps)
+apply(erule_tac exE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = "m # lm2" in exI, auto)
+apply(case_tac [!] ml, auto)
+apply(rule_tac [!] x = 0 in exI, simp_all add: tape_of_nl_abv tape_of_nat_list.simps)
+done
+
+lemma [simp]: "\<lbrakk>inv_on_left_moving_norm (as, lm) (s, l, Oc # r) ires;
+ hd l = Oc; l \<noteq> []\<rbrakk>
+ \<Longrightarrow> inv_on_left_moving_norm (as, lm)
+ (s, tl l, Oc # Oc # r) ires"
+apply(simp only: inv_on_left_moving_norm.simps)
+apply(erule exE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, rule_tac x = "ml - 1" in exI,
+ rule_tac x = "Suc mr" in exI, rule_tac x = rn in exI, simp)
+apply(case_tac ml, auto simp: exponent_def split: if_splits)
+done
+
+lemma [simp]: "inv_on_left_moving_norm (as, lm) (s, [], Oc # r) ires
+ \<Longrightarrow> inv_on_left_moving_in_middle_B (as, lm) (s, [], Bk # Oc # r) ires"
+apply(auto simp: inv_on_left_moving_norm.simps
+ inv_on_left_moving_in_middle_B.simps split: if_splits)
+done
+
+lemma [simp]:"inv_on_left_moving (as, lm) (s, l, Oc # r) ires
+ \<Longrightarrow> (l = [] \<longrightarrow> inv_on_left_moving (as, lm) (s, [], Bk # Oc # r) ires)
+ \<and> (l \<noteq> [] \<longrightarrow> inv_on_left_moving (as, lm) (s, tl l, hd l # Oc # r) ires)"
+apply(simp add: inv_on_left_moving.simps)
+apply(case_tac "l \<noteq> []", rule conjI, simp, simp)
+apply(case_tac "hd l", simp, simp, simp)
+done
+
+(*inv: from on_left_moving to check_left_moving*)
+lemma [simp]: "inv_on_left_moving_in_middle_B (as, lm)
+ (s, Bk # list, Bk # r) ires
+ \<Longrightarrow> inv_check_left_moving_on_leftmost (as, lm)
+ (s', list, Bk # Bk # r) ires"
+apply(auto simp: inv_on_left_moving_in_middle_B.simps
+ inv_check_left_moving_on_leftmost.simps split: if_splits)
+apply(case_tac [!] "rev lm1", simp_all)
+apply(case_tac [!] lista, simp_all add: tape_of_nl_abv tape_of_nat_list.simps)
+done
+
+lemma [simp]:
+ "inv_check_left_moving_in_middle (as, lm) (s, l, Bk # r) ires= False"
+by(auto simp: inv_check_left_moving_in_middle.simps )
+
+lemma [simp]:
+ "inv_on_left_moving_in_middle_B (as, lm) (s, [], Bk # r) ires\<Longrightarrow>
+ inv_check_left_moving_on_leftmost (as, lm) (s', [], Bk # Bk # r) ires"
+apply(auto simp: inv_on_left_moving_in_middle_B.simps
+ inv_check_left_moving_on_leftmost.simps split: if_splits)
+done
+
+
+lemma [simp]: "inv_check_left_moving_on_leftmost (as, lm)
+ (s, list, Oc # r) ires= False"
+by(auto simp: inv_check_left_moving_on_leftmost.simps split: if_splits)
+
+lemma [simp]: "inv_on_left_moving_in_middle_B (as, lm)
+ (s, Oc # list, Bk # r) ires
+ \<Longrightarrow> inv_check_left_moving_in_middle (as, lm) (s', list, Oc # Bk # r) ires"
+apply(auto simp: inv_on_left_moving_in_middle_B.simps
+ inv_check_left_moving_in_middle.simps split: if_splits)
+done
+
+lemma inv_on_left_moving_2_check_left_moving[simp]:
+ "inv_on_left_moving (as, lm) (s, l, Bk # r) ires
+ \<Longrightarrow> (l = [] \<longrightarrow> inv_check_left_moving (as, lm) (s', [], Bk # Bk # r) ires)
+ \<and> (l \<noteq> [] \<longrightarrow>
+ inv_check_left_moving (as, lm) (s', tl l, hd l # Bk # r) ires)"
+apply(simp add: inv_on_left_moving.simps inv_check_left_moving.simps)
+apply(case_tac l, simp, simp)
+apply(case_tac a, simp, simp)
+done
+
+lemma [simp]: "inv_on_left_moving_norm (as, lm) (s, l, []) ires = False"
+apply(auto simp: inv_on_left_moving_norm.simps)
+by(case_tac [!] mr, auto)
+
+lemma [simp]: "inv_on_left_moving (as, lm) (s, l, []) ires\<Longrightarrow>
+ inv_on_left_moving (as, lm) (6 + 2 * n, l, [Bk]) ires"
+apply(simp add: inv_on_left_moving.simps)
+apply(auto simp: inv_on_left_moving_in_middle_B.simps)
+done
+
+lemma [simp]: "inv_on_left_moving (as, lm) (s, l, []) ires = False"
+apply(simp add: inv_on_left_moving.simps)
+apply(simp add: inv_on_left_moving_in_middle_B.simps)
+done
+
+lemma [simp]: "inv_on_left_moving (as, lm) (s, l, []) ires
+ \<Longrightarrow> (l = [] \<longrightarrow> inv_check_left_moving (as, lm) (s', [], [Bk]) ires) \<and>
+ (l \<noteq> [] \<longrightarrow> inv_check_left_moving (as, lm) (s', tl l, [hd l]) ires)"
+by simp
+
+lemma Oc_Bk_Cons_ex[simp]:
+ "Oc # Bk # list = <lm::nat list> @ Bk\<^bsup>ln\<^esup> \<Longrightarrow>
+ \<exists>ln. list = <tl (lm)> @ Bk\<^bsup>ln\<^esup>"
+apply(case_tac "lm", simp)
+apply(case_tac ln, simp_all add: exponent_def)
+apply(case_tac lista,
+ auto simp: tape_of_nl_abv tape_of_nat_list.simps exponent_def)
+apply(case_tac [!] a, auto simp: )
+apply(case_tac ln, simp, rule_tac x = nat in exI, simp)
+done
+
+lemma [simp]:
+ "Oc # Bk # list = <rev lm1::nat list> @ Bk\<^bsup>ln\<^esup> \<Longrightarrow>
+ \<exists>rna. Oc # Bk # <lm2> @ Bk\<^bsup>rn\<^esup> = <hd (rev lm1) # lm2> @ Bk\<^bsup>rna\<^esup>"
+apply(frule Oc_Bk_Cons, simp)
+apply(case_tac lm2,
+ auto simp: tape_of_nl_abv tape_of_nat_list.simps exponent_def )
+apply(rule_tac x = "Suc rn" in exI, simp)
+done
+
+(*inv: from check_left_moving to on_left_moving*)
+lemma [intro]: "\<exists>rna. a # a\<^bsup>rn\<^esup> = a\<^bsup>rna\<^esup>"
+apply(rule_tac x = "Suc rn" in exI, simp)
+done
+
+lemma
+inv_check_left_moving_in_middle_2_on_left_moving_in_middle_B[simp]:
+"inv_check_left_moving_in_middle (as, lm) (s, Bk # list, Oc # r) ires
+ \<Longrightarrow> inv_on_left_moving_in_middle_B (as, lm) (s', list, Bk # Oc # r) ires"
+apply(simp only: inv_check_left_moving_in_middle.simps
+ inv_on_left_moving_in_middle_B.simps)
+apply(erule_tac exE)+
+apply(rule_tac x = "rev (tl (rev lm1))" in exI,
+ rule_tac x = "[hd (rev lm1)] @ lm2" in exI, auto)
+apply(case_tac [!] "rev lm1",simp_all add: tape_of_nl_abv tape_of_nat_list.simps)
+apply(case_tac [!] a, simp_all)
+apply(case_tac [1] lm2, simp_all add: tape_of_nat_list.simps, auto)
+apply(case_tac [3] lm2, simp_all add: tape_of_nat_list.simps, auto)
+apply(case_tac [!] lista, simp_all add: tape_of_nat_list.simps)
+done
+
+lemma [simp]:
+ "inv_check_left_moving_in_middle (as, lm) (s, [], Oc # r) ires\<Longrightarrow>
+ inv_check_left_moving_in_middle (as, lm) (s', [Bk], Oc # r) ires"
+apply(auto simp: inv_check_left_moving_in_middle.simps )
+done
+
+lemma [simp]:
+ "inv_check_left_moving_in_middle (as, lm) (s, [], Oc # r) ires
+ \<Longrightarrow> inv_on_left_moving_in_middle_B (as, lm) (s', [], Bk # Oc # r) ires"
+apply(insert
+inv_check_left_moving_in_middle_2_on_left_moving_in_middle_B[of
+ as lm n "[]" r], simp)
+done
+
+lemma [simp]: "a\<^bsup>0\<^esup> = []"
+apply(simp add: exponent_def)
+done
+
+lemma [simp]: "inv_check_left_moving_in_middle (as, lm)
+ (s, Oc # list, Oc # r) ires
+ \<Longrightarrow> inv_on_left_moving_norm (as, lm) (s', list, Oc # Oc # r) ires"
+apply(auto simp: inv_check_left_moving_in_middle.simps
+ inv_on_left_moving_norm.simps)
+apply(rule_tac x = "rev (tl (rev lm1))" in exI,
+ rule_tac x = lm2 in exI, rule_tac x = "hd (rev lm1)" in exI)
+apply(rule_tac conjI)
+apply(case_tac "rev lm1", simp, simp)
+apply(rule_tac x = "hd (rev lm1) - 1" in exI, auto)
+apply(rule_tac [!] x = "Suc (Suc 0)" in exI, simp)
+apply(case_tac [!] "rev lm1", simp_all)
+apply(case_tac [!] a, simp_all add: tape_of_nl_abv tape_of_nat_list.simps, auto)
+done
+
+lemma [simp]: "inv_check_left_moving (as, lm) (s, l, Oc # r) ires
+\<Longrightarrow> (l = [] \<longrightarrow> inv_on_left_moving (as, lm) (s', [], Bk # Oc # r) ires) \<and>
+ (l \<noteq> [] \<longrightarrow> inv_on_left_moving (as, lm) (s', tl l, hd l # Oc # r) ires)"
+apply(case_tac l,
+ auto simp: inv_check_left_moving.simps inv_on_left_moving.simps)
+apply(case_tac a, simp, simp)
+done
+
+(*inv: check_left_moving to after_left_moving*)
+lemma [simp]: "inv_check_left_moving (as, lm) (s, l, Bk # r) ires
+ \<Longrightarrow> inv_after_left_moving (as, lm) (s', Bk # l, r) ires"
+apply(auto simp: inv_check_left_moving.simps
+ inv_check_left_moving_on_leftmost.simps inv_after_left_moving.simps)
+done
+
+
+lemma [simp]:"inv_check_left_moving (as, lm) (s, l, []) ires
+ \<Longrightarrow> inv_after_left_moving (as, lm) (s', Bk # l, []) ires"
+by(simp add: inv_check_left_moving.simps
+inv_check_left_moving_in_middle.simps
+inv_check_left_moving_on_leftmost.simps)
+
+(*inv: after_left_moving to inv_stop*)
+lemma [simp]: "inv_after_left_moving (as, lm) (s, l, Bk # r) ires
+ \<Longrightarrow> inv_stop (as, lm) (s', Bk # l, r) ires"
+apply(auto simp: inv_after_left_moving.simps inv_stop.simps)
+done
+
+lemma [simp]: "inv_after_left_moving (as, lm) (s, l, []) ires
+ \<Longrightarrow> inv_stop (as, lm) (s', Bk # l, []) ires"
+by(auto simp: inv_after_left_moving.simps)
+
+(*inv: stop to stop*)
+lemma [simp]: "inv_stop (as, lm) (x, l, r) ires \<Longrightarrow>
+ inv_stop (as, lm) (y, l, r) ires"
+apply(simp add: inv_stop.simps)
+done
+
+lemma [simp]: "inv_after_clear (as, lm) (s, aaa, Oc # xs) ires= False"
+apply(auto simp: inv_after_clear.simps )
+done
+
+lemma [simp]:
+ "inv_after_left_moving (as, lm) (s, aaa, Oc # xs) ires = False"
+by(auto simp: inv_after_left_moving.simps )
+
+lemma start_of_not0: "as \<noteq> 0 \<Longrightarrow> start_of ly as > 0"
+apply(rule startof_not0)
+done
+
+text {*
+ The single step currectness of the TM complied from Abacus instruction @{text "Inc n"}.
+ It shows every single step execution of this TM keeps the invariant.
+*}
+
+lemma inc_inv_step:
+ assumes
+ -- {* Invariant holds on the start *}
+ h11: "inc_inv ly n (as, am) tc ires"
+ -- {* The layout of Abacus program @{text "aprog"} is @{text "ly"} *}
+ and h12: "ly = layout_of aprog"
+ -- {* The instruction at position @{text "as"} is @{text "Inc n"} *}
+ and h21: "abc_fetch as aprog = Some (Inc n)"
+ -- {* TM not yet reach the final state, where @{text "start_of ly as + 2*n + 9"} is the state
+ where the current TM stops and the next TM starts. *}
+ and h22: "(\<lambda> (s, l, r). s \<noteq> start_of ly as + 2*n + 9) tc"
+ shows
+ -- {*
+ Single step execution of the TM keeps the invaraint, where
+ the TM compiled from @{text "Inc n"} is @{text "(ci ly (start_of ly as) (Inc n))"}
+ @{text "start_of ly as - Suc 0)"} is the offset used to execute this {\em shifted}
+ TM.
+ *}
+ "inc_inv ly n (as, am) (t_step tc (ci ly (start_of ly as) (Inc n), start_of ly as - Suc 0)) ires"
+proof -
+ from h21 h22 have h3 : "start_of (layout_of aprog) as > 0"
+ apply(case_tac as, simp add: start_of.simps abc_fetch.simps)
+ apply(insert start_of_not0[of as "layout_of aprog"], simp)
+ done
+ from h11 h12 and h21 h22 and this show ?thesis
+ apply(case_tac tc, simp)
+ apply(case_tac "a = 0",
+ auto split:if_splits simp add:t_step.simps,
+ tactic {* ALLGOALS (resolve_tac [@{thm fetch_intro}]) *})
+ apply (simp_all add:fetch_simps new_tape.simps)
+ done
+qed
+
+
+lemma t_steps_ind: "t_steps tc (p, off) (Suc n)
+ = t_step (t_steps tc (p, off) n) (p, off)"
+apply(induct n arbitrary: tc)
+apply(simp add: t_steps.simps)
+apply(simp add: t_steps.simps)
+done
+
+definition lex_pair :: "((nat \<times> nat) \<times> (nat \<times> nat)) set"
+ where
+ "lex_pair \<equiv> 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 lex_square ::
+ "((nat \<times> nat \<times> nat \<times> nat) \<times> (nat \<times> nat \<times> nat \<times> nat)) set"
+ where "lex_square \<equiv> less_than <*lex*> lex_triple"
+
+fun abc_inc_stage1 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_inc_stage1 (s, l, r) ss n =
+ (if s = 0 then 0
+ else if s \<le> ss+2*n+1 then 5
+ else if s\<le> ss+2*n+5 then 4
+ else if s \<le> ss+2*n+7 then 3
+ else if s = ss+2*n+8 then 2
+ else 1)"
+
+fun abc_inc_stage2 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_inc_stage2 (s, l, r) ss n =
+ (if s \<le> ss + 2*n + 1 then 0
+ else if s = ss + 2*n + 2 then length r
+ else if s = ss + 2*n + 3 then length r
+ else if s = ss + 2*n + 4 then length r
+ else if s = ss + 2*n + 5 then
+ if r \<noteq> [] then length r
+ else 1
+ else if s = ss+2*n+6 then length l
+ else if s = ss+2*n+7 then length l
+ else 0)"
+
+fun abc_inc_stage3 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> block list \<Rightarrow> nat"
+ where
+ "abc_inc_stage3 (s, l, r) ss n ires = (
+ if s = ss + 2*n + 3 then 4
+ else if s = ss + 2*n + 4 then 3
+ else if s = ss + 2*n + 5 then
+ if r \<noteq> [] \<and> hd r = Oc then 2
+ else 1
+ else if s = ss + 2*n + 2 then 0
+ else if s = ss + 2*n + 6 then
+ if l = Bk # ires \<and> r \<noteq> [] \<and> hd r = Oc then 2
+ else 1
+ else if s = ss + 2*n + 7 then
+ if r \<noteq> [] \<and> hd r = Oc then 3
+ else 0
+ else ss+2*n+9 - s)"
+
+fun abc_inc_stage4 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> block list \<Rightarrow> nat"
+ where
+ "abc_inc_stage4 (s, l, r) ss n ires =
+ (if s \<le> ss+2*n+1 \<and> (s - ss) mod 2 = 0 then
+ if (r\<noteq>[] \<and> hd r = Oc) then 0
+ else 1
+ else if (s \<le> ss+2*n+1 \<and> (s - ss) mod 2 = Suc 0)
+ then length r
+ else if s = ss + 2*n + 6 then
+ if l = Bk # ires \<and> hd r = Bk then 0
+ else Suc (length l)
+ else 0)"
+
+fun abc_inc_measure :: "(t_conf \<times> nat \<times> nat \<times> block list) \<Rightarrow>
+ (nat \<times> nat \<times> nat \<times> nat)"
+ where
+ "abc_inc_measure (c, ss, n, ires) =
+ (abc_inc_stage1 c ss n, abc_inc_stage2 c ss n,
+ abc_inc_stage3 c ss n ires, abc_inc_stage4 c ss n ires)"
+
+definition abc_inc_LE :: "(((nat \<times> block list \<times> block list) \<times> nat \<times>
+ nat \<times> block list) \<times> ((nat \<times> block list \<times> block list) \<times> nat \<times> nat \<times> block list)) set"
+ where "abc_inc_LE \<equiv> (inv_image lex_square abc_inc_measure)"
+
+lemma wf_lex_triple: "wf lex_triple"
+by (auto intro:wf_lex_prod simp:lex_triple_def lex_pair_def)
+
+lemma wf_lex_square: "wf lex_square"
+by (auto intro:wf_lex_triple simp:lex_triple_def lex_square_def lex_pair_def)
+
+lemma wf_abc_inc_le[intro]: "wf abc_inc_LE"
+by(auto intro:wf_inv_image wf_lex_square simp:abc_inc_LE_def)
+
+(********************************************************************)
+declare inc_inv.simps[simp del]
+
+lemma halt_lemma2':
+ "\<lbrakk>wf LE; \<forall> n. ((\<not> P (f n) \<and> Q (f n)) \<longrightarrow>
+ (Q (f (Suc n)) \<and> (f (Suc n), (f n)) \<in> LE)); Q (f 0)\<rbrakk>
+ \<Longrightarrow> \<exists> n. P (f n)"
+apply(intro exCI, simp)
+apply(subgoal_tac "\<forall> n. Q (f n)", simp)
+apply(drule_tac f = f in wf_inv_image)
+apply(simp add: inv_image_def)
+apply(erule wf_induct, simp)
+apply(erule_tac x = x in allE)
+apply(erule_tac x = n in allE, erule_tac x = n in allE)
+apply(erule_tac x = "Suc x" in allE, simp)
+apply(rule_tac allI)
+apply(induct_tac n, simp)
+apply(erule_tac x = na in allE, simp)
+done
+
+lemma halt_lemma2'':
+ "\<lbrakk>P (f n); \<not> P (f (0::nat))\<rbrakk> \<Longrightarrow>
+ \<exists> n. (P (f n) \<and> (\<forall> i < n. \<not> P (f i)))"
+apply(induct n rule: nat_less_induct, auto)
+done
+
+lemma halt_lemma2''':
+ "\<lbrakk>\<forall>n. \<not> P (f n) \<and> Q (f n) \<longrightarrow> Q (f (Suc n)) \<and> (f (Suc n), f n) \<in> LE;
+ Q (f 0); \<forall>i<na. \<not> P (f i)\<rbrakk> \<Longrightarrow> Q (f na)"
+apply(induct na, simp, simp)
+done
+
+lemma halt_lemma2:
+ "\<lbrakk>wf LE;
+ \<forall> n. ((\<not> P (f n) \<and> Q (f n)) \<longrightarrow> (Q (f (Suc n)) \<and> (f (Suc n), (f n)) \<in> LE));
+ Q (f 0); \<not> P (f 0)\<rbrakk>
+ \<Longrightarrow> \<exists> n. P (f n) \<and> Q (f n)"
+apply(insert halt_lemma2' [of LE P f Q], simp, erule_tac exE)
+apply(subgoal_tac "\<exists> n. (P (f n) \<and> (\<forall> i < n. \<not> P (f i)))")
+apply(erule_tac exE)+
+apply(rule_tac x = na in exI, auto)
+apply(rule halt_lemma2''', simp, simp, simp)
+apply(erule_tac halt_lemma2'', simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>ly = layout_of aprog; abc_fetch as aprog = Some (Inc n)\<rbrakk>
+ \<Longrightarrow> start_of ly (Suc as) = start_of ly as + 2*n +9"
+apply(case_tac as, auto simp: abc_fetch.simps start_of.simps
+ layout_of.simps length_of.simps split: if_splits)
+done
+
+lemma inc_inv_init:
+ "\<lbrakk>abc_fetch as aprog = Some (Inc n);
+ crsp_l ly (as, am) (start_of ly as, l, r) ires; ly = layout_of aprog\<rbrakk>
+ \<Longrightarrow> inc_inv ly n (as, am) (start_of ly as, l, r) ires"
+apply(auto simp: crsp_l.simps inc_inv.simps
+ inv_locate_a.simps at_begin_fst_bwtn.simps
+ at_begin_fst_awtn.simps at_begin_norm.simps )
+apply(auto intro: startof_not0)
+done
+
+lemma inc_inv_stop_pre[simp]:
+ "\<lbrakk>ly = layout_of aprog; inc_inv ly n (as, am) (s, l, r) ires;
+ s = start_of ly as; abc_fetch as aprog = Some (Inc n)\<rbrakk>
+ \<Longrightarrow> (\<forall>na. \<not> (\<lambda>((s, l, r), ss, n', ires'). s = start_of ly (Suc as))
+ (t_steps (s, l, r) (ci ly (start_of ly as)
+ (Inc n), start_of ly as - Suc 0) na, s, n, ires) \<and>
+ (\<lambda>((s, l, r), ss, n', ires'). inc_inv ly n (as, am) (s, l, r) ires')
+ (t_steps (s, l, r) (ci ly (start_of ly as)
+ (Inc n), start_of ly as - Suc 0) na, s, n, ires) \<longrightarrow>
+ (\<lambda>((s, l, r), ss, n', ires'). inc_inv ly n (as, am) (s, l, r) ires')
+ (t_steps (s, l, r) (ci ly (start_of ly as)
+ (Inc n), start_of ly as - Suc 0) (Suc na), s, n, ires) \<and>
+ ((t_steps (s, l, r) (ci ly (start_of ly as) (Inc n),
+ start_of ly as - Suc 0) (Suc na), s, n, ires),
+ t_steps (s, l, r) (ci ly (start_of ly as)
+ (Inc n), start_of ly as - Suc 0) na, s, n, ires) \<in> abc_inc_LE)"
+apply(rule allI, rule impI, simp add: t_steps_ind,
+ rule conjI, erule_tac conjE)
+apply(rule_tac inc_inv_step, simp, simp, simp)
+apply(case_tac "t_steps (start_of (layout_of aprog) as, l, r) (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n), start_of (layout_of aprog) as - Suc 0) na", simp)
+proof -
+ fix na
+ assume h1: "abc_fetch as aprog = Some (Inc n)"
+ "\<not> (\<lambda>(s, l, r) (ss, n', ires'). s = start_of (layout_of aprog) as + 2 * n + 9)
+ (t_steps (start_of (layout_of aprog) as, l, r) (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n), start_of (layout_of aprog) as - Suc 0) na)
+ (start_of (layout_of aprog) as, n, ires) \<and>
+ inc_inv (layout_of aprog) n (as, am) (t_steps (start_of (layout_of aprog) as, l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Inc n), start_of (layout_of aprog) as - Suc 0) na) ires"
+ from h1 have h2: "start_of (layout_of aprog) as > 0"
+ apply(rule_tac startof_not0)
+ done
+ from h1 and h2 show "((t_step (t_steps (start_of (layout_of aprog) as, l, r) (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n), start_of (layout_of aprog) as - Suc 0) na)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Inc n), start_of (layout_of aprog) as - Suc 0),
+ start_of (layout_of aprog) as, n, ires),
+ t_steps (start_of (layout_of aprog) as, l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Inc n), start_of (layout_of aprog) as - Suc 0) na,
+ start_of (layout_of aprog) as, n, ires)
+ \<in> abc_inc_LE"
+ apply(case_tac "(t_steps (start_of (layout_of aprog) as, l, r)
+ (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n),
+ start_of (layout_of aprog) as - Suc 0) na)", simp)
+ apply(case_tac "a = 0",
+ auto split:if_splits simp add:t_step.simps inc_inv.simps,
+ tactic {* ALLGOALS (resolve_tac [@{thm fetch_intro}]) *})
+ apply(simp_all add:fetch_simps new_tape.simps)
+ apply(auto simp add: abc_inc_LE_def
+ lex_square_def lex_triple_def lex_pair_def
+ inv_after_write.simps inv_after_move.simps inv_after_clear.simps
+ inv_on_left_moving.simps inv_on_left_moving_norm.simps split: if_splits)
+ done
+qed
+
+lemma inc_inv_stop_pre1:
+ "\<lbrakk>
+ ly = layout_of aprog;
+ abc_fetch as aprog = Some (Inc n);
+ s = start_of ly as;
+ inc_inv ly n (as, am) (s, l, r) ires
+ \<rbrakk> \<Longrightarrow>
+ (\<exists> stp > 0. (\<lambda> (s', l', r').
+ s' = start_of ly (Suc as) \<and>
+ inc_inv ly n (as, am) (s', l', r') ires)
+ (t_steps (s, l, r) (ci ly (start_of ly as) (Inc n),
+ start_of ly as - Suc 0) stp))"
+apply(insert halt_lemma2[of abc_inc_LE
+ "\<lambda> ((s, l, r), ss, n', ires'). s = start_of ly (Suc as)"
+ "(\<lambda> stp. (t_steps (s, l, r)
+ (ci ly (start_of ly as) (Inc n),
+ start_of ly as - Suc 0) stp, s, n, ires))"
+ "\<lambda> ((s, l, r), ss, n'). inc_inv ly n (as, am) (s, l, r) ires"])
+apply(insert wf_abc_inc_le)
+apply(insert inc_inv_stop_pre[of ly aprog n as am s l r ires], simp)
+apply(simp only: t_steps.simps, auto)
+apply(rule_tac x = na in exI)
+apply(case_tac "(t_steps (start_of (layout_of aprog) as, l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Inc n), start_of (layout_of aprog) as - Suc 0) na)", simp)
+apply(case_tac na, simp add: t_steps.simps, simp)
+done
+
+lemma inc_inv_stop:
+ assumes program_and_layout:
+ -- {* There is an Abacus program @{text "aprog"} and its layout is @{text "ly"}: *}
+ "ly = layout_of aprog"
+ and an_instruction:
+ -- {* There is an instruction @{text "Inc n"} at postion @{text "as"} of @{text "aprog"} *}
+ "abc_fetch as aprog = Some (Inc n)"
+ and the_start_state:
+ -- {* According to @{text "ly"} and @{text "as"},
+ the start state of the TM compiled from this
+ @{text "Inc n"} instruction should be @{text "s"}:
+ *}
+ "s = start_of ly as"
+ and inv:
+ -- {* Invariant holds on configuration @{text "(s, l, r)"} *}
+ "inc_inv ly n (as, am) (s, l, r) ires"
+ shows -- {* After @{text "stp"} steps of execution, the compiled
+ TM reaches the start state of next compiled TM and the invariant
+ still holds.
+ *}
+ "(\<exists> stp > 0. (\<lambda> (s', l', r').
+ s' = start_of ly (Suc as) \<and>
+ inc_inv ly n (as, am) (s', l', r') ires)
+ (t_steps (s, l, r) (ci ly (start_of ly as) (Inc n),
+ start_of ly as - Suc 0) stp))"
+proof -
+ from inc_inv_stop_pre1 [OF program_and_layout an_instruction the_start_state inv]
+ show ?thesis .
+qed
+
+lemma inc_inv_stop_cond:
+ "\<lbrakk>ly = layout_of aprog;
+ s' = start_of ly (as + 1);
+ inc_inv ly n (as, lm) (s', (l', r')) ires;
+ abc_fetch as aprog = Some (Inc n)\<rbrakk> \<Longrightarrow>
+ crsp_l ly (Suc as, abc_lm_s lm n (Suc (abc_lm_v lm n)))
+ (s', l', r') ires"
+apply(subgoal_tac "s' = start_of ly as + 2*n + 9", simp)
+apply(auto simp: inc_inv.simps inv_stop.simps crsp_l.simps )
+done
+
+lemma inc_crsp_ex_pre:
+ "\<lbrakk>ly = layout_of aprog;
+ crsp_l ly (as, am) tc ires;
+ abc_fetch as aprog = Some (Inc n)\<rbrakk>
+ \<Longrightarrow> \<exists>stp > 0. crsp_l ly (abc_step_l (as, am) (Some (Inc n)))
+ (t_steps tc (ci ly (start_of ly as) (Inc n),
+ start_of ly as - Suc 0) stp) ires"
+proof(case_tac tc, simp add: abc_step_l.simps)
+ fix a b c
+ assume h1: "ly = layout_of aprog"
+ "crsp_l (layout_of aprog) (as, am) (a, b, c) ires"
+ "abc_fetch as aprog = Some (Inc n)"
+ hence h2: "a = start_of ly as"
+ by(auto simp: crsp_l.simps)
+ from h1 and h2 have h3:
+ "inc_inv ly n (as, am) (start_of ly as, b, c) ires"
+ by(rule_tac inc_inv_init, simp, simp, simp)
+ from h1 and h2 and h3 have h4:
+ "(\<exists> stp > 0. (\<lambda> (s', l', r'). s' =
+ start_of ly (Suc as) \<and> inc_inv ly n (as, am) (s', l', r') ires)
+ (t_steps (a, b, c) (ci ly (start_of ly as)
+ (Inc n), start_of ly as - Suc 0) stp))"
+ apply(rule_tac inc_inv_stop, auto)
+ done
+ from h1 and h2 and h3 and h4 show
+ "\<exists>stp > 0. crsp_l (layout_of aprog)
+ (Suc as, abc_lm_s am n (Suc (abc_lm_v am n)))
+ (t_steps (a, b, c) (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n),
+ start_of (layout_of aprog) as - Suc 0) stp) ires"
+ apply(erule_tac exE)
+ apply(rule_tac x = stp in exI)
+ apply(case_tac "(t_steps (a, b, c) (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Inc n),
+ start_of (layout_of aprog) as - Suc 0) stp)", simp)
+ apply(rule_tac inc_inv_stop_cond, auto)
+ done
+qed
+
+text {*
+ The total correctness of the compilaton of @{text "Inc n"} instruction.
+*}
+
+lemma inc_crsp_ex:
+ assumes layout:
+ -- {* For any Abacus program @{text "aprog"}, assuming its layout is @{text "ly"} *}
+ "ly = layout_of aprog"
+ and corresponds:
+ -- {* Abacus configuration @{text "(as, am)"} is in correspondence with
+ TM configuration @{text "tc"} *}
+ "crsp_l ly (as, am) tc ires"
+ and inc:
+ -- {* There is an instruction @{text "Inc n"} at postion @{text "as"} of @{text "aprog"} *}
+ "abc_fetch as aprog = Some (Inc n)"
+ shows
+ -- {*
+ After @{text "stp"} steps of execution, the TM compiled from this @{text "Inc n"}
+ stops with a configuration which corresponds to the Abacus configuration obtained
+ from the execution of this @{text "Inc n"} instruction.
+ *}
+ "\<exists>stp > 0. crsp_l ly (abc_step_l (as, am) (Some (Inc n)))
+ (t_steps tc (ci ly (start_of ly as) (Inc n),
+ start_of ly as - Suc 0) stp) ires"
+proof -
+ from inc_crsp_ex_pre [OF layout corresponds inc] show ?thesis .
+qed
+
+(*******End: inc crsp********)
+
+(*******Begin: dec crsp******)
+
+subsubsection {* The compilation of @{text "Dec n e"} *}
+
+
+text {*
+ The lemmas in this section lead to the correctness of the compilation
+ of @{text "Dec n e"} instruction using the same techniques as
+ @{text "Inc n"}.
+*}
+
+type_synonym dec_inv_t = "(nat * nat list) \<Rightarrow> t_conf \<Rightarrow> block list \<Rightarrow> bool"
+
+fun dec_first_on_right_moving :: "nat \<Rightarrow> dec_inv_t"
+ where
+ "dec_first_on_right_moving n (as, lm) (s, l, r) ires =
+ (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and>
+ ml + mr = Suc m \<and> length lm1 = n \<and> ml > 0 \<and> m > 0 \<and>
+ (if lm1 = [] then l = Oc\<^bsup>ml\<^esup> @ Bk # Bk # ires
+ else l = (Oc\<^bsup>ml\<^esup>) @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and>
+ ((r = (Oc\<^bsup>mr\<^esup>) @ [Bk] @ <lm2> @ (Bk\<^bsup>rn\<^esup>)) \<or> (r = (Oc\<^bsup>mr\<^esup>) \<and> lm2 = [])))"
+
+fun dec_on_right_moving :: "dec_inv_t"
+ where
+ "dec_on_right_moving (as, lm) (s, l, r) ires =
+ (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and>
+ ml + mr = Suc (Suc m) \<and>
+ (if lm1 = [] then l = Oc\<^bsup>ml\<^esup> @ Bk # Bk # ires
+ else l = (Oc\<^bsup>ml\<^esup>) @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and>
+ ((r = (Oc\<^bsup>mr\<^esup>) @ [Bk] @ <lm2> @ (Bk\<^bsup>rn\<^esup>)) \<or> (r = (Oc\<^bsup>mr\<^esup>) \<and> lm2 = [])))"
+
+fun dec_after_clear :: "dec_inv_t"
+ where
+ "dec_after_clear (as, lm) (s, l, r) ires =
+ (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and>
+ ml + mr = Suc m \<and> ml = Suc m \<and> r \<noteq> [] \<and> r \<noteq> [] \<and>
+ (if lm1 = [] then l = Oc\<^bsup>ml\<^esup> @ Bk # Bk # ires
+ else l = (Oc\<^bsup>ml \<^esup>) @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and>
+ (tl r = Bk # <lm2> @ (Bk\<^bsup>rn\<^esup>) \<or> tl r = [] \<and> lm2 = []))"
+
+fun dec_after_write :: "dec_inv_t"
+ where
+ "dec_after_write (as, lm) (s, l, r) ires =
+ (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and>
+ ml + mr = Suc m \<and> ml = Suc m \<and> lm2 \<noteq> [] \<and>
+ (if lm1 = [] then l = Bk # Oc\<^bsup>ml\<^esup> @ Bk # Bk # ires
+ else l = Bk # (Oc\<^bsup>ml \<^esup>) @ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and>
+ tl r = <lm2> @ (Bk\<^bsup>rn\<^esup>))"
+
+fun dec_right_move :: "dec_inv_t"
+ where
+ "dec_right_move (as, lm) (s, l, r) ires =
+ (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2
+ \<and> ml = Suc m \<and> mr = (0::nat) \<and>
+ (if lm1 = [] then l = Bk # Oc\<^bsup>ml\<^esup> @ Bk # Bk # ires
+ else l = Bk # Oc\<^bsup>ml\<^esup>@ [Bk] @ <rev lm1> @ Bk # Bk # ires)
+ \<and> (r = Bk # <lm2> @ Bk\<^bsup>rn\<^esup>\<or> r = [] \<and> lm2 = []))"
+
+fun dec_check_right_move :: "dec_inv_t"
+ where
+ "dec_check_right_move (as, lm) (s, l, r) ires =
+ (\<exists> lm1 lm2 m ml mr rn. lm = lm1 @ [m] @ lm2 \<and>
+ ml = Suc m \<and> mr = (0::nat) \<and>
+ (if lm1 = [] then l = Bk # Bk # Oc\<^bsup>ml\<^esup> @ Bk # Bk # ires
+ else l = Bk # Bk # Oc\<^bsup>ml \<^esup>@ [Bk] @ <rev lm1> @ Bk # Bk # ires) \<and>
+ r = <lm2> @ Bk\<^bsup>rn\<^esup>)"
+
+fun dec_left_move :: "dec_inv_t"
+ where
+ "dec_left_move (as, lm) (s, l, r) ires =
+ (\<exists> lm1 m rn. (lm::nat list) = lm1 @ [m::nat] \<and>
+ rn > 0 \<and>
+ (if lm1 = [] then l = Bk # Oc\<^bsup>Suc m\<^esup> @ Bk # Bk # ires
+ else l = Bk # Oc\<^bsup>Suc m\<^esup> @ Bk # <rev lm1> @ Bk # Bk # ires) \<and> r = Bk\<^bsup>rn\<^esup>)"
+
+declare
+ dec_on_right_moving.simps[simp del] dec_after_clear.simps[simp del]
+ dec_after_write.simps[simp del] dec_left_move.simps[simp del]
+ dec_check_right_move.simps[simp del] dec_right_move.simps[simp del]
+ dec_first_on_right_moving.simps[simp del]
+
+fun inv_locate_n_b :: "inc_inv_t"
+ where
+ "inv_locate_n_b (as, lm) (s, l, r) ires=
+ (\<exists> lm1 lm2 tn m ml mr rn. lm @ 0\<^bsup>tn\<^esup> = lm1 @ [m] @ lm2 \<and>
+ length lm1 = s \<and> m + 1 = ml + mr \<and>
+ ml = 1 \<and> tn = s + 1 - length lm \<and>
+ (if lm1 = [] then l = Oc\<^bsup>ml\<^esup> @ Bk # Bk # ires
+ else l = Oc\<^bsup>ml\<^esup>@Bk#<rev lm1>@Bk#Bk#ires) \<and>
+ (r = (Oc\<^bsup>mr\<^esup>) @ [Bk] @ <lm2>@ (Bk\<^bsup>rn\<^esup>) \<or> (lm2 = [] \<and> r = (Oc\<^bsup>mr\<^esup>)))
+ )"
+
+fun dec_inv_1 :: "layout \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> dec_inv_t"
+ where
+ "dec_inv_1 ly n e (as, am) (s, l, r) ires =
+ (let ss = start_of ly as in
+ let am' = abc_lm_s am n (abc_lm_v am n - Suc 0) in
+ let am'' = abc_lm_s am n (abc_lm_v am n) in
+ if s = start_of ly e then inv_stop (as, am'') (s, l, r) ires
+ else if s = ss then False
+ else if ss \<le> s \<and> s < ss + 2*n then
+ if (s - ss) mod 2 = 0 then
+ inv_locate_a (as, am) ((s - ss) div 2, l, r) ires
+ \<or> inv_locate_a (as, am'') ((s - ss) div 2, l, r) ires
+ else
+ inv_locate_b (as, am) ((s - ss) div 2, l, r) ires
+ \<or> inv_locate_b (as, am'') ((s - ss) div 2, l, r) ires
+ else if s = ss + 2 * n then
+ inv_locate_a (as, am) (n, l, r) ires
+ \<or> inv_locate_a (as, am'') (n, l, r) ires
+ else if s = ss + 2 * n + 1 then
+ inv_locate_b (as, am) (n, l, r) ires
+ else if s = ss + 2 * n + 13 then
+ inv_on_left_moving (as, am'') (s, l, r) ires
+ else if s = ss + 2 * n + 14 then
+ inv_check_left_moving (as, am'') (s, l, r) ires
+ else if s = ss + 2 * n + 15 then
+ inv_after_left_moving (as, am'') (s, l, r) ires
+ else False)"
+
+fun dec_inv_2 :: "layout \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> dec_inv_t"
+ where
+ "dec_inv_2 ly n e (as, am) (s, l, r) ires =
+ (let ss = start_of ly as in
+ let am' = abc_lm_s am n (abc_lm_v am n - Suc 0) in
+ let am'' = abc_lm_s am n (abc_lm_v am n) in
+ if s = 0 then False
+ else if s = ss then False
+ else if ss \<le> s \<and> s < ss + 2*n then
+ if (s - ss) mod 2 = 0 then
+ inv_locate_a (as, am) ((s - ss) div 2, l, r) ires
+ else inv_locate_b (as, am) ((s - ss) div 2, l, r) ires
+ else if s = ss + 2 * n then
+ inv_locate_a (as, am) (n, l, r) ires
+ else if s = ss + 2 * n + 1 then
+ inv_locate_n_b (as, am) (n, l, r) ires
+ else if s = ss + 2 * n + 2 then
+ dec_first_on_right_moving n (as, am'') (s, l, r) ires
+ else if s = ss + 2 * n + 3 then
+ dec_after_clear (as, am') (s, l, r) ires
+ else if s = ss + 2 * n + 4 then
+ dec_right_move (as, am') (s, l, r) ires
+ else if s = ss + 2 * n + 5 then
+ dec_check_right_move (as, am') (s, l, r) ires
+ else if s = ss + 2 * n + 6 then
+ dec_left_move (as, am') (s, l, r) ires
+ else if s = ss + 2 * n + 7 then
+ dec_after_write (as, am') (s, l, r) ires
+ else if s = ss + 2 * n + 8 then
+ dec_on_right_moving (as, am') (s, l, r) ires
+ else if s = ss + 2 * n + 9 then
+ dec_after_clear (as, am') (s, l, r) ires
+ else if s = ss + 2 * n + 10 then
+ inv_on_left_moving (as, am') (s, l, r) ires
+ else if s = ss + 2 * n + 11 then
+ inv_check_left_moving (as, am') (s, l, r) ires
+ else if s = ss + 2 * n + 12 then
+ inv_after_left_moving (as, am') (s, l, r) ires
+ else if s = ss + 2 * n + 16 then
+ inv_stop (as, am') (s, l, r) ires
+ else False)"
+
+(*begin: dec_fetch lemmas*)
+
+lemma dec_fetch_locate_a_o:
+ "\<lbrakk>start_of ly as \<le> a;
+ a < start_of ly as + 2 * n; start_of ly as > 0;
+ a - start_of ly as = 2 * q\<rbrakk>
+ \<Longrightarrow> fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (Suc (2 * q)) Oc = (R, a + 1)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append Suc_pre)
+apply(subgoal_tac "(findnth n ! Suc (4 * q)) =
+ findnth (Suc q) ! (4 * q + 1)")
+apply(simp add: findnth.simps nth_append)
+apply(subgoal_tac " findnth n !(4 * q + 1) =
+ findnth (Suc q) ! (4 * q + 1)", simp)
+apply(rule_tac findnth_nth, auto)
+done
+
+lemma dec_fetch_locate_a_b:
+ "\<lbrakk>start_of ly as \<le> a;
+ a < start_of ly as + 2 * n;
+ start_of ly as > 0;
+ a - start_of ly as = 2 * q\<rbrakk>
+ \<Longrightarrow> fetch (ci (layout_of aprog) (start_of ly as) (Dec n e))
+ (Suc (2 * q)) Bk = (W1, a)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append)
+apply(subgoal_tac "(findnth n ! (4 * q)) =
+ findnth (Suc q) ! (4 * q )")
+apply(simp add: findnth.simps nth_append)
+apply(subgoal_tac " findnth n !(4 * q + 0) =
+ findnth (Suc q) ! (4 * q + 0)", simp)
+apply(rule_tac findnth_nth, auto)
+done
+
+lemma dec_fetch_locate_b_o:
+ "\<lbrakk>start_of ly as \<le> a;
+ a < start_of ly as + 2 * n;
+ (a - start_of ly as) mod 2 = Suc 0;
+ start_of ly as> 0\<rbrakk>
+ \<Longrightarrow> fetch (ci (layout_of aprog) (start_of ly as) (Dec n e))
+ (Suc (a - start_of ly as)) Oc = (R, a)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append)
+apply(subgoal_tac "\<exists> q. (a - start_of ly as) = 2 * q + 1", auto)
+apply(subgoal_tac "(findnth n ! Suc (Suc (Suc (4 * q)))) =
+ findnth (Suc q) ! (4 * q + 3)")
+apply(simp add: findnth.simps nth_append)
+apply(subgoal_tac " findnth n ! (4 * q + 3) =
+ findnth (Suc q) ! (4 * q + 3)", simp add: add3_Suc)
+apply(rule_tac findnth_nth, auto)
+done
+
+lemma dec_fetch_locate_b_b:
+ "\<lbrakk>\<not> a < start_of ly as;
+ a < start_of ly as + 2 * n;
+ (a - start_of ly as) mod 2 = Suc 0;
+ start_of ly as > 0\<rbrakk>
+ \<Longrightarrow> fetch (ci (layout_of aprog) (start_of ly as) (Dec n e))
+ (Suc (a - start_of ly as)) Bk = (R, a + 1)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append)
+apply(subgoal_tac "\<exists> q. (a - start_of ly as) = 2 * q + 1", auto)
+apply(subgoal_tac "(findnth n ! Suc ((Suc (4 * q)))) =
+ findnth (Suc q) ! (4 * q + 2)")
+apply(simp add: findnth.simps nth_append)
+apply(subgoal_tac " findnth n ! (4 * q + 2) =
+ findnth (Suc q) ! (4 * q + 2)", simp)
+apply(rule_tac findnth_nth, auto)
+done
+
+lemma dec_fetch_locate_n_a_o:
+ "start_of ly as > 0 \<Longrightarrow> fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (Suc (2 * n)) Oc
+ = (R, start_of ly as + 2*n + 1)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tdec_b_def)
+done
+
+lemma dec_fetch_locate_n_a_b:
+ "start_of ly as > 0 \<Longrightarrow> fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (Suc (2 * n)) Bk
+ = (W1, start_of ly as + 2*n)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tdec_b_def)
+done
+
+lemma dec_fetch_locate_n_b_o:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (Suc (Suc (2 * n))) Oc
+ = (R, start_of ly as + 2*n + 2)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tdec_b_def)
+done
+
+
+lemma dec_fetch_locate_n_b_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (Suc (Suc (2 * n))) Bk
+ = (L, start_of ly as + 2*n + 13)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tdec_b_def)
+done
+
+lemma dec_fetch_first_on_right_move_o:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (Suc (Suc (Suc (2 * n)))) Oc
+ = (R, start_of ly as + 2*n + 2)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tdec_b_def)
+done
+
+lemma dec_fetch_first_on_right_move_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog) (start_of ly as) (Dec n e))
+ (Suc (Suc (Suc (2 * n)))) Bk
+ = (L, start_of ly as + 2*n + 3)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append tdec_b_def)
+done
+
+lemma [simp]: "fetch x (a + 2 * n) b = fetch x (2 * n + a) b"
+thm arg_cong
+apply(rule_tac x = "a + 2*n" and y = "2*n + a" in arg_cong, simp)
+done
+
+lemma dec_fetch_first_after_clear_o:
+ "start_of ly as > 0 \<Longrightarrow> fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 4) Oc
+ = (W0, start_of ly as + 2*n + 3)"
+apply(auto simp: ci.simps findnth.simps tshift.simps
+ tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 4 = Suc (2*n + 3)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_first_after_clear_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 4) Bk
+ = (R, start_of ly as + 2*n + 4)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 4= Suc (2*n + 3)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_right_move_b:
+ "start_of ly as > 0 \<Longrightarrow> fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 5) Bk
+ = (R, start_of ly as + 2*n + 5)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 5= Suc (2*n + 4)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_check_right_move_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 6) Bk
+ = (L, start_of ly as + 2*n + 6)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 6 = Suc (2*n + 5)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_check_right_move_o:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog) (start_of ly as)
+ (Dec n e)) (2 * n + 6) Oc
+ = (L, start_of ly as + 2*n + 7)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 6 = Suc (2*n + 5)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_left_move_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 7) Bk
+ = (L, start_of ly as + 2*n + 10)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 7 = Suc (2*n + 6)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_after_write_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 8) Bk
+ = (W1, start_of ly as + 2*n + 7)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 8 = Suc (2*n + 7)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_after_write_o:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 8) Oc
+ = (R, start_of ly as + 2*n + 8)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 8 = Suc (2*n + 7)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_on_right_move_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 9) Bk
+ = (L, start_of ly as + 2*n + 9)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 9 = Suc (2*n + 8)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_on_right_move_o:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 9) Oc
+ = (R, start_of ly as + 2*n + 8)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 9 = Suc (2*n + 8)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_after_clear_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 10) Bk
+ = (R, start_of ly as + 2*n + 4)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 10 = Suc (2*n + 9)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_after_clear_o:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 10) Oc
+ = (W0, start_of ly as + 2*n + 9)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 10= Suc (2*n + 9)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_on_left_move1_o:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 11) Oc
+ = (L, start_of ly as + 2*n + 10)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 11= Suc (2*n + 10)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_on_left_move1_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 11) Bk
+ = (L, start_of ly as + 2*n + 11)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 11 = Suc (2*n + 10)",
+ simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_check_left_move1_o:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 12) Oc
+ = (L, start_of ly as + 2*n + 10)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 12= Suc (2*n + 11)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_check_left_move1_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 12) Bk
+ = (R, start_of ly as + 2*n + 12)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 12 = Suc (2*n + 11)",
+ simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_after_left_move1_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 13) Bk
+ = (R, start_of ly as + 2*n + 16)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 13 = Suc (2*n + 12)",
+ simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_on_left_move2_o:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 14) Oc
+ = (L, start_of ly as + 2*n + 13)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 14 = Suc (2*n + 13)",
+ simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_on_left_move2_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 14) Bk
+ = (L, start_of ly as + 2*n + 14)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 14 = Suc (2*n + 13)",
+ simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_check_left_move2_o:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 15) Oc
+ = (L, start_of ly as + 2*n + 13)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 15 = Suc (2*n + 14)",
+ simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_check_left_move2_b:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2 * n + 15) Bk
+ = (R, start_of ly as + 2*n + 15)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 15= Suc (2*n + 14)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_after_left_move2_b:
+ "\<lbrakk>ly = layout_of aprog;
+ abc_fetch as aprog = Some (Dec n e);
+ start_of ly as > 0\<rbrakk> \<Longrightarrow>
+ fetch (ci (layout_of aprog) (start_of ly as)
+ (Dec n e)) (2 * n + 16) Bk
+ = (R, start_of ly e)"
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac "2*n + 16 = Suc (2*n + 15)",
+ simp only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+lemma dec_fetch_next_state:
+ "start_of ly as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog)
+ (start_of ly as) (Dec n e)) (2* n + 17) b
+ = (Nop, 0)"
+apply(case_tac b)
+apply(auto simp: ci.simps findnth.simps
+ tshift.simps tdec_b_def add3_Suc)
+apply(subgoal_tac [!] "2*n + 17 = Suc (2*n + 16)",
+ simp_all only: fetch.simps)
+apply(auto simp: nth_of.simps nth_append)
+done
+
+(*End: dec_fetch lemmas*)
+lemmas dec_fetch_simps =
+ dec_fetch_locate_a_o dec_fetch_locate_a_b dec_fetch_locate_b_o
+ dec_fetch_locate_b_b dec_fetch_locate_n_a_o
+ dec_fetch_locate_n_a_b dec_fetch_locate_n_b_o
+ dec_fetch_locate_n_b_b dec_fetch_first_on_right_move_o
+ dec_fetch_first_on_right_move_b dec_fetch_first_after_clear_b
+ dec_fetch_first_after_clear_o dec_fetch_right_move_b
+ dec_fetch_on_right_move_b dec_fetch_on_right_move_o
+ dec_fetch_after_clear_b dec_fetch_after_clear_o
+ dec_fetch_check_right_move_b dec_fetch_check_right_move_o
+ dec_fetch_left_move_b dec_fetch_on_left_move1_b
+ dec_fetch_on_left_move1_o dec_fetch_check_left_move1_b
+ dec_fetch_check_left_move1_o dec_fetch_after_left_move1_b
+ dec_fetch_on_left_move2_b dec_fetch_on_left_move2_o
+ dec_fetch_check_left_move2_o dec_fetch_check_left_move2_b
+ dec_fetch_after_left_move2_b dec_fetch_after_write_b
+ dec_fetch_after_write_o dec_fetch_next_state
+
+lemma [simp]:
+ "\<lbrakk>start_of ly as \<le> a;
+ a < start_of ly as + 2 * n;
+ (a - start_of ly as) mod 2 = Suc 0;
+ inv_locate_b (as, am) ((a - start_of ly as) div 2, aaa, Bk # xs) ires\<rbrakk>
+ \<Longrightarrow> \<not> Suc a < start_of ly as + 2 * n \<longrightarrow>
+ inv_locate_a (as, am) (n, Bk # aaa, xs) ires"
+apply(insert locate_b_2_locate_a[of a ly as n am aaa xs], simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>start_of ly as \<le> a;
+ a < start_of ly as + 2 * n;
+ (a - start_of ly as) mod 2 = Suc 0;
+ inv_locate_b (as, am) ((a - start_of ly as) div 2, aaa, []) ires\<rbrakk>
+ \<Longrightarrow> \<not> Suc a < start_of ly as + 2 * n \<longrightarrow>
+ inv_locate_a (as, am) (n, Bk # aaa, []) ires"
+apply(insert locate_b_2_locate_a_B[of a ly as n am aaa], simp)
+done
+
+(*
+lemma [simp]: "a\<^bsup>0\<^esup>=[]"
+apply(simp add: exponent_def)
+done
+*)
+
+lemma exp_ind: "a\<^bsup>Suc b\<^esup> = a\<^bsup>b\<^esup> @ [a]"
+apply(simp only: exponent_def rep_ind)
+done
+
+lemma [simp]:
+ "inv_locate_b (as, am) (n, l, Oc # r) ires
+ \<Longrightarrow> dec_first_on_right_moving n (as, abc_lm_s am n (abc_lm_v am n))
+ (Suc (Suc (start_of ly as + 2 * n)), Oc # l, r) ires"
+apply(simp only: inv_locate_b.simps
+ dec_first_on_right_moving.simps in_middle.simps
+ abc_lm_s.simps abc_lm_v.simps)
+apply(erule_tac exE)+
+apply(erule conjE)+
+apply(case_tac "n < length am", simp)
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, simp)
+apply(rule_tac x = "Suc ml" in exI, rule_tac conjI, rule_tac [1-2] impI)
+prefer 3
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, simp)
+apply(subgoal_tac "Suc n - length am = Suc (n - length am)",
+ simp only:exponent_def rep_ind, simp)
+apply(rule_tac x = "Suc ml" in exI, simp_all)
+apply(rule_tac [!] x = "mr - 1" in exI, simp_all)
+apply(case_tac [!] mr, auto)
+done
+
+lemma [simp]:
+ "\<lbrakk>inv_locate_b (as, am) (n, l, r) ires; l \<noteq> []\<rbrakk> \<Longrightarrow>
+ \<not> inv_on_left_moving_in_middle_B (as, abc_lm_s am n (abc_lm_v am n))
+ (s, tl l, hd l # r) ires"
+apply(auto simp: inv_locate_b.simps
+ inv_on_left_moving_in_middle_B.simps in_middle.simps)
+apply(case_tac [!] ml, auto split: if_splits)
+done
+
+lemma [simp]: "inv_locate_b (as, am) (n, l, r) ires \<Longrightarrow> l \<noteq> []"
+apply(auto simp: inv_locate_b.simps in_middle.simps split: if_splits)
+done
+
+lemma [simp]: "\<lbrakk>inv_locate_b (as, am) (n, l, Bk # r) ires; n < length am\<rbrakk>
+ \<Longrightarrow> inv_on_left_moving_norm (as, am) (s, tl l, hd l # Bk # r) ires"
+apply(simp only: inv_locate_b.simps inv_on_left_moving_norm.simps
+ in_middle.simps)
+apply(erule_tac exE)+
+apply(erule_tac conjE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, simp)
+apply(rule_tac x = "ml - 1" in exI, auto)
+apply(rule_tac [!] x = "Suc mr" in exI)
+apply(case_tac [!] mr, auto)
+done
+
+lemma [simp]: "\<lbrakk>inv_locate_b (as, am) (n, l, Bk # r) ires; \<not> n < length am\<rbrakk>
+ \<Longrightarrow> inv_on_left_moving_norm (as, am @
+ replicate (n - length am) 0 @ [0]) (s, tl l, hd l # Bk # r) ires"
+apply(simp only: inv_locate_b.simps inv_on_left_moving_norm.simps
+ in_middle.simps)
+apply(erule_tac exE)+
+apply(erule_tac conjE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, simp)
+apply(subgoal_tac "Suc n - length am = Suc (n - length am)", simp only: rep_ind exponent_def, simp_all)
+apply(rule_tac x = "Suc mr" in exI, auto)
+done
+
+lemma inv_locate_b_2_on_left_moving[simp]:
+ "\<lbrakk>inv_locate_b (as, am) (n, l, Bk # r) ires\<rbrakk>
+ \<Longrightarrow> (l = [] \<longrightarrow> inv_on_left_moving (as,
+ abc_lm_s am n (abc_lm_v am n)) (s, [], Bk # Bk # r) ires) \<and>
+ (l \<noteq> [] \<longrightarrow> inv_on_left_moving (as,
+ abc_lm_s am n (abc_lm_v am n)) (s, tl l, hd l # Bk # r) ires)"
+apply(subgoal_tac "l\<noteq>[]")
+apply(subgoal_tac "\<not> inv_on_left_moving_in_middle_B
+ (as, abc_lm_s am n (abc_lm_v am n)) (s, tl l, hd l # Bk # r) ires")
+apply(simp add:inv_on_left_moving.simps
+ abc_lm_s.simps abc_lm_v.simps split: if_splits, auto)
+done
+
+lemma [simp]:
+ "inv_locate_b (as, am) (n, l, []) ires \<Longrightarrow>
+ inv_locate_b (as, am) (n, l, [Bk]) ires"
+apply(auto simp: inv_locate_b.simps in_middle.simps)
+apply(rule_tac x = lm1 in exI, rule_tac x = "[]" in exI,
+ rule_tac x = "Suc (length lm1) - length am" in exI,
+ rule_tac x = m in exI, simp)
+apply(rule_tac x = ml in exI, rule_tac x = mr in exI)
+apply(auto)
+done
+
+lemma nil_2_nil: "<lm::nat list> = [] \<Longrightarrow> lm = []"
+apply(auto simp: tape_of_nl_abv)
+apply(case_tac lm, simp)
+apply(case_tac list, auto simp: tape_of_nat_list.simps)
+done
+
+lemma inv_locate_b_2_on_left_moving_b[simp]:
+ "inv_locate_b (as, am) (n, l, []) ires
+ \<Longrightarrow> (l = [] \<longrightarrow> inv_on_left_moving (as,
+ abc_lm_s am n (abc_lm_v am n)) (s, [], [Bk]) ires) \<and>
+ (l \<noteq> [] \<longrightarrow> inv_on_left_moving (as, abc_lm_s am n
+ (abc_lm_v am n)) (s, tl l, [hd l]) ires)"
+apply(insert inv_locate_b_2_on_left_moving[of as am n l "[]" ires s])
+apply(simp only: inv_on_left_moving.simps, simp)
+apply(subgoal_tac "\<not> inv_on_left_moving_in_middle_B
+ (as, abc_lm_s am n (abc_lm_v am n)) (s, tl l, [hd l]) ires", simp)
+apply(simp only: inv_on_left_moving_norm.simps)
+apply(erule_tac exE)+
+apply(erule_tac conjE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, rule_tac x = ml in exI,
+ rule_tac x = mr in exI, simp)
+apply(case_tac mr, simp, simp, case_tac nat, auto intro: nil_2_nil)
+done
+
+lemma [simp]:
+ "\<lbrakk>dec_first_on_right_moving n (as, am) (s, aaa, Oc # xs) ires\<rbrakk>
+ \<Longrightarrow> dec_first_on_right_moving n (as, am) (s', Oc # aaa, xs) ires"
+apply(simp only: dec_first_on_right_moving.simps)
+apply(erule exE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, simp)
+apply(rule_tac x = "Suc ml" in exI,
+ rule_tac x = "mr - 1" in exI, auto)
+apply(case_tac [!] mr, auto)
+done
+
+lemma [simp]:
+ "dec_first_on_right_moving n (as, am) (s, l, Bk # xs) ires \<Longrightarrow> l \<noteq> []"
+apply(auto simp: dec_first_on_right_moving.simps split: if_splits)
+done
+
+lemma [elim]:
+ "\<lbrakk>\<not> length lm1 < length am;
+ am @ replicate (length lm1 - length am) 0 @ [0::nat] =
+ lm1 @ m # lm2;
+ 0 < m\<rbrakk>
+ \<Longrightarrow> RR"
+apply(subgoal_tac "lm2 = []", simp)
+apply(drule_tac length_equal, simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>dec_first_on_right_moving n (as,
+ abc_lm_s am n (abc_lm_v am n)) (s, l, Bk # xs) ires\<rbrakk>
+\<Longrightarrow> dec_after_clear (as, abc_lm_s am n
+ (abc_lm_v am n - Suc 0)) (s', tl l, hd l # Bk # xs) ires"
+apply(simp only: dec_first_on_right_moving.simps
+ dec_after_clear.simps abc_lm_s.simps abc_lm_v.simps)
+apply(erule_tac exE)+
+apply(case_tac "n < length am")
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = "m - 1" in exI, auto simp: )
+apply(case_tac [!] mr, auto)
+done
+
+lemma [simp]:
+ "\<lbrakk>dec_first_on_right_moving n (as,
+ abc_lm_s am n (abc_lm_v am n)) (s, l, []) ires\<rbrakk>
+\<Longrightarrow> (l = [] \<longrightarrow> dec_after_clear (as,
+ abc_lm_s am n (abc_lm_v am n - Suc 0)) (s', [], [Bk]) ires) \<and>
+ (l \<noteq> [] \<longrightarrow> dec_after_clear (as, abc_lm_s am n
+ (abc_lm_v am n - Suc 0)) (s', tl l, [hd l]) ires)"
+apply(subgoal_tac "l \<noteq> []",
+ simp only: dec_first_on_right_moving.simps
+ dec_after_clear.simps abc_lm_s.simps abc_lm_v.simps)
+apply(erule_tac exE)+
+apply(case_tac "n < length am", simp)
+apply(rule_tac x = lm1 in exI, rule_tac x = "m - 1" in exI, auto)
+apply(case_tac [1-2] mr, auto)
+apply(case_tac [1-2] m, auto simp: dec_first_on_right_moving.simps split: if_splits)
+done
+
+lemma [simp]: "\<lbrakk>dec_after_clear (as, am) (s, l, Oc # r) ires\<rbrakk>
+ \<Longrightarrow> dec_after_clear (as, am) (s', l, Bk # r) ires"
+apply(auto simp: dec_after_clear.simps)
+done
+
+lemma [simp]: "\<lbrakk>dec_after_clear (as, am) (s, l, Bk # r) ires\<rbrakk>
+ \<Longrightarrow> dec_right_move (as, am) (s', Bk # l, r) ires"
+apply(auto simp: dec_after_clear.simps dec_right_move.simps split: if_splits)
+done
+
+lemma [simp]: "\<lbrakk>dec_after_clear (as, am) (s, l, []) ires\<rbrakk>
+ \<Longrightarrow> dec_right_move (as, am) (s', Bk # l, []) ires"
+apply(auto simp: dec_after_clear.simps dec_right_move.simps )
+done
+
+lemma [simp]: "\<exists>rn. a::block\<^bsup>rn\<^esup> = []"
+apply(rule_tac x = 0 in exI, simp)
+done
+
+lemma [simp]: "\<lbrakk>dec_after_clear (as, am) (s, l, []) ires\<rbrakk>
+ \<Longrightarrow> dec_right_move (as, am) (s', Bk # l, [Bk]) ires"
+apply(auto simp: dec_after_clear.simps dec_right_move.simps split: if_splits)
+done
+
+lemma [simp]:"dec_right_move (as, am) (s, l, Oc # r) ires = False"
+apply(auto simp: dec_right_move.simps)
+done
+
+lemma dec_right_move_2_check_right_move[simp]:
+ "\<lbrakk>dec_right_move (as, am) (s, l, Bk # r) ires\<rbrakk>
+ \<Longrightarrow> dec_check_right_move (as, am) (s', Bk # l, r) ires"
+apply(auto simp: dec_right_move.simps dec_check_right_move.simps split: if_splits)
+done
+
+lemma [simp]:
+ "dec_right_move (as, am) (s, l, []) ires=
+ dec_right_move (as, am) (s, l, [Bk]) ires"
+apply(simp add: dec_right_move.simps)
+apply(rule_tac iffI)
+apply(erule_tac [!] exE)+
+apply(erule_tac [2] exE)
+apply(rule_tac [!] x = lm1 in exI, rule_tac x = "[]" in exI,
+ rule_tac [!] x = m in exI, auto)
+apply(auto intro: nil_2_nil)
+done
+
+lemma [simp]: "\<lbrakk>dec_right_move (as, am) (s, l, []) ires\<rbrakk>
+ \<Longrightarrow> dec_check_right_move (as, am) (s, Bk # l, []) ires"
+apply(insert dec_right_move_2_check_right_move[of as am s l "[]" s'],
+ simp)
+done
+
+lemma [simp]: "dec_check_right_move (as, am) (s, l, r) ires\<Longrightarrow> l \<noteq> []"
+apply(auto simp: dec_check_right_move.simps split: if_splits)
+done
+
+lemma [simp]: "\<lbrakk>dec_check_right_move (as, am) (s, l, Oc # r) ires\<rbrakk>
+ \<Longrightarrow> dec_after_write (as, am) (s', tl l, hd l # Oc # r) ires"
+apply(auto simp: dec_check_right_move.simps dec_after_write.simps)
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, auto)
+done
+
+lemma [simp]: "\<lbrakk>dec_check_right_move (as, am) (s, l, Bk # r) ires\<rbrakk>
+ \<Longrightarrow> dec_left_move (as, am) (s', tl l, hd l # Bk # r) ires"
+apply(auto simp: dec_check_right_move.simps
+ dec_left_move.simps inv_after_move.simps)
+apply(rule_tac x = lm1 in exI, rule_tac x = m in exI, auto)
+apply(auto intro: BkCons_nil nil_2_nil dest: BkCons_nil)
+apply(rule_tac x = "Suc rn" in exI)
+apply(auto intro: BkCons_nil nil_2_nil dest: BkCons_nil)
+done
+
+lemma [simp]: "\<lbrakk>dec_check_right_move (as, am) (s, l, []) ires\<rbrakk>
+ \<Longrightarrow> dec_left_move (as, am) (s', tl l, [hd l]) ires"
+apply(auto simp: dec_check_right_move.simps
+ dec_left_move.simps inv_after_move.simps)
+apply(rule_tac x = lm1 in exI, rule_tac x = m in exI, auto)
+apply(auto intro: BkCons_nil nil_2_nil dest: BkCons_nil)
+done
+
+lemma [simp]: "dec_left_move (as, am) (s, aaa, Oc # xs) ires = False"
+apply(auto simp: dec_left_move.simps inv_after_move.simps)
+apply(case_tac [!] rn, auto)
+done
+
+lemma [simp]: "dec_left_move (as, am) (s, l, r) ires
+ \<Longrightarrow> l \<noteq> []"
+apply(auto simp: dec_left_move.simps split: if_splits)
+done
+
+lemma tape_of_nl_abv_cons_ex[simp]:
+ "\<exists>lna. Oc # Oc\<^bsup>m\<^esup> @ Bk # <rev lm1> @ Bk\<^bsup>ln\<^esup> = <m # rev lm1> @ Bk\<^bsup>lna\<^esup>"
+apply(case_tac "lm1=[]", auto simp: tape_of_nl_abv
+ tape_of_nat_list.simps)
+apply(rule_tac x = "ln" in exI, simp)
+apply(simp add: tape_of_nat_list_cons exponent_def)
+done
+
+(*
+lemma [simp]: "inv_on_left_moving_in_middle_B (as, lm1 @ [m])
+ (s', Oc # Oc\<^bsup>m\<^esup> @ Bk # <rev lm1> @ Bk\<^bsup>ln\<^esup>, Bk # Bk\<^bsup>rn\<^esup>) ires"
+apply(simp only: inv_on_left_moving_in_middle_B.simps)
+apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = "[]" in exI, auto)
+done
+*)
+lemma [simp]: "inv_on_left_moving_in_middle_B (as, [m])
+ (s', Oc # Oc\<^bsup>m\<^esup> @ Bk # Bk # ires, Bk # Bk\<^bsup>rn\<^esup>) ires"
+apply(simp add: inv_on_left_moving_in_middle_B.simps)
+apply(rule_tac x = "[m]" in exI, simp, auto simp: tape_of_nat_def)
+done
+
+lemma [simp]: "inv_on_left_moving_in_middle_B (as, [m])
+ (s', Oc # Oc\<^bsup>m\<^esup> @ Bk # Bk # ires, [Bk]) ires"
+apply(simp add: inv_on_left_moving_in_middle_B.simps)
+apply(rule_tac x = "[m]" in exI, simp, auto simp: tape_of_nat_def)
+done
+
+lemma [simp]: "lm1 \<noteq> [] \<Longrightarrow>
+ inv_on_left_moving_in_middle_B (as, lm1 @ [m]) (s',
+ Oc # Oc\<^bsup>m\<^esup> @ Bk # <rev lm1> @ Bk # Bk # ires, Bk # Bk\<^bsup>rn\<^esup>) ires"
+apply(simp only: inv_on_left_moving_in_middle_B.simps)
+apply(rule_tac x = "lm1 @ [m ]" in exI, rule_tac x = "[]" in exI, simp, auto)
+done
+
+lemma [simp]: "lm1 \<noteq> [] \<Longrightarrow>
+ inv_on_left_moving_in_middle_B (as, lm1 @ [m]) (s',
+ Oc # Oc\<^bsup>m\<^esup> @ Bk # <rev lm1> @ Bk # Bk # ires, [Bk]) ires"
+apply(simp only: inv_on_left_moving_in_middle_B.simps)
+apply(rule_tac x = "lm1 @ [m ]" in exI, rule_tac x = "[]" in exI, simp, auto)
+done
+
+lemma [simp]: "dec_left_move (as, am) (s, l, Bk # r) ires
+ \<Longrightarrow> inv_on_left_moving (as, am) (s', tl l, hd l # Bk # r) ires"
+apply(auto simp: dec_left_move.simps inv_on_left_moving.simps split: if_splits)
+done
+
+(*
+lemma [simp]: "inv_on_left_moving_in_middle_B (as, lm1 @ [m])
+ (s', Oc # Oc\<^bsup>m\<^esup> @ Bk # <rev lm1> @ Bk\<^bsup>ln\<^esup>, [Bk]) ires"
+apply(auto simp: inv_on_left_moving_in_middle_B.simps)
+apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = "[]" in exI, auto)
+done
+*)
+
+lemma [simp]: "dec_left_move (as, am) (s, l, []) ires
+ \<Longrightarrow> inv_on_left_moving (as, am) (s', tl l, [hd l]) ires"
+apply(auto simp: dec_left_move.simps inv_on_left_moving.simps split: if_splits)
+done
+
+lemma [simp]: "dec_after_write (as, am) (s, l, Oc # r) ires
+ \<Longrightarrow> dec_on_right_moving (as, am) (s', Oc # l, r) ires"
+apply(auto simp: dec_after_write.simps dec_on_right_moving.simps)
+apply(rule_tac x = "lm1 @ [m]" in exI, rule_tac x = "tl lm2" in exI,
+ rule_tac x = "hd lm2" in exI, simp)
+apply(rule_tac x = "Suc 0" in exI,rule_tac x = "Suc (hd lm2)" in exI)
+apply(case_tac lm2, simp, simp)
+apply(case_tac "list = []",
+ auto simp: tape_of_nl_abv tape_of_nat_list.simps split: if_splits )
+apply(case_tac rn, auto)
+apply(case_tac "rev lm1", simp, simp add: tape_of_nat_list.simps)
+apply(case_tac rn, auto)
+apply(case_tac list, simp_all add: tape_of_nat_list.simps, auto)
+apply(case_tac "rev lm1", simp, simp add: tape_of_nat_list.simps)
+apply(case_tac list, simp_all add: tape_of_nat_list.simps, auto)
+done
+
+lemma [simp]: "dec_after_write (as, am) (s, l, Bk # r) ires
+ \<Longrightarrow> dec_after_write (as, am) (s', l, Oc # r) ires"
+apply(auto simp: dec_after_write.simps)
+done
+
+lemma [simp]: "dec_after_write (as, am) (s, aaa, []) ires
+ \<Longrightarrow> dec_after_write (as, am) (s', aaa, [Oc]) ires"
+apply(auto simp: dec_after_write.simps)
+done
+
+lemma [simp]: "dec_on_right_moving (as, am) (s, l, Oc # r) ires
+ \<Longrightarrow> dec_on_right_moving (as, am) (s', Oc # l, r) ires"
+apply(simp only: dec_on_right_moving.simps)
+apply(erule_tac exE)+
+apply(erule conjE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = "m" in exI, rule_tac x = "Suc ml" in exI,
+ rule_tac x = "mr - 1" in exI, simp)
+apply(case_tac mr, auto)
+done
+
+lemma [simp]: "dec_on_right_moving (as, am) (s, l, r) ires\<Longrightarrow> l \<noteq> []"
+apply(auto simp: dec_on_right_moving.simps split: if_splits)
+done
+
+lemma [simp]: "dec_on_right_moving (as, am) (s, l, Bk # r) ires
+ \<Longrightarrow> dec_after_clear (as, am) (s', tl l, hd l # Bk # r) ires"
+apply(auto simp: dec_on_right_moving.simps dec_after_clear.simps)
+apply(case_tac [!] mr, auto split: if_splits)
+done
+
+lemma [simp]: "dec_on_right_moving (as, am) (s, l, []) ires
+ \<Longrightarrow> dec_after_clear (as, am) (s', tl l, [hd l]) ires"
+apply(auto simp: dec_on_right_moving.simps dec_after_clear.simps)
+apply(case_tac mr, simp_all split: if_splits)
+apply(rule_tac x = lm1 in exI, simp)
+done
+
+lemma start_of_le: "a < b \<Longrightarrow> start_of ly a \<le> start_of ly b"
+proof(induct b arbitrary: a, simp, case_tac "a = b", simp)
+ fix b a
+ show "start_of ly b \<le> start_of ly (Suc b)"
+ apply(case_tac "b::nat",
+ simp add: start_of.simps, simp add: start_of.simps)
+ done
+next
+ fix b a
+ assume h1: "\<And>a. a < b \<Longrightarrow> start_of ly a \<le> start_of ly b"
+ "a < Suc b" "a \<noteq> b"
+ hence "a < b"
+ by(simp)
+ from h1 and this have h2: "start_of ly a \<le> start_of ly b"
+ by(drule_tac h1, simp)
+ from h2 show "start_of ly a \<le> start_of ly (Suc b)"
+ proof -
+ have "start_of ly b \<le> start_of ly (Suc b)"
+ apply(case_tac "b::nat",
+ simp add: start_of.simps, simp add: start_of.simps)
+ done
+ from h2 and this show "start_of ly a \<le> start_of ly (Suc b)"
+ by simp
+ qed
+qed
+
+lemma start_of_dec_length[simp]:
+ "\<lbrakk>abc_fetch a aprog = Some (Dec n e)\<rbrakk> \<Longrightarrow>
+ start_of (layout_of aprog) (Suc a)
+ = start_of (layout_of aprog) a + 2*n + 16"
+apply(case_tac a, auto simp: abc_fetch.simps start_of.simps
+ layout_of.simps length_of.simps
+ split: if_splits)
+done
+
+lemma start_of_ge:
+ "\<lbrakk>abc_fetch a aprog = Some (Dec n e); a < e\<rbrakk> \<Longrightarrow>
+ start_of (layout_of aprog) e >
+ start_of (layout_of aprog) a + 2*n + 15"
+apply(case_tac "e = Suc a",
+ simp add: start_of.simps abc_fetch.simps layout_of.simps
+ length_of.simps split: if_splits)
+apply(subgoal_tac "Suc a < e", drule_tac a = "Suc a"
+ and ly = "layout_of aprog" in start_of_le)
+apply(subgoal_tac "start_of (layout_of aprog) (Suc a)
+ = start_of (layout_of aprog) a + 2*n + 16", simp)
+apply(rule_tac start_of_dec_length, simp)
+apply(arith)
+done
+
+lemma starte_not_equal[simp]:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e); ly = layout_of aprog\<rbrakk>
+ \<Longrightarrow> (start_of ly e \<noteq> Suc (Suc (start_of ly as + 2 * n)) \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 3 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 4 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 5 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 6 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 7 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 8 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 9 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 10 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 11 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 12 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 13 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 14 \<and>
+ start_of ly e \<noteq> start_of ly as + 2 * n + 15)"
+apply(case_tac "e = as", simp)
+apply(case_tac "e < as")
+apply(drule_tac a = e and b = as and ly = ly in start_of_le, simp)
+apply(drule_tac a = as and e = e in start_of_ge, simp, simp)
+done
+
+lemma [simp]: "\<lbrakk>abc_fetch as aprog = Some (Dec n e); ly = layout_of aprog\<rbrakk>
+ \<Longrightarrow> (Suc (Suc (start_of ly as + 2 * n)) \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 3 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 4 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 5 \<noteq>start_of ly e \<and>
+ start_of ly as + 2 * n + 6 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 7 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 8 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 9 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 10 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 11 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 12 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 13 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 14 \<noteq> start_of ly e \<and>
+ start_of ly as + 2 * n + 15 \<noteq> start_of ly e)"
+apply(insert starte_not_equal[of as aprog n e ly],
+ simp del: starte_not_equal)
+apply(erule_tac conjE)+
+apply(rule_tac conjI, simp del: starte_not_equal)+
+apply(rule not_sym, simp)
+done
+
+lemma [simp]: "start_of (layout_of aprog) as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n as)) (Suc 0) Oc =
+ (R, Suc (start_of (layout_of aprog) as))"
+
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append
+ Suc_pre tdec_b_def)
+apply(insert findnth_nth[of 0 n "Suc 0"], simp)
+apply(simp add: findnth.simps)
+done
+
+lemma start_of_inj[simp]:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e); e \<noteq> as; ly = layout_of aprog\<rbrakk>
+ \<Longrightarrow> start_of ly as \<noteq> start_of ly e"
+apply(case_tac "e < as")
+apply(case_tac "as", simp, simp)
+apply(case_tac "e = nat", simp add: start_of.simps
+ layout_of.simps length_of.simps)
+apply(subgoal_tac "e < length aprog", simp add: length_of.simps
+ split: abc_inst.splits)
+apply(simp add: abc_fetch.simps split: if_splits)
+apply(subgoal_tac "e < nat", drule_tac a = e and b = nat
+ and ly =ly in start_of_le, simp)
+apply(subgoal_tac "start_of ly nat < start_of ly (Suc nat)",
+ simp, simp add: start_of.simps layout_of.simps)
+apply(subgoal_tac "nat < length aprog", simp)
+apply(case_tac "aprog ! nat", auto simp: length_of.simps)
+apply(simp add: abc_fetch.simps split: if_splits)
+apply(subgoal_tac "e > as", drule_tac start_of_ge, auto)
+done
+
+lemma [simp]: "\<lbrakk>abc_fetch as aprog = Some (Dec n e); e < as\<rbrakk>
+ \<Longrightarrow> Suc (start_of (layout_of aprog) e) -
+ start_of (layout_of aprog) as = 0"
+apply(frule_tac ly = "layout_of aprog" in start_of_le, simp)
+apply(subgoal_tac "start_of (layout_of aprog) as \<noteq>
+ start_of (layout_of aprog) e", arith)
+apply(rule start_of_inj, auto)
+done
+
+lemma [simp]:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e);
+ 0 < start_of (layout_of aprog) as\<rbrakk>
+ \<Longrightarrow> (fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e)) (Suc (start_of (layout_of aprog) e) -
+ start_of (layout_of aprog) as) Oc)
+ = (if e = as then (R, start_of (layout_of aprog) as + 1)
+ else (Nop, 0))"
+apply(auto split: if_splits)
+apply(case_tac "e < as", simp add: fetch.simps)
+apply(subgoal_tac " e > as")
+apply(drule start_of_ge, simp,
+ auto simp: fetch.simps ci_length nth_of.simps)
+apply(subgoal_tac
+ "length (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e)) div 2= length_of (Dec n e)")
+defer
+apply(simp add: ci_length)
+apply(subgoal_tac
+ "length (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e)) mod 2 = 0", auto simp: length_of.simps)
+done
+
+lemma [simp]:
+ "start_of (layout_of aprog) as > 0 \<Longrightarrow>
+ fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n as)) (Suc 0) Bk
+ = (W1, start_of (layout_of aprog) as)"
+apply(auto simp: ci.simps findnth.simps fetch.simps nth_of.simps
+ tshift.simps nth_append Suc_pre tdec_b_def)
+apply(insert findnth_nth[of 0 n "0"], simp)
+apply(simp add: findnth.simps)
+done
+
+lemma [simp]:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e);
+ 0 < start_of (layout_of aprog) as\<rbrakk>
+\<Longrightarrow> (fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e)) (Suc (start_of (layout_of aprog) e) -
+ start_of (layout_of aprog) as) Bk)
+ = (if e = as then (W1, start_of (layout_of aprog) as)
+ else (Nop, 0))"
+apply(auto split: if_splits)
+apply(case_tac "e < as", simp add: fetch.simps)
+apply(subgoal_tac " e > as")
+apply(drule start_of_ge, simp, auto simp: fetch.simps
+ ci_length nth_of.simps)
+apply(subgoal_tac
+ "length (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e)) div 2= length_of (Dec n e)")
+defer
+apply(simp add: ci_length)
+apply(subgoal_tac
+ "length (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e)) mod 2 = 0", auto simp: length_of.simps)
+apply(simp add: ci.simps tshift.simps tdec_b_def)
+done
+
+lemma [simp]:
+ "inv_stop (as, abc_lm_s am n (abc_lm_v am n)) (s, l, r) ires \<Longrightarrow> l \<noteq> []"
+apply(auto simp: inv_stop.simps)
+done
+
+lemma [simp]:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e); e \<noteq> as; ly = layout_of aprog\<rbrakk>
+ \<Longrightarrow> (\<not> (start_of ly as \<le> start_of ly e \<and>
+ start_of ly e < start_of ly as + 2 * n))
+ \<and> start_of ly e \<noteq> start_of ly as + 2*n \<and>
+ start_of ly e \<noteq> Suc (start_of ly as + 2*n) "
+apply(case_tac "e < as")
+apply(drule_tac ly = ly in start_of_le, simp)
+apply(case_tac n, simp, drule start_of_inj, simp, simp, simp, simp)
+apply(drule_tac start_of_ge, simp, simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e); start_of ly as \<le> s;
+ s < start_of ly as + 2 * n; ly = layout_of aprog\<rbrakk>
+ \<Longrightarrow> Suc s \<noteq> start_of ly e "
+apply(case_tac "e = as", simp)
+apply(case_tac "e < as")
+apply(drule_tac a = e and b = as and ly = ly in start_of_le, simp)
+apply(drule_tac start_of_ge, auto)
+done
+
+lemma [simp]: "\<lbrakk>abc_fetch as aprog = Some (Dec n e);
+ ly = layout_of aprog\<rbrakk>
+ \<Longrightarrow> Suc (start_of ly as + 2 * n) \<noteq> start_of ly e"
+apply(case_tac "e = as", simp)
+apply(case_tac "e < as")
+apply(drule_tac a = e and b = as and ly = ly in start_of_le, simp)
+apply(drule_tac start_of_ge, auto)
+done
+
+lemma dec_false_1[simp]:
+ "\<lbrakk>abc_lm_v am n = 0; inv_locate_b (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
+ \<Longrightarrow> False"
+apply(auto simp: inv_locate_b.simps in_middle.simps exponent_def)
+apply(case_tac "length lm1 \<ge> length am", auto)
+apply(subgoal_tac "lm2 = []", simp, subgoal_tac "m = 0", simp)
+apply(case_tac mr, auto simp: )
+apply(subgoal_tac "Suc (length lm1) - length am =
+ Suc (length lm1 - length am)",
+ simp add: rep_ind del: replicate.simps, simp)
+apply(drule_tac xs = "am @ replicate (Suc (length lm1) - length am) 0"
+ and ys = "lm1 @ m # lm2" in length_equal, simp)
+apply(case_tac mr, auto simp: abc_lm_v.simps)
+apply(case_tac "mr = 0", simp_all add: exponent_def split: if_splits)
+apply(subgoal_tac "Suc (length lm1) - length am =
+ Suc (length lm1 - length am)",
+ simp add: rep_ind del: replicate.simps, simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>inv_locate_b (as, am) (n, aaa, Bk # xs) ires;
+ abc_lm_v am n = 0\<rbrakk>
+ \<Longrightarrow> inv_on_left_moving (as, abc_lm_s am n 0)
+ (s, tl aaa, hd aaa # Bk # xs) ires"
+apply(insert inv_locate_b_2_on_left_moving[of as am n aaa xs ires s], simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>abc_lm_v am n = 0; inv_locate_b (as, am) (n, aaa, []) ires\<rbrakk>
+ \<Longrightarrow> inv_on_left_moving (as, abc_lm_s am n 0) (s, tl aaa, [hd aaa]) ires"
+apply(insert inv_locate_b_2_on_left_moving_b[of as am n aaa ires s], simp)
+done
+
+lemma [simp]: "\<lbrakk>am ! n = (0::nat); n < length am\<rbrakk> \<Longrightarrow> am[n := 0] = am"
+apply(simp add: list_update_same_conv)
+done
+
+lemma [simp]: "\<lbrakk>abc_lm_v am n = 0;
+ inv_locate_b (as, abc_lm_s am n 0) (n, Oc # aaa, xs) ires\<rbrakk>
+ \<Longrightarrow> inv_locate_b (as, am) (n, Oc # aaa, xs) ires"
+apply(simp only: inv_locate_b.simps in_middle.simps abc_lm_s.simps
+ abc_lm_v.simps)
+apply(erule_tac exE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI, simp)
+apply(case_tac "n < length am", simp_all)
+apply(erule_tac conjE)+
+apply(rule_tac x = tn in exI, rule_tac x = m in exI, simp)
+apply(rule_tac x = ml in exI, rule_tac x = mr in exI, simp)
+defer
+apply(rule_tac x = "Suc n - length am" in exI, rule_tac x = m in exI)
+apply(subgoal_tac "Suc n - length am = Suc (n - length am)")
+apply(simp add: exponent_def rep_ind del: replicate.simps, auto)
+done
+
+lemma [intro]: "\<lbrakk>abc_lm_v (a # list) 0 = 0\<rbrakk> \<Longrightarrow> a = 0"
+apply(simp add: abc_lm_v.simps split: if_splits)
+done
+
+lemma [simp]:
+ "inv_stop (as, abc_lm_s am n 0)
+ (start_of (layout_of aprog) e, aaa, Oc # xs) ires
+ \<Longrightarrow> inv_locate_a (as, abc_lm_s am n 0) (0, aaa, Oc # xs) ires"
+apply(simp add: inv_locate_a.simps)
+apply(rule disjI1)
+apply(auto simp: inv_stop.simps at_begin_norm.simps)
+done
+
+lemma [simp]:
+ "\<lbrakk>abc_lm_v am 0 = 0;
+ inv_stop (as, abc_lm_s am 0 0)
+ (start_of (layout_of aprog) e, aaa, Oc # xs) ires\<rbrakk> \<Longrightarrow>
+ inv_locate_b (as, am) (0, Oc # aaa, xs) ires"
+apply(auto simp: inv_stop.simps inv_locate_b.simps
+ in_middle.simps abc_lm_s.simps)
+apply(case_tac "am = []", simp)
+apply(rule_tac x = "[]" in exI, rule_tac x = "Suc 0" in exI,
+ rule_tac x = 0 in exI, simp)
+apply(rule_tac x = "Suc 0" in exI, rule_tac x = 0 in exI,
+ simp add: tape_of_nl_abv tape_of_nat_list.simps, auto)
+apply(case_tac rn, auto)
+apply(rule_tac x = "tl am" in exI, rule_tac x = 0 in exI,
+ rule_tac x = "hd am" in exI, simp)
+apply(rule_tac x = "Suc 0" in exI, rule_tac x = "hd am" in exI, simp)
+apply(case_tac am, simp, simp)
+apply(subgoal_tac "a = 0", case_tac list,
+ auto simp: tape_of_nat_list.simps tape_of_nl_abv)
+apply(case_tac rn, auto)
+done
+
+lemma [simp]:
+ "\<lbrakk>inv_stop (as, abc_lm_s am n 0)
+ (start_of (layout_of aprog) e, aaa, Oc # xs) ires\<rbrakk>
+ \<Longrightarrow> inv_locate_b (as, am) (0, Oc # aaa, xs) ires \<or>
+ inv_locate_b (as, abc_lm_s am n 0) (0, Oc # aaa, xs) ires"
+apply(simp)
+done
+
+lemma [simp]:
+"\<lbrakk>abc_lm_v am n = 0;
+ inv_stop (as, abc_lm_s am n 0)
+ (start_of (layout_of aprog) e, aaa, Oc # xs) ires\<rbrakk>
+ \<Longrightarrow> \<not> Suc 0 < 2 * n \<longrightarrow> e = as \<longrightarrow>
+ inv_locate_b (as, am) (n, Oc # aaa, xs) ires"
+apply(case_tac n, simp, simp)
+done
+
+lemma dec_false2:
+ "inv_stop (as, abc_lm_s am n 0)
+ (start_of (layout_of aprog) e, aaa, Bk # xs) ires = False"
+apply(auto simp: inv_stop.simps abc_lm_s.simps)
+apply(case_tac "am", simp, case_tac n, simp add: tape_of_nl_abv)
+apply(case_tac list, simp add: tape_of_nat_list.simps )
+apply(simp add: tape_of_nat_list.simps , simp)
+apply(case_tac "list[nat := 0]",
+ simp add: tape_of_nat_list.simps tape_of_nl_abv)
+apply(simp add: tape_of_nat_list.simps )
+apply(case_tac "am @ replicate (n - length am) 0 @ [0]", simp)
+apply(case_tac list, auto simp: tape_of_nl_abv
+ tape_of_nat_list.simps )
+done
+
+lemma dec_false3:
+ "inv_stop (as, abc_lm_s am n 0)
+ (start_of (layout_of aprog) e, aaa, []) ires = False"
+apply(auto simp: inv_stop.simps abc_lm_s.simps)
+apply(case_tac "am", case_tac n, auto)
+apply(case_tac n, auto simp: tape_of_nl_abv)
+apply(case_tac "list::nat list",
+ simp add: tape_of_nat_list.simps tape_of_nat_list.simps)
+apply(simp add: tape_of_nat_list.simps)
+apply(case_tac "list[nat := 0]",
+ simp add: tape_of_nat_list.simps tape_of_nat_list.simps)
+apply(simp add: tape_of_nat_list.simps)
+apply(case_tac "(am @ replicate (n - length am) 0 @ [0])", simp)
+apply(case_tac list, auto simp: tape_of_nat_list.simps)
+done
+
+lemma [simp]:
+ "fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Dec n e)) 0 b = (Nop, 0)"
+by(simp add: fetch.simps)
+
+declare dec_inv_1.simps[simp del]
+
+declare inv_locate_n_b.simps [simp del]
+
+lemma [simp]:
+"\<lbrakk>0 < abc_lm_v am n; 0 < n;
+ at_begin_norm (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
+ \<Longrightarrow> inv_locate_n_b (as, am) (n, Oc # aaa, xs) ires"
+apply(simp only: at_begin_norm.simps inv_locate_n_b.simps)
+apply(erule_tac exE)+
+apply(rule_tac x = lm1 in exI, simp)
+apply(case_tac "length lm2", simp)
+apply(case_tac rn, simp, simp)
+apply(rule_tac x = "tl lm2" in exI, rule_tac x = "hd lm2" in exI, simp)
+apply(rule conjI)
+apply(case_tac "lm2", simp, simp)
+apply(case_tac "lm2", auto simp: tape_of_nl_abv tape_of_nat_list.simps)
+apply(case_tac [!] "list", auto simp: tape_of_nl_abv tape_of_nat_list.simps)
+apply(case_tac rn, auto)
+done
+lemma [simp]: "(\<exists>rn. Oc # xs = Bk\<^bsup>rn\<^esup>) = False"
+apply(auto)
+apply(case_tac rn, auto simp: )
+done
+
+lemma [simp]:
+ "\<lbrakk>0 < abc_lm_v am n; 0 < n;
+ at_begin_fst_bwtn (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
+ \<Longrightarrow> inv_locate_n_b (as, am) (n, Oc # aaa, xs) ires"
+apply(simp add: at_begin_fst_bwtn.simps inv_locate_n_b.simps )
+done
+
+lemma Suc_minus:"length am + tn = n
+ \<Longrightarrow> Suc tn = Suc n - length am "
+apply(arith)
+done
+
+lemma [simp]:
+ "\<lbrakk>0 < abc_lm_v am n; 0 < n;
+ at_begin_fst_awtn (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
+ \<Longrightarrow> inv_locate_n_b (as, am) (n, Oc # aaa, xs) ires"
+apply(simp only: at_begin_fst_awtn.simps inv_locate_n_b.simps )
+apply(erule exE)+
+apply(erule conjE)+
+apply(rule_tac x = lm1 in exI, rule_tac x = "[]" in exI,
+ rule_tac x = "Suc tn" in exI, rule_tac x = 0 in exI)
+apply(simp add: exponent_def rep_ind del: replicate.simps)
+apply(rule conjI)+
+apply(auto)
+apply(case_tac [!] rn, auto)
+done
+
+lemma [simp]:
+ "\<lbrakk>0 < abc_lm_v am n; 0 < n; inv_locate_a (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
+ \<Longrightarrow> inv_locate_n_b (as, am) (n, Oc#aaa, xs) ires"
+apply(auto simp: inv_locate_a.simps)
+done
+
+lemma [simp]:
+ "\<lbrakk>inv_locate_n_b (as, am) (n, aaa, Oc # xs) ires\<rbrakk>
+ \<Longrightarrow> dec_first_on_right_moving n (as, abc_lm_s am n (abc_lm_v am n))
+ (s, Oc # aaa, xs) ires"
+apply(auto simp: inv_locate_n_b.simps dec_first_on_right_moving.simps
+ abc_lm_s.simps abc_lm_v.simps)
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI, simp)
+apply(rule_tac x = "Suc (Suc 0)" in exI,
+ rule_tac x = "m - 1" in exI, simp)
+apply(case_tac m, auto simp: exponent_def)
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI,
+ simp add: Suc_diff_le rep_ind del: replicate.simps)
+apply(rule_tac x = "Suc (Suc 0)" in exI,
+ rule_tac x = "m - 1" in exI, simp)
+apply(case_tac m, auto simp: exponent_def)
+apply(rule_tac x = lm1 in exI, rule_tac x = "[]" in exI,
+ rule_tac x = m in exI, simp)
+apply(rule_tac x = "Suc (Suc 0)" in exI,
+ rule_tac x = "m - 1" in exI, simp)
+apply(case_tac m, auto)
+apply(rule_tac x = lm1 in exI, rule_tac x = lm2 in exI,
+ rule_tac x = m in exI,
+ simp add: Suc_diff_le rep_ind del: replicate.simps, simp)
+done
+
+lemma dec_false_2:
+ "\<lbrakk>0 < abc_lm_v am n; inv_locate_n_b (as, am) (n, aaa, Bk # xs) ires\<rbrakk>
+ \<Longrightarrow> False"
+apply(auto simp: inv_locate_n_b.simps abc_lm_v.simps split: if_splits)
+apply(case_tac [!] m, auto)
+done
+
+lemma dec_false_2_b:
+ "\<lbrakk>0 < abc_lm_v am n; inv_locate_n_b (as, am)
+ (n, aaa, []) ires\<rbrakk> \<Longrightarrow> False"
+apply(auto simp: inv_locate_n_b.simps abc_lm_v.simps split: if_splits)
+apply(case_tac [!] m, auto simp: )
+done
+
+
+(*begin: dec halt1 lemmas*)
+thm abc_inc_stage1.simps
+fun abc_dec_1_stage1:: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_dec_1_stage1 (s, l, r) ss n =
+ (if s > ss \<and> s \<le> ss + 2*n + 1 then 4
+ else if s = ss + 2 * n + 13 \<or> s = ss + 2*n + 14 then 3
+ else if s = ss + 2*n + 15 then 2
+ else 0)"
+
+fun abc_dec_1_stage2:: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_dec_1_stage2 (s, l, r) ss n =
+ (if s \<le> ss + 2 * n + 1 then (ss + 2 * n + 16 - s)
+ else if s = ss + 2*n + 13 then length l
+ else if s = ss + 2*n + 14 then length l
+ else 0)"
+
+fun abc_dec_1_stage3 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> block list \<Rightarrow> nat"
+ where
+ "abc_dec_1_stage3 (s, l, r) ss n ires =
+ (if s \<le> ss + 2*n + 1 then
+ if (s - ss) mod 2 = 0 then
+ if r \<noteq> [] \<and> hd r = Oc then 0 else 1
+ else length r
+ else if s = ss + 2 * n + 13 then
+ if l = Bk # ires \<and> r \<noteq> [] \<and> hd r = Oc then 2
+ else 1
+ else if s = ss + 2 * n + 14 then
+ if r \<noteq> [] \<and> hd r = Oc then 3 else 0
+ else 0)"
+
+fun abc_dec_1_measure :: "(t_conf \<times> nat \<times> nat \<times> block list) \<Rightarrow> (nat \<times> nat \<times> nat)"
+ where
+ "abc_dec_1_measure (c, ss, n, ires) = (abc_dec_1_stage1 c ss n,
+ abc_dec_1_stage2 c ss n, abc_dec_1_stage3 c ss n ires)"
+
+definition abc_dec_1_LE ::
+ "(((nat \<times> block list \<times> block list) \<times> nat \<times>
+ nat \<times> block list) \<times> ((nat \<times> block list \<times> block list) \<times> nat \<times> nat \<times> block list)) set"
+ where "abc_dec_1_LE \<equiv> (inv_image lex_triple abc_dec_1_measure)"
+
+lemma wf_dec_le: "wf abc_dec_1_LE"
+by(auto intro:wf_inv_image wf_lex_triple simp:abc_dec_1_LE_def)
+
+declare dec_inv_1.simps[simp del] dec_inv_2.simps[simp del]
+
+lemma [elim]:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e);
+ start_of (layout_of aprog) as < start_of (layout_of aprog) e;
+ start_of (layout_of aprog) e \<le>
+ Suc (start_of (layout_of aprog) as + 2 * n)\<rbrakk> \<Longrightarrow> False"
+apply(case_tac "e = as", simp)
+apply(case_tac "e < as")
+apply(drule_tac a = e and b = as and ly = "layout_of aprog" in
+ start_of_le, simp)
+apply(drule_tac start_of_ge, auto)
+done
+
+lemma [elim]: "\<lbrakk>abc_fetch as aprog = Some (Dec n e);
+ start_of (layout_of aprog) e
+ = start_of (layout_of aprog) as + 2 * n + 13\<rbrakk>
+ \<Longrightarrow> False"
+apply(insert starte_not_equal[of as aprog n e "layout_of aprog"],
+ simp)
+done
+
+lemma [elim]: "\<lbrakk>abc_fetch as aprog = Some (Dec n e);
+ start_of (layout_of aprog) e =
+ start_of (layout_of aprog) as + 2 * n + 14\<rbrakk>
+ \<Longrightarrow> False"
+apply(insert starte_not_equal[of as aprog n e "layout_of aprog"],
+ simp)
+done
+
+lemma [elim]:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e);
+ start_of (layout_of aprog) as < start_of (layout_of aprog) e;
+ start_of (layout_of aprog) e \<le>
+ Suc (start_of (layout_of aprog) as + 2 * n)\<rbrakk>
+ \<Longrightarrow> False"
+apply(case_tac "e = as", simp)
+apply(case_tac "e < as")
+apply(drule_tac a = e and b = as and ly = "layout_of aprog" in
+ start_of_le, simp)
+apply(drule_tac start_of_ge, auto)
+done
+
+lemma [elim]:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e);
+ start_of (layout_of aprog) e =
+ start_of (layout_of aprog) as + 2 * n + 13\<rbrakk>
+ \<Longrightarrow> False"
+apply(insert starte_not_equal[of as aprog n e "layout_of aprog"],
+ simp)
+done
+
+lemma [simp]:
+ "abc_fetch as aprog = Some (Dec n e) \<Longrightarrow>
+ Suc (start_of (layout_of aprog) as) \<noteq> start_of (layout_of aprog) e"
+apply(case_tac "e = as", simp)
+apply(case_tac "e < as")
+apply(drule_tac a = e and b = as and ly = "(layout_of aprog)" in
+ start_of_le, simp)
+apply(drule_tac a = as and e = e in start_of_ge, simp, simp)
+done
+
+lemma [simp]: "inv_on_left_moving (as, am) (s, [], r) ires
+ = False"
+apply(simp add: inv_on_left_moving.simps inv_on_left_moving_norm.simps
+ inv_on_left_moving_in_middle_B.simps)
+done
+
+lemma [simp]:
+ "inv_check_left_moving (as, abc_lm_s am n 0)
+ (start_of (layout_of aprog) as + 2 * n + 14, [], Oc # xs) ires
+ = False"
+apply(simp add: inv_check_left_moving.simps inv_check_left_moving_in_middle.simps)
+done
+
+lemma dec_inv_stop1_pre:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e); abc_lm_v am n = 0;
+ start_of (layout_of aprog) as > 0\<rbrakk>
+ \<Longrightarrow> \<forall>na. \<not> (\<lambda>(s, l, r) (ss, n', ires'). s = start_of (layout_of aprog) e)
+ (t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) na)
+ (start_of (layout_of aprog) as, n, ires) \<and>
+ dec_inv_1 (layout_of aprog) n e (as, am)
+ (t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) na) ires
+ \<longrightarrow> dec_inv_1 (layout_of aprog) n e (as, am)
+ (t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0)
+ (Suc na)) ires \<and>
+ ((t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) (Suc na),
+ start_of (layout_of aprog) as, n, ires),
+ t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) na,
+ start_of (layout_of aprog) as, n, ires)
+ \<in> abc_dec_1_LE"
+apply(rule allI, rule impI, simp add: t_steps_ind)
+apply(case_tac "(t_steps (Suc (start_of (layout_of aprog) as), l, r)
+(ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+start_of (layout_of aprog) as - Suc 0) na)", simp)
+apply(auto split:if_splits simp add:t_step.simps dec_inv_1.simps,
+ tactic {* ALLGOALS (resolve_tac [@{thm fetch_intro}]) *})
+apply(simp_all add:dec_fetch_simps new_tape.simps dec_inv_1.simps)
+apply(auto simp add: abc_dec_1_LE_def lex_square_def
+ lex_triple_def lex_pair_def
+ split: if_splits)
+apply(rule dec_false_1, simp, simp)
+done
+
+lemma dec_inv_stop1:
+ "\<lbrakk>ly = layout_of aprog;
+ dec_inv_1 ly n e (as, am) (start_of ly as + 1, l, r) ires;
+ abc_fetch as aprog = Some (Dec n e); abc_lm_v am n = 0\<rbrakk> \<Longrightarrow>
+ (\<exists> stp. (\<lambda> (s', l', r'). s' = start_of ly e \<and>
+ dec_inv_1 ly n e (as, am) (s', l' , r') ires)
+ (t_steps (start_of ly as + 1, l, r)
+ (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) stp))"
+apply(insert halt_lemma2[of abc_dec_1_LE
+ "\<lambda> ((s, l, r), ss, n', ires'). s = start_of ly e"
+ "(\<lambda> stp. (t_steps (start_of ly as + 1, l, r)
+ (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0)
+ stp, start_of ly as, n, ires))"
+ "\<lambda> ((s, l, r), ss, n, ires'). dec_inv_1 ly n e (as, am) (s, l, r) ires'"],
+ simp)
+apply(insert wf_dec_le, simp)
+apply(insert dec_inv_stop1_pre[of as aprog n e am l r], simp)
+apply(subgoal_tac "start_of (layout_of aprog) as > 0",
+ simp add: t_steps.simps)
+apply(erule_tac exE, rule_tac x = na in exI)
+apply(case_tac
+ "(t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) na)",
+ case_tac b, auto)
+apply(rule startof_not0)
+done
+
+(*begin: dec halt2 lemmas*)
+
+lemma [simp]:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e);
+ ly = layout_of aprog\<rbrakk> \<Longrightarrow>
+ start_of ly (Suc as) = start_of ly as + 2*n + 16"
+by simp
+
+fun abc_dec_2_stage1 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_dec_2_stage1 (s, l, r) ss n =
+ (if s \<le> ss + 2*n + 1 then 7
+ else if s = ss + 2*n + 2 then 6
+ else if s = ss + 2*n + 3 then 5
+ else if s \<ge> ss + 2*n + 4 \<and> s \<le> ss + 2*n + 9 then 4
+ else if s = ss + 2*n + 6 then 3
+ else if s = ss + 2*n + 10 \<or> s = ss + 2*n + 11 then 2
+ else if s = ss + 2*n + 12 then 1
+ else 0)"
+
+thm new_tape.simps
+
+fun abc_dec_2_stage2 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_dec_2_stage2 (s, l, r) ss n =
+ (if s \<le> ss + 2 * n + 1 then (ss + 2 * n + 16 - s)
+ else if s = ss + 2*n + 10 then length l
+ else if s = ss + 2*n + 11 then length l
+ else if s = ss + 2*n + 4 then length r - 1
+ else if s = ss + 2*n + 5 then length r
+ else if s = ss + 2*n + 7 then length r - 1
+ else if s = ss + 2*n + 8 then
+ length r + length (takeWhile (\<lambda> a. a = Oc) l) - 1
+ else if s = ss + 2*n + 9 then
+ length r + length (takeWhile (\<lambda> a. a = Oc) l) - 1
+ else 0)"
+
+fun abc_dec_2_stage3 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> block list \<Rightarrow> nat"
+ where
+ "abc_dec_2_stage3 (s, l, r) ss n ires =
+ (if s \<le> ss + 2*n + 1 then
+ if (s - ss) mod 2 = 0 then if r \<noteq> [] \<and>
+ hd r = Oc then 0 else 1
+ else length r
+ else if s = ss + 2 * n + 10 then
+ if l = Bk # ires \<and> r \<noteq> [] \<and> hd r = Oc then 2
+ else 1
+ else if s = ss + 2 * n + 11 then
+ if r \<noteq> [] \<and> hd r = Oc then 3
+ else 0
+ else (ss + 2 * n + 16 - s))"
+
+fun abc_dec_2_stage4 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_dec_2_stage4 (s, l, r) ss n =
+ (if s = ss + 2*n + 2 then length r
+ else if s = ss + 2*n + 8 then length r
+ else if s = ss + 2*n + 3 then
+ if r \<noteq> [] \<and> hd r = Oc then 1
+ else 0
+ else if s = ss + 2*n + 7 then
+ if r \<noteq> [] \<and> hd r = Oc then 0
+ else 1
+ else if s = ss + 2*n + 9 then
+ if r \<noteq> [] \<and> hd r = Oc then 1
+ else 0
+ else 0)"
+
+fun abc_dec_2_measure :: "(t_conf \<times> nat \<times> nat \<times> block list) \<Rightarrow>
+ (nat \<times> nat \<times> nat \<times> nat)"
+ where
+ "abc_dec_2_measure (c, ss, n, ires) =
+ (abc_dec_2_stage1 c ss n, abc_dec_2_stage2 c ss n,
+ abc_dec_2_stage3 c ss n ires, abc_dec_2_stage4 c ss n)"
+
+definition abc_dec_2_LE ::
+ "(((nat \<times> block list \<times> block list) \<times> nat \<times> nat \<times> block list) \<times>
+ ((nat \<times> block list \<times> block list) \<times> nat \<times> nat \<times> block list)) set"
+ where "abc_dec_2_LE \<equiv> (inv_image lex_square abc_dec_2_measure)"
+
+lemma wf_dec_2_le: "wf abc_dec_2_LE"
+by(auto intro:wf_inv_image wf_lex_triple wf_lex_square
+ simp:abc_dec_2_LE_def)
+
+lemma [simp]: "dec_after_write (as, am) (s, aa, r) ires
+ \<Longrightarrow> takeWhile (\<lambda>a. a = Oc) aa = []"
+apply(simp only : dec_after_write.simps)
+apply(erule exE)+
+apply(erule_tac conjE)+
+apply(case_tac aa, simp)
+apply(case_tac a, simp only: takeWhile.simps , simp, simp split: if_splits)
+done
+
+lemma [simp]:
+ "\<lbrakk>dec_on_right_moving (as, lm) (s, aa, []) ires;
+ length (takeWhile (\<lambda>a. a = Oc) (tl aa))
+ \<noteq> length (takeWhile (\<lambda>a. a = Oc) aa) - Suc 0\<rbrakk>
+ \<Longrightarrow> length (takeWhile (\<lambda>a. a = Oc) (tl aa)) <
+ length (takeWhile (\<lambda>a. a = Oc) aa) - Suc 0"
+apply(simp only: dec_on_right_moving.simps)
+apply(erule_tac exE)+
+apply(erule_tac conjE)+
+apply(case_tac mr, auto split: if_splits)
+done
+
+lemma [simp]:
+ "dec_after_clear (as, abc_lm_s am n (abc_lm_v am n - Suc 0))
+ (start_of (layout_of aprog) as + 2 * n + 9, aa, Bk # xs) ires
+ \<Longrightarrow> length xs - Suc 0 < length xs +
+ length (takeWhile (\<lambda>a. a = Oc) aa)"
+apply(simp only: dec_after_clear.simps)
+apply(erule_tac exE)+
+apply(erule conjE)+
+apply(simp split: if_splits )
+done
+
+lemma [simp]:
+ "\<lbrakk>dec_after_clear (as, abc_lm_s am n (abc_lm_v am n - Suc 0))
+ (start_of (layout_of aprog) as + 2 * n + 9, aa, []) ires\<rbrakk>
+ \<Longrightarrow> Suc 0 < length (takeWhile (\<lambda>a. a = Oc) aa)"
+apply(simp add: dec_after_clear.simps split: if_splits)
+done
+
+lemma [simp]:
+ "\<lbrakk>dec_on_right_moving (as, am) (s, aa, Bk # xs) ires;
+ Suc (length (takeWhile (\<lambda>a. a = Oc) (tl aa)))
+ \<noteq> length (takeWhile (\<lambda>a. a = Oc) aa)\<rbrakk>
+ \<Longrightarrow> Suc (length (takeWhile (\<lambda>a. a = Oc) (tl aa)))
+ < length (takeWhile (\<lambda>a. a = Oc) aa)"
+apply(simp only: dec_on_right_moving.simps)
+apply(erule exE)+
+apply(erule conjE)+
+apply(case_tac ml, auto split: if_splits )
+done
+
+(*
+lemma abc_dec_2_wf:
+ "\<lbrakk>ly = layout_of aprog; dec_inv_2 ly n e (as, am) (start_of ly as + 1, l, r); abc_fetch as aprog = Dec n e; abc_lm_v am n > 0\<rbrakk>
+ \<Longrightarrow> \<forall>na. \<not> (\<lambda>(s, l, r) (ss, n'). s = start_of (layout_of aprog) as + 2*n + 16)
+ (t_steps (Suc (start_of (layout_of aprog) as), l, r) (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e), start_of (layout_of aprog) as - Suc 0) na)
+ (start_of (layout_of aprog) as, n) \<longrightarrow>
+ ((t_steps (Suc (start_of (layout_of aprog) as), l, r) (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e), start_of (layout_of aprog) as - Suc 0) (Suc na),
+ start_of (layout_of aprog) as, n),
+ t_steps (Suc (start_of (layout_of aprog) as), l, r) (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e), start_of (layout_of aprog) as - Suc 0) na,
+ start_of (layout_of aprog) as, n)
+ \<in> abc_dec_2_LE"
+proof(rule allI, rule impI, simp add: t_steps_ind)
+ fix na
+ assume h1 :"ly = layout_of aprog" "dec_inv_2 (layout_of aprog) n e (as, am) (Suc (start_of (layout_of aprog) as), l, r)"
+ "abc_fetch as aprog = Dec n e" "abc_lm_v am n > 0"
+ "\<not> (\<lambda>(s, l, r) (ss, n'). s = start_of (layout_of aprog) as + 2*n + 16)
+ (t_steps (Suc (start_of (layout_of aprog) as), l, r) (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e), start_of (layout_of aprog) as - Suc 0) na)
+ (start_of (layout_of aprog) as, n)"
+ thus "((t_step (t_steps (Suc (start_of (layout_of aprog) as), l, r) (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e), start_of (layout_of aprog) as - Suc 0) na)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e), start_of (layout_of aprog) as - Suc 0),
+ start_of (layout_of aprog) as, n),
+ t_steps (Suc (start_of (layout_of aprog) as), l, r) (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e), start_of (layout_of aprog) as - Suc 0) na,
+ start_of (layout_of aprog) as, n)
+ \<in> abc_dec_2_LE"
+ proof(insert dec_inv_2_steps[of "layout_of aprog" n e as am "(start_of (layout_of aprog) as + 1, l, r)" aprog na],
+ case_tac "(t_steps (start_of (layout_of aprog) as + 1, l, r) (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e), start_of (layout_of aprog) as - Suc 0) na)", case_tac b, simp)
+ fix a b aa ba
+ assume "dec_inv_2 (layout_of aprog) n e (as, am) (a, aa, ba)" " a \<noteq> start_of (layout_of aprog) as + 2*n + 16" "abc_lm_v am n > 0" "abc_fetch as aprog = Dec n e "
+ thus "((t_step (a, aa, ba) (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e), start_of (layout_of aprog) as - Suc 0), start_of (layout_of aprog) as, n), (a, aa, ba),
+ start_of (layout_of aprog) as, n)
+ \<in> abc_dec_2_LE"
+ apply(case_tac "a = 0", auto split:if_splits simp add:t_step.simps dec_inv_2.simps,
+ tactic {* ALLGOALS (resolve_tac (thms "fetch_intro")) *})
+ apply(simp_all add:dec_fetch_simps new_tape.simps)
+ apply(auto simp add: abc_dec_2_LE_def lex_square_def lex_triple_def lex_pair_def
+ split: if_splits)
+
+ done
+ qed
+qed
+*)
+
+lemma [simp]: "inv_check_left_moving (as, abc_lm_s am n (abc_lm_v am n - Suc 0))
+ (start_of (layout_of aprog) as + 2 * n + 11, [], Oc # xs) ires = False"
+apply(simp add: inv_check_left_moving.simps inv_check_left_moving_in_middle.simps)
+done
+
+lemma dec_inv_stop2_pre:
+ "\<lbrakk>abc_fetch as aprog = Some (Dec n e); abc_lm_v am n > 0\<rbrakk> \<Longrightarrow>
+ \<forall>na. \<not> (\<lambda>(s, l, r) (ss, n', ires').
+ s = start_of (layout_of aprog) as + 2 * n + 16)
+ (t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) na)
+ (start_of (layout_of aprog) as, n, ires) \<and>
+ dec_inv_2 (layout_of aprog) n e (as, am)
+ (t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) na) ires
+ \<longrightarrow>
+ dec_inv_2 (layout_of aprog) n e (as, am)
+ (t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) (Suc na)) ires \<and>
+ ((t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) (Suc na),
+ start_of (layout_of aprog) as, n, ires),
+ t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) na,
+ start_of (layout_of aprog) as, n, ires)
+ \<in> abc_dec_2_LE"
+apply(subgoal_tac "start_of (layout_of aprog) as > 0")
+apply(rule allI, rule impI, simp add: t_steps_ind)
+apply(case_tac "(t_steps (Suc (start_of (layout_of aprog) as), l, r)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) na)", simp)
+apply(auto split:if_splits simp add:t_step.simps dec_inv_2.simps,
+ tactic {* ALLGOALS (resolve_tac [@{thm fetch_intro}]) *})
+apply(simp_all add:dec_fetch_simps new_tape.simps dec_inv_2.simps)
+apply(auto simp add: abc_dec_2_LE_def lex_square_def lex_triple_def
+ lex_pair_def split: if_splits)
+apply(auto intro: dec_false_2_b dec_false_2)
+apply(rule startof_not0)
+done
+
+lemma dec_stop2:
+ "\<lbrakk>ly = layout_of aprog;
+ dec_inv_2 ly n e (as, am) (start_of ly as + 1, l, r) ires;
+ abc_fetch as aprog = Some (Dec n e);
+ abc_lm_v am n > 0\<rbrakk> \<Longrightarrow>
+ (\<exists> stp. (\<lambda> (s', l', r'). s' = start_of ly (Suc as) \<and>
+ dec_inv_2 ly n e (as, am) (s', l', r') ires)
+ (t_steps (start_of ly as+1, l, r) (ci ly (start_of ly as)
+ (Dec n e), start_of ly as - Suc 0) stp))"
+apply(insert halt_lemma2[of abc_dec_2_LE
+ "\<lambda> ((s, l, r), ss, n', ires'). s = start_of ly (Suc as)"
+ "(\<lambda> stp. (t_steps (start_of ly as + 1, l, r)
+ (ci ly (start_of ly as) (Dec n e), start_of ly as - Suc 0) stp,
+ start_of ly as, n, ires))"
+ "(\<lambda> ((s, l, r), ss, n, ires'). dec_inv_2 ly n e (as, am) (s, l, r) ires')"])
+apply(insert wf_dec_2_le, simp)
+apply(insert dec_inv_stop2_pre[of as aprog n e am l r],
+ simp add: t_steps.simps)
+apply(erule_tac exE)
+apply(rule_tac x = na in exI)
+apply(case_tac "(t_steps (Suc (start_of (layout_of aprog) as), l, r)
+(ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) na)",
+ case_tac b, auto)
+done
+
+lemma dec_inv_stop_cond1:
+ "\<lbrakk>ly = layout_of aprog;
+ dec_inv_1 ly n e (as, lm) (s, (l, r)) ires; s = start_of ly e;
+ abc_fetch as aprog = Some (Dec n e); abc_lm_v lm n = 0\<rbrakk>
+ \<Longrightarrow> crsp_l ly (e, abc_lm_s lm n 0) (s, l, r) ires"
+apply(simp add: dec_inv_1.simps split: if_splits)
+apply(auto simp: crsp_l.simps inv_stop.simps )
+done
+
+lemma dec_inv_stop_cond2:
+ "\<lbrakk>ly = layout_of aprog; s = start_of ly (Suc as);
+ dec_inv_2 ly n e (as, lm) (s, (l, r)) ires;
+ abc_fetch as aprog = Some (Dec n e);
+ abc_lm_v lm n > 0\<rbrakk>
+ \<Longrightarrow> crsp_l ly (Suc as,
+ abc_lm_s lm n (abc_lm_v lm n - Suc 0)) (s, l, r) ires"
+apply(simp add: dec_inv_2.simps split: if_splits)
+apply(auto simp: crsp_l.simps inv_stop.simps )
+done
+
+lemma [simp]: "(case Bk\<^bsup>rn\<^esup> of [] \<Rightarrow> Bk |
+ Bk # xs \<Rightarrow> Bk | Oc # xs \<Rightarrow> Oc) = Bk"
+apply(case_tac rn, auto)
+done
+
+lemma [simp]: "t_steps tc (p,off) (m + n) =
+ t_steps (t_steps tc (p, off) m) (p, off) n"
+apply(induct m arbitrary: n)
+apply(simp add: t_steps.simps)
+proof -
+ fix m n
+ assume h1: "\<And>n. t_steps tc (p, off) (m + n) =
+ t_steps (t_steps tc (p, off) m) (p, off) n"
+ hence h2: "t_steps tc (p, off) (Suc m + n) =
+ t_steps tc (p, off) (m + Suc n)"
+ by simp
+ from h1 and this show
+ "t_steps tc (p, off) (Suc m + n) =
+ t_steps (t_steps tc (p, off) (Suc m)) (p, off) n"
+ proof(simp only: h2, simp add: t_steps.simps)
+ have h3: "(t_step (t_steps tc (p, off) m) (p, off)) =
+ (t_steps (t_step tc (p, off)) (p, off) m)"
+ apply(simp add: t_steps.simps[THEN sym] t_steps_ind[THEN sym])
+ done
+ from h3 show
+ "t_steps (t_step (t_steps tc (p, off) m) (p, off)) (p, off) n = t_steps (t_steps (t_step tc (p, off)) (p, off) m) (p, off) n"
+ by simp
+ qed
+qed
+
+lemma [simp]: " abc_fetch as aprog = Some (Dec n e) \<Longrightarrow>
+ Suc (start_of (layout_of aprog) as) \<noteq>
+ start_of (layout_of aprog) e"
+apply(case_tac "e = as", simp)
+apply(case_tac "e < as")
+apply(drule_tac a = e and b = as and ly = "layout_of aprog"
+ in start_of_le, simp)
+apply(drule_tac start_of_ge, auto)
+done
+
+lemma [simp]: "inv_locate_b (as, []) (0, Oc # Bk # Bk # ires, Bk\<^bsup>rn - Suc 0\<^esup>) ires"
+apply(auto simp: inv_locate_b.simps in_middle.simps)
+apply(rule_tac x = "[]" in exI, rule_tac x = "Suc 0" in exI,
+ rule_tac x = 0 in exI, simp)
+apply(rule_tac x = "Suc 0" in exI, rule_tac x = 0 in exI, auto)
+apply(case_tac rn, simp, case_tac nat, auto)
+done
+
+lemma [simp]:
+ "inv_locate_n_b (as, []) (0, Oc # Bk # Bk # ires, Bk\<^bsup>rn - Suc 0\<^esup>) ires"
+apply(auto simp: inv_locate_n_b.simps in_middle.simps)
+apply(case_tac rn, simp, case_tac nat, auto)
+done
+
+lemma [simp]:
+"abc_fetch as aprog = Some (Dec n e) \<Longrightarrow>
+ dec_inv_1 (layout_of aprog) n e (as, [])
+ (Suc (start_of (layout_of aprog) as), Oc # Bk # Bk # ires, Bk\<^bsup>rn - Suc 0\<^esup>) ires
+\<and>
+ dec_inv_2 (layout_of aprog) n e (as, [])
+ (Suc (start_of (layout_of aprog) as), Oc # Bk # Bk # ires, Bk\<^bsup>rn - Suc 0\<^esup>) ires"
+apply(simp add: dec_inv_1.simps dec_inv_2.simps)
+apply(case_tac n, auto)
+done
+
+lemma [simp]:
+ "\<lbrakk>am \<noteq> []; <am> = Oc # r';
+ abc_fetch as aprog = Some (Dec n e)\<rbrakk>
+ \<Longrightarrow> inv_locate_b (as, am) (0, Oc # Bk # Bk # ires, r' @ Bk\<^bsup>rn\<^esup>) ires"
+apply(auto simp: inv_locate_b.simps in_middle.simps)
+apply(rule_tac x = "tl am" in exI, rule_tac x = 0 in exI,
+ rule_tac x = "hd am" in exI, simp)
+apply(rule_tac x = "Suc 0" in exI)
+apply(rule_tac x = "hd am" in exI, simp)
+apply(case_tac am, simp, case_tac list, auto simp: tape_of_nl_abv tape_of_nat_list.simps)
+apply(case_tac rn, auto)
+done
+
+lemma [simp]:
+ "\<lbrakk><am> = Oc # r'; abc_fetch as aprog = Some (Dec n e)\<rbrakk> \<Longrightarrow>
+ inv_locate_n_b (as, am) (0, Oc # Bk # Bk # ires, r' @ Bk\<^bsup>rn\<^esup>) ires"
+apply(auto simp: inv_locate_n_b.simps)
+apply(rule_tac x = "tl am" in exI, rule_tac x = "hd am" in exI, auto)
+apply(case_tac [!] am, auto simp: tape_of_nl_abv tape_of_nat_list.simps )
+apply(case_tac [!]list, auto simp: tape_of_nl_abv tape_of_nat_list.simps)
+apply(case_tac rn, simp, simp)
+apply(erule_tac x = nat in allE, simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>am \<noteq> [];
+ <am> = Oc # r';
+ abc_fetch as aprog = Some (Dec n e)\<rbrakk> \<Longrightarrow>
+ dec_inv_1 (layout_of aprog) n e (as, am)
+ (Suc (start_of (layout_of aprog) as),
+ Oc # Bk # Bk # ires, r' @ Bk\<^bsup>rn\<^esup>) ires \<and>
+ dec_inv_2 (layout_of aprog) n e (as, am)
+ (Suc (start_of (layout_of aprog) as),
+ Oc # Bk # Bk # ires, r' @ Bk\<^bsup>rn\<^esup>) ires"
+apply(simp add: dec_inv_1.simps dec_inv_2.simps)
+apply(case_tac n, auto)
+done
+
+lemma [simp]: "am \<noteq> [] \<Longrightarrow> \<exists>r'. <am::nat list> = Oc # r'"
+apply(case_tac am, simp, case_tac list)
+apply(auto simp: tape_of_nl_abv tape_of_nat_list.simps )
+done
+
+lemma [simp]: "start_of (layout_of aprog) as > 0 \<Longrightarrow>
+ (fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Dec n e)) (Suc 0) Bk)
+ = (W1, start_of (layout_of aprog) as)"
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append Suc_pre tdec_b_def)
+thm findnth_nth
+apply(insert findnth_nth[of 0 n 0], simp)
+apply(simp add: findnth.simps)
+done
+
+lemma [simp]:
+ "start_of (layout_of aprog) as > 0
+ \<Longrightarrow> (t_step (start_of (layout_of aprog) as, Bk # Bk # ires, Bk\<^bsup>rn\<^esup>)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0))
+ = (start_of (layout_of aprog) as, Bk # Bk # ires, Oc # Bk\<^bsup>rn- Suc 0\<^esup>)"
+apply(simp add: t_step.simps)
+apply(case_tac "start_of (layout_of aprog) as",
+ auto simp: new_tape.simps)
+apply(case_tac rn, auto)
+done
+
+lemma [simp]: "start_of (layout_of aprog) as > 0 \<Longrightarrow>
+ (fetch (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e)) (Suc 0) Oc)
+ = (R, Suc (start_of (layout_of aprog) as))"
+
+apply(auto simp: ci.simps findnth.simps fetch.simps
+ nth_of.simps tshift.simps nth_append
+ Suc_pre tdec_b_def)
+apply(insert findnth_nth[of 0 n "Suc 0"], simp)
+apply(simp add: findnth.simps)
+done
+
+lemma [simp]: "start_of (layout_of aprog) as > 0 \<Longrightarrow>
+ (t_step (start_of (layout_of aprog) as, Bk # Bk # ires, Oc # Bk\<^bsup>rn - Suc 0\<^esup>)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0)) =
+ (Suc (start_of (layout_of aprog) as), Oc # Bk # Bk # ires, Bk\<^bsup>rn-Suc 0\<^esup>)"
+apply(simp add: t_step.simps)
+apply(case_tac "start_of (layout_of aprog) as",
+ auto simp: new_tape.simps)
+done
+
+lemma [simp]: "start_of (layout_of aprog) as > 0 \<Longrightarrow>
+ t_step (start_of (layout_of aprog) as, Bk # Bk # ires, Oc # r' @ Bk\<^bsup>rn\<^esup>)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) =
+ (Suc (start_of (layout_of aprog) as), Oc # Bk # Bk # ires, r' @ Bk\<^bsup>rn\<^esup>)"
+apply(simp add: t_step.simps)
+apply(case_tac "start_of (layout_of aprog) as",
+ auto simp: new_tape.simps)
+done
+
+lemma crsp_next_state:
+ "\<lbrakk>crsp_l (layout_of aprog) (as, am) tc ires;
+ abc_fetch as aprog = Some (Dec n e)\<rbrakk>
+ \<Longrightarrow> \<exists> stp' > 0. (\<lambda> (s, l, r).
+ (s = Suc (start_of (layout_of aprog) as)
+ \<and> (dec_inv_1 (layout_of aprog) n e (as, am) (s, l, r) ires)
+ \<and> (dec_inv_2 (layout_of aprog) n e (as, am) (s, l, r)) ires))
+ (t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp')"
+apply(subgoal_tac "start_of (layout_of aprog) as > 0")
+apply(case_tac tc, case_tac b, auto simp: crsp_l.simps)
+apply(case_tac "am = []", simp)
+apply(rule_tac x = "Suc (Suc 0)" in exI, simp add: t_steps.simps)
+proof-
+ fix rn
+ assume h1: "am \<noteq> []" "abc_fetch as aprog = Some (Dec n e)"
+ "start_of (layout_of aprog) as > 0"
+ hence h2: "\<exists> r'. <am> = Oc # r'"
+ by simp
+ from h1 and h2 show
+ "\<exists>stp'>0. case t_steps (start_of (layout_of aprog) as, Bk # Bk # ires, <am> @ Bk\<^bsup>rn\<^esup>)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) stp' of
+ (s, ab) \<Rightarrow> s = Suc (start_of (layout_of aprog) as) \<and>
+ dec_inv_1 (layout_of aprog) n e (as, am) (s, ab) ires \<and>
+ dec_inv_2 (layout_of aprog) n e (as, am) (s, ab) ires"
+ proof(erule_tac exE, simp, rule_tac x = "Suc 0" in exI,
+ simp add: t_steps.simps)
+ qed
+next
+ assume "abc_fetch as aprog = Some (Dec n e)"
+ thus "0 < start_of (layout_of aprog) as"
+ apply(insert startof_not0[of "layout_of aprog" as], simp)
+ done
+qed
+
+lemma dec_crsp_ex1:
+ "\<lbrakk>crsp_l (layout_of aprog) (as, am) tc ires;
+ abc_fetch as aprog = Some (Dec n e);
+ abc_lm_v am n = 0\<rbrakk>
+ \<Longrightarrow> \<exists>stp > 0. crsp_l (layout_of aprog) (e, abc_lm_s am n 0)
+ (t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp) ires"
+proof -
+ assume h1: "crsp_l (layout_of aprog) (as, am) tc ires"
+ "abc_fetch as aprog = Some (Dec n e)" "abc_lm_v am n = 0"
+ hence h2: "\<exists> stp' > 0. (\<lambda> (s, l, r).
+ (s = Suc (start_of (layout_of aprog) as) \<and>
+ (dec_inv_1 (layout_of aprog) n e (as, am) (s, l, r)) ires))
+ (t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp')"
+ apply(insert crsp_next_state[of aprog as am tc ires n e], auto)
+ done
+ from h1 and h2 show
+ "\<exists>stp > 0. crsp_l (layout_of aprog) (e, abc_lm_s am n 0)
+ (t_steps tc (ci (layout_of aprog) (start_of
+ (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) stp) ires"
+ proof(erule_tac exE, case_tac "(t_steps tc (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Dec n e), start_of
+ (layout_of aprog) as - Suc 0) stp')", simp)
+ fix stp' a b c
+ assume h3: "stp' > 0 \<and> a = Suc (start_of (layout_of aprog) as) \<and>
+ dec_inv_1 (layout_of aprog) n e (as, am) (a, b, c) ires"
+ "abc_fetch as aprog = Some (Dec n e)" "abc_lm_v am n = 0"
+ "t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp'
+ = (Suc (start_of (layout_of aprog) as), b, c)"
+ thus "\<exists>stp > 0. crsp_l (layout_of aprog) (e, abc_lm_s am n 0)
+ (t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp) ires"
+ proof(erule_tac conjE, simp)
+ assume "dec_inv_1 (layout_of aprog) n e (as, am)
+ (Suc (start_of (layout_of aprog) as), b, c) ires"
+ "abc_fetch as aprog = Some (Dec n e)"
+ "abc_lm_v am n = 0"
+ " t_steps tc (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) stp'
+ = (Suc (start_of (layout_of aprog) as), b, c)"
+ hence h4: "\<exists>stp. (\<lambda>(s', l', r'). s' =
+ start_of (layout_of aprog) e \<and>
+ dec_inv_1 (layout_of aprog) n e (as, am) (s', l', r') ires)
+ (t_steps (start_of (layout_of aprog) as + 1, b, c)
+ (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) stp)"
+ apply(rule_tac dec_inv_stop1, auto)
+ done
+ from h3 and h4 show ?thesis
+ apply(erule_tac exE)
+ apply(rule_tac x = "stp' + stp" in exI, simp)
+ apply(case_tac "(t_steps (Suc (start_of (layout_of aprog) as),
+ b, c) (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) stp)",
+ simp)
+ apply(rule_tac dec_inv_stop_cond1, auto)
+ done
+ qed
+ qed
+qed
+
+lemma dec_crsp_ex2:
+ "\<lbrakk>crsp_l (layout_of aprog) (as, am) tc ires;
+ abc_fetch as aprog = Some (Dec n e);
+ 0 < abc_lm_v am n\<rbrakk>
+ \<Longrightarrow> \<exists>stp > 0. crsp_l (layout_of aprog)
+ (Suc as, abc_lm_s am n (abc_lm_v am n - Suc 0))
+ (t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp) ires"
+proof -
+ assume h1:
+ "crsp_l (layout_of aprog) (as, am) tc ires"
+ "abc_fetch as aprog = Some (Dec n e)"
+ "abc_lm_v am n > 0"
+ hence h2:
+ "\<exists> stp' > 0. (\<lambda> (s, l, r). (s = Suc (start_of (layout_of aprog) as)
+ \<and> (dec_inv_2 (layout_of aprog) n e (as, am) (s, l, r)) ires))
+(t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp')"
+ apply(insert crsp_next_state[of aprog as am tc ires n e], auto)
+ done
+ from h1 and h2 show
+ "\<exists>stp >0. crsp_l (layout_of aprog)
+ (Suc as, abc_lm_s am n (abc_lm_v am n - Suc 0))
+ (t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp) ires"
+ proof(erule_tac exE,
+ case_tac
+ "(t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp')", simp)
+ fix stp' a b c
+ assume h3: "0 < stp' \<and> a = Suc (start_of (layout_of aprog) as) \<and>
+ dec_inv_2 (layout_of aprog) n e (as, am) (a, b, c) ires"
+ "abc_fetch as aprog = Some (Dec n e)"
+ "abc_lm_v am n > 0"
+ "t_steps tc (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Dec n e),
+ start_of (layout_of aprog) as - Suc 0) stp'
+ = (Suc (start_of (layout_of aprog) as), b, c)"
+ thus "?thesis"
+ proof(erule_tac conjE, simp)
+ assume
+ "dec_inv_2 (layout_of aprog) n e (as, am)
+ (Suc (start_of (layout_of aprog) as), b, c) ires"
+ "abc_fetch as aprog = Some (Dec n e)" "abc_lm_v am n > 0"
+ "t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp'
+ = (Suc (start_of (layout_of aprog) as), b, c)"
+ hence h4:
+ "\<exists>stp. (\<lambda>(s', l', r'). s' = start_of (layout_of aprog) (Suc as) \<and>
+ dec_inv_2 (layout_of aprog) n e (as, am) (s', l', r') ires)
+ (t_steps (start_of (layout_of aprog) as + 1, b, c)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp)"
+ apply(rule_tac dec_stop2, auto)
+ done
+ from h3 and h4 show ?thesis
+ apply(erule_tac exE)
+ apply(rule_tac x = "stp' + stp" in exI, simp)
+ apply(case_tac
+ "(t_steps (Suc (start_of (layout_of aprog) as), b, c)
+ (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ (Dec n e), start_of (layout_of aprog) as - Suc 0) stp)"
+ ,simp)
+ apply(rule_tac dec_inv_stop_cond2, auto)
+ done
+ qed
+ qed
+qed
+
+lemma dec_crsp_ex_pre:
+ "\<lbrakk>ly = layout_of aprog; crsp_l ly (as, am) tc ires;
+ abc_fetch as aprog = Some (Dec n e)\<rbrakk>
+ \<Longrightarrow> \<exists>stp > 0. crsp_l ly (abc_step_l (as, am) (Some (Dec n e)))
+ (t_steps tc (ci (layout_of aprog) (start_of ly as) (Dec n e),
+ start_of ly as - Suc 0) stp) ires"
+apply(auto simp: abc_step_l.simps intro: dec_crsp_ex2 dec_crsp_ex1)
+done
+
+lemma dec_crsp_ex:
+ assumes layout: -- {* There is an Abacus program @{text "aprog"} with layout @{text "ly"} *}
+ "ly = layout_of aprog"
+ and dec: -- {* There is an @{text "Dec n e"} instruction at postion @{text "as"} of @{text "aprog"} *}
+ "abc_fetch as aprog = Some (Dec n e)"
+ and correspond:
+ -- {* Abacus configuration @{text "(as, am)"} is in correspondence with TM
+ configuration @{text "tc"}
+ *}
+ "crsp_l ly (as, am) tc ires"
+shows
+ "\<exists>stp > 0. crsp_l ly (abc_step_l (as, am) (Some (Dec n e)))
+ (t_steps tc (ci (layout_of aprog) (start_of ly as) (Dec n e),
+ start_of ly as - Suc 0) stp) ires"
+proof -
+ from dec_crsp_ex_pre layout dec correspond show ?thesis by blast
+qed
+
+
+(*******End: dec crsp********)
+
+
+subsubsection {* Compilation of @{text "Goto n"}*}
+
+
+(*******Begin: goto crsp********)
+lemma goto_fetch:
+ "fetch (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) (Goto n)) (Suc 0) b
+ = (Nop, start_of (layout_of aprog) n)"
+apply(auto simp: ci.simps fetch.simps nth_of.simps
+ split: block.splits)
+done
+
+text {*
+ Correctness of complied @{text "Goto n"}
+ *}
+
+lemma goto_crsp_ex_pre:
+ "\<lbrakk>ly = layout_of aprog;
+ crsp_l ly (as, am) tc ires;
+ abc_fetch as aprog = Some (Goto n)\<rbrakk>
+ \<Longrightarrow> \<exists>stp > 0. crsp_l ly (abc_step_l (as, am) (Some (Goto n)))
+ (t_steps tc (ci (layout_of aprog) (start_of ly as) (Goto n),
+ start_of ly as - Suc 0) stp) ires"
+apply(rule_tac x = 1 in exI)
+apply(simp add: abc_step_l.simps t_steps.simps t_step.simps)
+apply(case_tac tc, simp)
+apply(subgoal_tac "a = start_of (layout_of aprog) as", auto)
+apply(subgoal_tac "start_of (layout_of aprog) as > 0", simp)
+apply(auto simp: goto_fetch new_tape.simps crsp_l.simps)
+apply(rule startof_not0)
+done
+
+lemma goto_crsp_ex:
+ assumes layout: "ly = layout_of aprog"
+ and goto: "abc_fetch as aprog = Some (Goto n)"
+ and correspondence: "crsp_l ly (as, am) tc ires"
+ shows "\<exists>stp>0. crsp_l ly (abc_step_l (as, am) (Some (Goto n)))
+ (t_steps tc (ci (layout_of aprog) (start_of ly as) (Goto n),
+ start_of ly as - Suc 0) stp) ires"
+proof -
+ from goto_crsp_ex_pre and layout goto correspondence show "?thesis" by blast
+qed
+(*******End : goto crsp*********)
+
+subsubsection {*
+ The correctness of the compiler
+ *}
+
+declare abc_step_l.simps[simp del]
+
+lemma tm_crsp_ex:
+ "\<lbrakk>ly = layout_of aprog;
+ crsp_l ly (as, am) tc ires;
+ as < length aprog;
+ abc_fetch as aprog = Some ins\<rbrakk>
+ \<Longrightarrow> \<exists> n > 0. crsp_l ly (abc_step_l (as,am) (Some ins))
+ (t_steps tc (ci (layout_of aprog) (start_of ly as)
+ (ins), (start_of ly as) - (Suc 0)) n) ires"
+apply(case_tac "ins", simp)
+apply(auto intro: inc_crsp_ex_pre dec_crsp_ex goto_crsp_ex)
+done
+
+lemma start_of_pre:
+ "n < length aprog \<Longrightarrow> start_of (layout_of aprog) n
+ = start_of (layout_of (butlast aprog)) n"
+apply(induct n, simp add: start_of.simps, simp)
+apply(simp add: layout_of.simps start_of.simps)
+apply(subgoal_tac "n < length aprog - Suc 0", simp)
+apply(subgoal_tac "(aprog ! n) = (butlast aprog ! n)", simp)
+proof -
+ fix n
+ assume h1: "Suc n < length aprog"
+ thus "aprog ! n = butlast aprog ! n"
+ apply(case_tac "length aprog", simp, simp)
+ apply(insert nth_append[of "butlast aprog" "[last aprog]" n])
+ apply(subgoal_tac "(butlast aprog @ [last aprog]) = aprog")
+ apply(simp split: if_splits)
+ apply(rule append_butlast_last_id, case_tac aprog, simp, simp)
+ done
+next
+ fix n
+ assume "Suc n < length aprog"
+ thus "n < length aprog - Suc 0"
+ apply(case_tac aprog, simp, simp)
+ done
+qed
+
+lemma zip_eq: "xs = ys \<Longrightarrow> zip xs zs = zip ys zs"
+by simp
+
+lemma tpairs_of_append_iff: "length aprog = Suc n \<Longrightarrow>
+ tpairs_of aprog = tpairs_of (butlast aprog) @
+ [(start_of (layout_of aprog) n, aprog ! n)]"
+apply(simp add: tpairs_of.simps)
+apply(insert zip_append[of "map (start_of (layout_of aprog)) [0..<n]"
+ "butlast aprog" "[start_of (layout_of aprog) n]" "[last aprog]"])
+apply(simp del: zip_append)
+apply(subgoal_tac "(butlast aprog @ [last aprog]) = aprog", auto)
+apply(rule_tac zip_eq, auto)
+apply(rule_tac start_of_pre, simp)
+apply(insert last_conv_nth[of aprog], case_tac aprog, simp, simp)
+apply(rule append_butlast_last_id, case_tac aprog, simp, simp)
+done
+
+lemma [simp]: "list_all (\<lambda>(n, tm). abacus.t_ncorrect (ci layout n tm))
+ (zip (map (start_of layout) [0..<length aprog]) aprog)"
+proof(induct "length aprog" arbitrary: aprog, simp)
+ fix x aprog
+ assume ind: "\<And>aprog. x = length aprog \<Longrightarrow>
+ list_all (\<lambda>(n, tm). abacus.t_ncorrect (ci layout n tm))
+ (zip (map (start_of layout) [0..<length aprog]) aprog)"
+ and h: "Suc x = length (aprog::abc_inst list)"
+ have g1: "list_all (\<lambda>(n, tm). abacus.t_ncorrect (ci layout n tm))
+ (zip (map (start_of layout) [0..<length (butlast aprog)])
+ (butlast aprog))"
+ using h
+ apply(rule_tac ind, auto)
+ done
+ have g2: "(map (start_of layout) [0..<length aprog]) =
+ map (start_of layout) ([0..<length aprog - 1]
+ @ [length aprog - 1])"
+ using h
+ apply(case_tac aprog, simp, simp)
+ done
+ have "\<exists> xs a. aprog = xs @ [a]"
+ using h
+ apply(rule_tac x = "butlast aprog" in exI,
+ rule_tac x = "last aprog" in exI)
+ apply(case_tac "aprog = []", simp, simp)
+ done
+ from this obtain xs where "\<exists> a. aprog = xs @ [a]" ..
+ from this obtain a where g3: "aprog = xs @ [a]" ..
+ from g1 and g2 and g3 show "list_all (\<lambda>(n, tm).
+ abacus.t_ncorrect (ci layout n tm))
+ (zip (map (start_of layout) [0..<length aprog]) aprog)"
+ apply(simp)
+ apply(auto simp: t_ncorrect.simps ci.simps tshift.simps
+ tinc_b_def tdec_b_def split: abc_inst.splits)
+ apply arith+
+ done
+qed
+
+lemma [intro]: "abc2t_correct aprog"
+apply(simp add: abc2t_correct.simps tpairs_of.simps
+ split: abc_inst.splits)
+done
+
+lemma as_out: "\<lbrakk>ly = layout_of aprog; tprog = tm_of aprog;
+ crsp_l ly (as, am) tc ires; length aprog \<le> as\<rbrakk>
+ \<Longrightarrow> abc_step_l (as, am) (abc_fetch as aprog) = (as, am)"
+apply(simp add: abc_fetch.simps abc_step_l.simps)
+done
+
+lemma tm_merge_ex:
+ "\<lbrakk>crsp_l (layout_of aprog) (as, am) tc ires;
+ as < length aprog;
+ abc_fetch as aprog = Some a;
+ abc2t_correct aprog;
+ crsp_l (layout_of aprog) (abc_step_l (as, am) (Some a))
+ (t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as)
+ a, start_of (layout_of aprog) as - Suc 0) n) ires;
+ n > 0\<rbrakk>
+ \<Longrightarrow> \<exists>stp > 0. crsp_l (layout_of aprog) (abc_step_l (as, am)
+ (Some a)) (t_steps tc (tm_of aprog, 0) stp) ires"
+apply(case_tac "(t_steps tc (ci (layout_of aprog)
+ (start_of (layout_of aprog) as) a,
+ start_of (layout_of aprog) as - Suc 0) n)", simp)
+apply(case_tac "(abc_step_l (as, am) (Some a))", simp)
+proof -
+ fix aa b c aaa ba
+ assume h:
+ "crsp_l (layout_of aprog) (as, am) tc ires"
+ "as < length aprog"
+ "abc_fetch as aprog = Some a"
+ "crsp_l (layout_of aprog) (aaa, ba) (aa, b, c) ires"
+ "abc2t_correct aprog"
+ "n>0"
+ "t_steps tc (ci (layout_of aprog) (start_of (layout_of aprog) as) a,
+ start_of (layout_of aprog) as - Suc 0) n = (aa, b, c)"
+ "abc_step_l (as, am) (Some a) = (aaa, ba)"
+ hence "aa = start_of (layout_of aprog) aaa"
+ apply(simp add: crsp_l.simps)
+ done
+ from this and h show
+ "\<exists>stp > 0. crsp_l (layout_of aprog) (aaa, ba)
+ (t_steps tc (tm_of aprog, 0) stp) ires"
+ apply(insert tms_out_ex[of "layout_of aprog" aprog
+ "tm_of aprog" as am tc ires a n aa b c aaa ba], auto)
+ done
+qed
+
+lemma crsp_inside:
+ "\<lbrakk>ly = layout_of aprog;
+ tprog = tm_of aprog;
+ crsp_l ly (as, am) tc ires;
+ as < length aprog\<rbrakk> \<Longrightarrow>
+ (\<exists> stp > 0. crsp_l ly (abc_step_l (as,am) (abc_fetch as aprog))
+ (t_steps tc (tprog, 0) stp) ires)"
+apply(case_tac "abc_fetch as aprog", simp add: abc_fetch.simps)
+proof -
+ fix a
+ assume "ly = layout_of aprog"
+ "tprog = tm_of aprog"
+ "crsp_l ly (as, am) tc ires"
+ "as < length aprog"
+ "abc_fetch as aprog = Some a"
+ thus "\<exists>stp > 0. crsp_l ly (abc_step_l (as, am)
+ (abc_fetch as aprog)) (t_steps tc (tprog, 0) stp) ires"
+ proof(insert tm_crsp_ex[of ly aprog as am tc ires a],
+ auto intro: tm_merge_ex)
+ qed
+qed
+
+lemma crsp_outside:
+ "\<lbrakk>ly = layout_of aprog; tprog = tm_of aprog;
+ crsp_l ly (as, am) tc ires; as \<ge> length aprog\<rbrakk>
+ \<Longrightarrow> (\<exists> stp. crsp_l ly (abc_step_l (as,am) (abc_fetch as aprog))
+ (t_steps tc (tprog, 0) stp) ires)"
+apply(subgoal_tac "abc_step_l (as, am) (abc_fetch as aprog)
+ = (as, am)", simp)
+apply(rule_tac x = 0 in exI, simp add: t_steps.simps)
+apply(rule as_out, simp+)
+done
+
+text {*
+ Single-step correntess of the compiler.
+*}
+lemma astep_crsp_pre:
+ "\<lbrakk>ly = layout_of aprog;
+ tprog = tm_of aprog;
+ crsp_l ly (as, am) tc ires\<rbrakk>
+ \<Longrightarrow> (\<exists> stp. crsp_l ly (abc_step_l (as,am)
+ (abc_fetch as aprog)) (t_steps tc (tprog, 0) stp) ires)"
+apply(case_tac "as < length aprog")
+apply(drule_tac crsp_inside, auto)
+apply(rule_tac crsp_outside, simp+)
+done
+
+text {*
+ Single-step correntess of the compiler.
+*}
+lemma astep_crsp_pre1:
+ "\<lbrakk>ly = layout_of aprog;
+ tprog = tm_of aprog;
+ crsp_l ly (as, am) tc ires\<rbrakk>
+ \<Longrightarrow> (\<exists> stp. crsp_l ly (abc_step_l (as,am)
+ (abc_fetch as aprog)) (t_steps tc (tprog, 0) stp) ires)"
+apply(case_tac "as < length aprog")
+apply(drule_tac crsp_inside, auto)
+apply(rule_tac crsp_outside, simp+)
+done
+
+lemma astep_crsp:
+ assumes layout:
+ -- {* There is a Abacus program @{text "aprog"} with layout @{text "ly"} *}
+ "ly = layout_of aprog"
+ and compiled:
+ -- {* @{text "tprog"} is the TM compiled from @{text "aprog"} *}
+ "tprog = tm_of aprog"
+ and corresponds:
+ -- {* Abacus configuration @{text "(as, am)"} is in correspondence with TM configuration
+ @{text "tc"} *}
+ "crsp_l ly (as, am) tc ires"
+ -- {* One step execution of @{text "aprog"} can be simulated by multi-step execution
+ of @{text "tprog"} *}
+ shows "(\<exists> stp. crsp_l ly (abc_step_l (as,am)
+ (abc_fetch as aprog)) (t_steps tc (tprog, 0) stp) ires)"
+proof -
+ from astep_crsp_pre1 [OF layout compiled corresponds] show ?thesis .
+qed
+
+lemma steps_crsp_pre:
+ "\<lbrakk>ly = layout_of aprog; tprog = tm_of aprog;
+ crsp_l ly ac tc ires; ac' = abc_steps_l ac aprog n\<rbrakk> \<Longrightarrow>
+ (\<exists> n'. crsp_l ly ac' (t_steps tc (tprog, 0) n') ires)"
+apply(induct n arbitrary: ac' ac tc, simp add: abc_steps_l.simps)
+apply(rule_tac x = 0 in exI)
+apply(case_tac ac, simp add: abc_steps_l.simps t_steps.simps)
+apply(case_tac ac, simp add: abc_steps_l.simps)
+apply(subgoal_tac
+ "(\<exists> stp. crsp_l ly (abc_step_l (a, b)
+ (abc_fetch a aprog)) (t_steps tc (tprog, 0) stp) ires)")
+apply(erule exE)
+apply(subgoal_tac
+ "\<exists>n'. crsp_l (layout_of aprog)
+ (abc_steps_l (abc_step_l (a, b) (abc_fetch a aprog)) aprog n)
+ (t_steps ((t_steps tc (tprog, 0) stp)) (tm_of aprog, 0) n') ires")
+apply(erule exE)
+apply(subgoal_tac
+ "t_steps (t_steps tc (tprog, 0) stp) (tm_of aprog, 0) n' =
+ t_steps tc (tprog, 0) (stp + n')")
+apply(rule_tac x = "stp + n'" in exI, simp)
+apply(auto intro: astep_crsp simp: t_step_add)
+done
+
+text {*
+ Multi-step correctess of the compiler.
+*}
+
+lemma steps_crsp:
+ assumes layout:
+ -- {* There is an Abacus program @{text "aprog"} with layout @{text "ly"} *}
+ "ly = layout_of aprog"
+ and compiled:
+ -- {* @{text "tprog"} is the TM compiled from @{text "aprog"} *}
+ "tprog = tm_of aprog"
+ and correspond:
+ -- {* Abacus configuration @{text "ac"} is in correspondence with TM configuration @{text "tc"} *}
+ "crsp_l ly ac tc ires"
+ and execution:
+ -- {* @{text "ac'"} is the configuration obtained from @{text "n"}-step execution
+ of @{text "aprog"} starting from configuration @{text "ac"} *}
+ "ac' = abc_steps_l ac aprog n"
+ -- {* There exists steps @{text "n'"} steps, after these steps of execution,
+ the Turing configuration such obtained is in correspondence with @{text "ac'"} *}
+ shows "(\<exists> n'. crsp_l ly ac' (t_steps tc (tprog, 0) n') ires)"
+proof -
+ from steps_crsp_pre [OF layout compiled correspond execution] show ?thesis .
+qed
+
+
+subsubsection {* The Mop-up machine *}
+
+fun mop_bef :: "nat \<Rightarrow> tprog"
+ where
+ "mop_bef 0 = []" |
+ "mop_bef (Suc n) = mop_bef n @
+ [(R, 2*n + 3), (W0, 2*n + 2), (R, 2*n + 1), (W1, 2*n + 2)]"
+
+definition mp_up :: "tprog"
+ where
+ "mp_up \<equiv> [(R, 2), (R, 1), (L, 5), (W0, 3), (R, 4), (W0, 3),
+ (R, 2), (W0, 3), (L, 5), (L, 6), (R, 0), (L, 6)]"
+
+fun tMp :: "nat \<Rightarrow> nat \<Rightarrow> tprog"
+ where
+ "tMp n off = tshift (mop_bef n @ tshift mp_up (2*n)) off"
+
+declare mp_up_def[simp del] tMp.simps[simp del] mop_bef.simps[simp del]
+(**********Begin: equiv among aba and turing***********)
+
+lemma tm_append_step:
+ "\<lbrakk>t_ncorrect tp1; t_step tc (tp1, 0) = (s, l, r); s \<noteq> 0\<rbrakk>
+ \<Longrightarrow> t_step tc (tp1 @ tp2, 0) = (s, l, r)"
+apply(simp add: t_step.simps)
+apply(case_tac tc, simp)
+apply(case_tac
+ "(fetch tp1 a (case c of [] \<Rightarrow> Bk |
+ Bk # xs \<Rightarrow> Bk | Oc # xs \<Rightarrow> Oc))", simp)
+apply(case_tac a, simp add: fetch.simps)
+apply(simp add: fetch.simps)
+apply(case_tac c, simp)
+apply(case_tac [!] "ab::block")
+apply(auto simp: nth_of.simps nth_append t_ncorrect.simps
+ split: if_splits)
+done
+
+lemma state0_ind: "t_steps (0, l, r) (tp, 0) stp = (0, l, r)"
+apply(induct stp, simp add: t_steps.simps)
+apply(simp add: t_steps.simps t_step.simps fetch.simps new_tape.simps)
+done
+
+lemma tm_append_steps:
+ "\<lbrakk>t_ncorrect tp1; t_steps tc (tp1, 0) stp = (s, l ,r); s \<noteq> 0\<rbrakk>
+ \<Longrightarrow> t_steps tc (tp1 @ tp2, 0) stp = (s, l, r)"
+apply(induct stp arbitrary: tc s l r)
+apply(case_tac tc, simp)
+apply(simp add: t_steps.simps)
+proof -
+ fix stp tc s l r
+ assume h1: "\<And>tc s l r. \<lbrakk>t_ncorrect tp1; t_steps tc (tp1, 0) stp =
+ (s, l, r); s \<noteq> 0\<rbrakk> \<Longrightarrow> t_steps tc (tp1 @ tp2, 0) stp = (s, l, r)"
+ and h2: "t_steps tc (tp1, 0) (Suc stp) = (s, l, r)" "s \<noteq> 0"
+ "t_ncorrect tp1"
+ thus "t_steps tc (tp1 @ tp2, 0) (Suc stp) = (s, l, r)"
+ apply(simp add: t_steps.simps)
+ apply(case_tac "(t_step tc (tp1, 0))", simp)
+ proof-
+ fix a b c
+ assume g1: "\<And>tc s l r. \<lbrakk>t_steps tc (tp1, 0) stp = (s, l, r);
+ 0 < s\<rbrakk> \<Longrightarrow> t_steps tc (tp1 @ tp2, 0) stp = (s, l, r)"
+ and g2: "t_step tc (tp1, 0) = (a, b, c)"
+ "t_steps (a, b, c) (tp1, 0) stp = (s, l, r)"
+ "0 < s"
+ "t_ncorrect tp1"
+ hence g3: "a > 0"
+ apply(case_tac "a::nat", auto simp: t_steps.simps)
+ apply(simp add: state0_ind)
+ done
+ from g1 and g2 and this have g4:
+ "(t_step tc (tp1 @ tp2, 0)) = (a, b, c)"
+ apply(rule_tac tm_append_step, simp, simp, simp)
+ done
+ from g1 and g2 and g3 and g4 show
+ "t_steps (t_step tc (tp1 @ tp2, 0)) (tp1 @ tp2, 0) stp
+ = (s, l, r)"
+ apply(simp)
+ done
+ qed
+qed
+
+lemma shift_fetch:
+ "\<lbrakk>n < length tp;
+ (tp:: (taction \<times> nat) list) ! n = (aa, ba);
+ ba \<noteq> 0\<rbrakk>
+ \<Longrightarrow> (tshift tp (length tp div 2)) ! n =
+ (aa , ba + length tp div 2)"
+apply(simp add: tshift.simps)
+done
+
+lemma tshift_length_equal: "length (tshift tp q) = length tp"
+apply(auto simp: tshift.simps)
+done
+
+thm nth_of.simps
+
+lemma [simp]: "t_ncorrect tp \<Longrightarrow> 2 * (length tp div 2) = length tp"
+apply(auto simp: t_ncorrect.simps)
+done
+
+lemma tm_append_step_equal':
+ "\<lbrakk>t_ncorrect tp; t_ncorrect tp'; off = length tp div 2\<rbrakk> \<Longrightarrow>
+ (\<lambda> (s, l, r). ((\<lambda> (s', l', r').
+ (s'\<noteq> 0 \<longrightarrow> (s = s' + off \<and> l = l' \<and> r = r')))
+ (t_step (a, b, c) (tp', 0))))
+ (t_step (a + off, b, c) (tp @ tshift tp' off, 0))"
+apply(simp add: t_step.simps)
+apply(case_tac a, simp add: fetch.simps)
+apply(case_tac
+"(fetch tp' a (case c of [] \<Rightarrow> Bk | Bk # xs \<Rightarrow> Bk | Oc # xs \<Rightarrow> Oc))",
+ simp)
+apply(case_tac
+"(fetch (tp @ tshift tp' (length tp div 2))
+ (Suc (nat + length tp div 2))
+ (case c of [] \<Rightarrow> Bk | Bk # xs \<Rightarrow> Bk | Oc # xs \<Rightarrow> Oc))",
+ simp)
+apply(case_tac "(new_tape aa (b, c))",
+ case_tac "(new_tape aaa (b, c))", simp,
+ rule impI, simp add: fetch.simps split: block.splits option.splits)
+apply (auto simp: nth_of.simps t_ncorrect.simps
+ nth_append tshift_length_equal tshift.simps split: if_splits)
+done
+
+
+lemma tm_append_step_equal:
+ "\<lbrakk>t_ncorrect tp; t_ncorrect tp'; off = length tp div 2;
+ t_step (a, b, c) (tp', 0) = (aa, ab, bb); aa \<noteq> 0\<rbrakk>
+ \<Longrightarrow> t_step (a + length tp div 2, b, c)
+ (tp @ tshift tp' (length tp div 2), 0)
+ = (aa + length tp div 2, ab, bb)"
+apply(insert tm_append_step_equal'[of tp tp' off a b c], simp)
+apply(case_tac "(t_step (a + length tp div 2, b, c)
+ (tp @ tshift tp' (length tp div 2), 0))", simp)
+done
+
+lemma tm_append_steps_equal:
+ "\<lbrakk>t_ncorrect tp; t_ncorrect tp'; off = length tp div 2\<rbrakk> \<Longrightarrow>
+ (\<lambda> (s, l, r). ((\<lambda> (s', l', r'). ((s'\<noteq> 0 \<longrightarrow> s = s' + off \<and> l = l'
+ \<and> r = r'))) (t_steps (a, b, c) (tp', 0) stp)))
+ (t_steps (a + off, b, c) (tp @ tshift tp' off, 0) stp)"
+apply(induct stp arbitrary : a b c, simp add: t_steps.simps)
+apply(simp add: t_steps.simps)
+apply(case_tac "(t_step (a, b, c) (tp', 0))", simp)
+apply(case_tac "aa = 0", simp add: state0_ind)
+apply(subgoal_tac "(t_step (a + length tp div 2, b, c)
+ (tp @ tshift tp' (length tp div 2), 0))
+ = (aa + length tp div 2, ba, ca)", simp)
+apply(rule tm_append_step_equal, auto)
+done
+
+(*********Begin: mop_up***************)
+type_synonym mopup_type = "t_conf \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> block list \<Rightarrow> bool"
+
+fun mopup_stop :: "mopup_type"
+ where
+ "mopup_stop (s, l, r) lm n ires=
+ (\<exists> ln rn. l = Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires \<and> r = <abc_lm_v lm n> @ Bk\<^bsup>rn\<^esup>)"
+
+fun mopup_bef_erase_a :: "mopup_type"
+ where
+ "mopup_bef_erase_a (s, l, r) lm n ires=
+ (\<exists> ln m rn. l = Bk \<^bsup>ln\<^esup> @ Bk # Bk # ires \<and>
+ r = Oc\<^bsup>m \<^esup>@ Bk # <(drop ((s + 1) div 2) lm)> @ Bk\<^bsup>rn\<^esup>)"
+
+fun mopup_bef_erase_b :: "mopup_type"
+ where
+ "mopup_bef_erase_b (s, l, r) lm n ires =
+ (\<exists> ln m rn. l = Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires \<and> r = Bk # Oc\<^bsup>m\<^esup> @ Bk #
+ <(drop (s div 2) lm)> @ Bk\<^bsup>rn\<^esup>)"
+
+
+fun mopup_jump_over1 :: "mopup_type"
+ where
+ "mopup_jump_over1 (s, l, r) lm n ires =
+ (\<exists> ln m1 m2 rn. m1 + m2 = Suc (abc_lm_v lm n) \<and>
+ l = Oc\<^bsup>m1\<^esup> @ Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires \<and>
+ (r = Oc\<^bsup>m2\<^esup> @ Bk # <(drop (Suc n) lm)> @ Bk\<^bsup>rn \<^esup>\<or>
+ (r = Oc\<^bsup>m2\<^esup> \<and> (drop (Suc n) lm) = [])))"
+
+fun mopup_aft_erase_a :: "mopup_type"
+ where
+ "mopup_aft_erase_a (s, l, r) lm n ires =
+ (\<exists> lnl lnr rn (ml::nat list) m.
+ m = Suc (abc_lm_v lm n) \<and> l = Bk\<^bsup>lnr \<^esup>@ Oc\<^bsup>m \<^esup>@ Bk\<^bsup>lnl\<^esup> @ Bk # Bk # ires \<and>
+ (r = <ml> @ Bk\<^bsup>rn\<^esup>))"
+
+fun mopup_aft_erase_b :: "mopup_type"
+ where
+ "mopup_aft_erase_b (s, l, r) lm n ires=
+ (\<exists> lnl lnr rn (ml::nat list) m.
+ m = Suc (abc_lm_v lm n) \<and>
+ l = Bk\<^bsup>lnr \<^esup>@ Oc\<^bsup>m \<^esup>@ Bk\<^bsup>lnl\<^esup> @ Bk # Bk # ires \<and>
+ (r = Bk # <ml> @ Bk\<^bsup>rn \<^esup>\<or>
+ r = Bk # Bk # <ml> @ Bk\<^bsup>rn\<^esup>))"
+
+fun mopup_aft_erase_c :: "mopup_type"
+ where
+ "mopup_aft_erase_c (s, l, r) lm n ires =
+ (\<exists> lnl lnr rn (ml::nat list) m.
+ m = Suc (abc_lm_v lm n) \<and>
+ l = Bk\<^bsup>lnr \<^esup>@ Oc\<^bsup>m \<^esup>@ Bk\<^bsup>lnl\<^esup> @ Bk # Bk # ires \<and>
+ (r = <ml> @ Bk\<^bsup>rn \<^esup>\<or> r = Bk # <ml> @ Bk\<^bsup>rn\<^esup>))"
+
+fun mopup_left_moving :: "mopup_type"
+ where
+ "mopup_left_moving (s, l, r) lm n ires =
+ (\<exists> lnl lnr rn m.
+ m = Suc (abc_lm_v lm n) \<and>
+ ((l = Bk\<^bsup>lnr \<^esup>@ Oc\<^bsup>m \<^esup>@ Bk\<^bsup>lnl\<^esup> @ Bk # Bk # ires \<and> r = Bk\<^bsup>rn\<^esup>) \<or>
+ (l = Oc\<^bsup>m - 1\<^esup> @ Bk\<^bsup>lnl\<^esup> @ Bk # Bk # ires \<and> r = Oc # Bk\<^bsup>rn\<^esup>)))"
+
+fun mopup_jump_over2 :: "mopup_type"
+ where
+ "mopup_jump_over2 (s, l, r) lm n ires =
+ (\<exists> ln rn m1 m2.
+ m1 + m2 = Suc (abc_lm_v lm n)
+ \<and> r \<noteq> []
+ \<and> (hd r = Oc \<longrightarrow> (l = Oc\<^bsup>m1\<^esup> @ Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires \<and> r = Oc\<^bsup>m2\<^esup> @ Bk\<^bsup>rn\<^esup>))
+ \<and> (hd r = Bk \<longrightarrow> (l = Bk\<^bsup>ln\<^esup> @ Bk # ires \<and> r = Bk # Oc\<^bsup>m1 + m2\<^esup> @ Bk\<^bsup>rn\<^esup>)))"
+
+
+fun mopup_inv :: "mopup_type"
+ where
+ "mopup_inv (s, l, r) lm n ires =
+ (if s = 0 then mopup_stop (s, l, r) lm n ires
+ else if s \<le> 2*n then
+ if s mod 2 = 1 then mopup_bef_erase_a (s, l, r) lm n ires
+ else mopup_bef_erase_b (s, l, r) lm n ires
+ else if s = 2*n + 1 then
+ mopup_jump_over1 (s, l, r) lm n ires
+ else if s = 2*n + 2 then mopup_aft_erase_a (s, l, r) lm n ires
+ else if s = 2*n + 3 then mopup_aft_erase_b (s, l, r) lm n ires
+ else if s = 2*n + 4 then mopup_aft_erase_c (s, l, r) lm n ires
+ else if s = 2*n + 5 then mopup_left_moving (s, l, r) lm n ires
+ else if s = 2*n + 6 then mopup_jump_over2 (s, l, r) lm n ires
+ else False)"
+
+declare
+ mopup_jump_over2.simps[simp del] mopup_left_moving.simps[simp del]
+ mopup_aft_erase_c.simps[simp del] mopup_aft_erase_b.simps[simp del]
+ mopup_aft_erase_a.simps[simp del] mopup_jump_over1.simps[simp del]
+ mopup_bef_erase_a.simps[simp del] mopup_bef_erase_b.simps[simp del]
+ mopup_stop.simps[simp del]
+
+lemma mopup_fetch_0[simp]:
+ "(fetch (mop_bef n @ tshift mp_up (2 * n)) 0 b) = (Nop, 0)"
+by(simp add: fetch.simps)
+
+lemma mop_bef_length[simp]: "length (mop_bef n) = 4 * n"
+apply(induct n, simp add: mop_bef.simps, simp add: mop_bef.simps)
+done
+
+thm findnth_nth
+lemma mop_bef_nth:
+ "\<lbrakk>q < n; x < 4\<rbrakk> \<Longrightarrow> mop_bef n ! (4 * q + x) =
+ mop_bef (Suc q) ! ((4 * q) + x)"
+apply(induct n, simp)
+apply(case_tac "q < n", simp add: mop_bef.simps, auto)
+apply(simp add: nth_append)
+apply(subgoal_tac "q = n", simp)
+apply(arith)
+done
+
+lemma fetch_bef_erase_a_o[simp]:
+ "\<lbrakk>0 < s; s \<le> 2 * n; s mod 2 = Suc 0\<rbrakk>
+ \<Longrightarrow> (fetch (mop_bef n @ tshift mp_up (2 * n)) s Oc) = (W0, s + 1)"
+apply(subgoal_tac "\<exists> q. s = 2*q + 1", auto)
+apply(subgoal_tac "length (mop_bef n) = 4*n")
+apply(auto simp: fetch.simps nth_of.simps nth_append)
+apply(subgoal_tac "mop_bef n ! (4 * q + 1) =
+ mop_bef (Suc q) ! ((4 * q) + 1)",
+ simp add: mop_bef.simps nth_append)
+apply(rule mop_bef_nth, auto)
+done
+
+lemma fetch_bef_erase_a_b[simp]:
+ "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n; s mod 2 = Suc 0\<rbrakk>
+ \<Longrightarrow> (fetch (mop_bef n @ tshift mp_up (2 * n)) s Bk) = (R, s + 2)"
+apply(subgoal_tac "\<exists> q. s = 2*q + 1", auto)
+apply(subgoal_tac "length (mop_bef n) = 4*n")
+apply(auto simp: fetch.simps nth_of.simps nth_append)
+apply(subgoal_tac "mop_bef n ! (4 * q + 0) =
+ mop_bef (Suc q) ! ((4 * q + 0))",
+ simp add: mop_bef.simps nth_append)
+apply(rule mop_bef_nth, auto)
+done
+
+lemma fetch_bef_erase_b_b:
+ "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n; s mod 2 = 0\<rbrakk> \<Longrightarrow>
+ (fetch (mop_bef n @ tshift mp_up (2 * n)) s Bk) = (R, s - 1)"
+apply(subgoal_tac "\<exists> q. s = 2 * q", auto)
+apply(case_tac qa, simp, simp)
+apply(auto simp: fetch.simps nth_of.simps nth_append)
+apply(subgoal_tac "mop_bef n ! (4 * nat + 2) =
+ mop_bef (Suc nat) ! ((4 * nat) + 2)",
+ simp add: mop_bef.simps nth_append)
+apply(rule mop_bef_nth, auto)
+done
+
+lemma fetch_jump_over1_o:
+ "fetch (mop_bef n @ tshift mp_up (2 * n)) (Suc (2 * n)) Oc
+ = (R, Suc (2 * n))"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(auto simp: fetch.simps nth_of.simps mp_up_def nth_append
+ tshift.simps)
+done
+
+lemma fetch_jump_over1_b:
+ "fetch (mop_bef n @ tshift mp_up (2 * n)) (Suc (2 * n)) Bk
+ = (R, Suc (Suc (2 * n)))"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(auto simp: fetch.simps nth_of.simps mp_up_def
+ nth_append tshift.simps)
+done
+
+lemma fetch_aft_erase_a_o:
+ "fetch (mop_bef n @ tshift mp_up (2 * n)) (Suc (Suc (2 * n))) Oc
+ = (W0, Suc (2 * n + 2))"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(auto simp: fetch.simps nth_of.simps mp_up_def
+ nth_append tshift.simps)
+done
+
+lemma fetch_aft_erase_a_b:
+ "fetch (mop_bef n @ tshift mp_up (2 * n)) (Suc (Suc (2 * n))) Bk
+ = (L, Suc (2 * n + 4))"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(auto simp: fetch.simps nth_of.simps mp_up_def
+ nth_append tshift.simps)
+done
+
+lemma fetch_aft_erase_b_b:
+ "fetch (mop_bef n @ tshift mp_up (2 * n)) (2*n + 3) Bk
+ = (R, Suc (2 * n + 3))"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(subgoal_tac "2*n + 3 = Suc (2*n + 2)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps mp_up_def nth_append tshift.simps)
+done
+
+lemma fetch_aft_erase_c_o:
+ "fetch (mop_bef n @ tshift mp_up (2 * n)) (2 * n + 4) Oc
+ = (W0, Suc (2 * n + 2))"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(subgoal_tac "2*n + 4 = Suc (2*n + 3)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps mp_up_def nth_append tshift.simps)
+done
+
+lemma fetch_aft_erase_c_b:
+ "fetch (mop_bef n @ tshift mp_up (2 * n)) (2 * n + 4) Bk
+ = (R, Suc (2 * n + 1))"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(subgoal_tac "2*n + 4 = Suc (2*n + 3)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps mp_up_def nth_append tshift.simps)
+done
+
+lemma fetch_left_moving_o:
+ "(fetch (mop_bef n @ tshift mp_up (2 * n)) (2 * n + 5) Oc)
+ = (L, 2*n + 6)"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(subgoal_tac "2*n + 5 = Suc (2*n + 4)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps mp_up_def nth_append tshift.simps)
+done
+
+lemma fetch_left_moving_b:
+ "(fetch (mop_bef n @ tshift mp_up (2 * n)) (2 * n + 5) Bk)
+ = (L, 2*n + 5)"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(subgoal_tac "2*n + 5 = Suc (2*n + 4)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps mp_up_def nth_append tshift.simps)
+done
+
+lemma fetch_jump_over2_b:
+ "(fetch (mop_bef n @ tshift mp_up (2 * n)) (2 * n + 6) Bk)
+ = (R, 0)"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(subgoal_tac "2*n + 6 = Suc (2*n + 5)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps mp_up_def nth_append tshift.simps)
+done
+
+lemma fetch_jump_over2_o:
+"(fetch (mop_bef n @ tshift mp_up (2 * n)) (2 * n + 6) Oc)
+ = (L, 2*n + 6)"
+apply(subgoal_tac "length (mop_bef n) = 4 * n")
+apply(subgoal_tac "2*n + 6 = Suc (2*n + 5)", simp only: fetch.simps)
+apply(auto simp: nth_of.simps mp_up_def nth_append tshift.simps)
+done
+
+lemmas mopupfetchs =
+fetch_bef_erase_a_o fetch_bef_erase_a_b fetch_bef_erase_b_b
+fetch_jump_over1_o fetch_jump_over1_b fetch_aft_erase_a_o
+fetch_aft_erase_a_b fetch_aft_erase_b_b fetch_aft_erase_c_o
+fetch_aft_erase_c_b fetch_left_moving_o fetch_left_moving_b
+fetch_jump_over2_b fetch_jump_over2_o
+
+lemma [simp]:
+"\<lbrakk>n < length lm; 0 < s; s mod 2 = Suc 0;
+ mopup_bef_erase_a (s, l, Oc # xs) lm n ires;
+ Suc s \<le> 2 * n\<rbrakk> \<Longrightarrow>
+ mopup_bef_erase_b (Suc s, l, Bk # xs) lm n ires"
+apply(auto simp: mopup_bef_erase_a.simps mopup_bef_erase_b.simps )
+apply(rule_tac x = "m - 1" in exI, rule_tac x = rn in exI)
+apply(case_tac m, simp, simp)
+done
+
+lemma mopup_false1:
+ "\<lbrakk>0 < s; s \<le> 2 * n; s mod 2 = Suc 0; \<not> Suc s \<le> 2 * n\<rbrakk>
+ \<Longrightarrow> RR"
+apply(arith)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n; s mod 2 = Suc 0;
+ mopup_bef_erase_a (s, l, Oc # xs) lm n ires; r = Oc # xs\<rbrakk>
+ \<Longrightarrow> (Suc s \<le> 2 * n \<longrightarrow> mopup_bef_erase_b (Suc s, l, Bk # xs) lm n ires) \<and>
+ (\<not> Suc s \<le> 2 * n \<longrightarrow> mopup_jump_over1 (Suc s, l, Bk # xs) lm n ires) "
+apply(auto elim: mopup_false1)
+done
+
+lemma drop_abc_lm_v_simp[simp]:
+ "n < length lm \<Longrightarrow> drop n lm = abc_lm_v lm n # drop (Suc n) lm"
+apply(auto simp: abc_lm_v.simps)
+apply(drule drop_Suc_conv_tl, simp)
+done
+lemma [simp]: "(\<exists>rna. Bk\<^bsup>rn\<^esup> = Bk # Bk\<^bsup>rna\<^esup>) \<or> Bk\<^bsup>rn\<^esup> = []"
+apply(case_tac rn, simp, auto)
+done
+
+lemma [simp]: "\<exists>lna. Bk # Bk\<^bsup>ln\<^esup> = Bk\<^bsup>lna\<^esup>"
+apply(rule_tac x = "Suc ln" in exI, auto)
+done
+
+lemma mopup_bef_erase_a_2_jump_over[simp]:
+ "\<lbrakk>n < length lm; 0 < s; s mod 2 = Suc 0;
+ mopup_bef_erase_a (s, l, Bk # xs) lm n ires; Suc s = 2 * n\<rbrakk>
+\<Longrightarrow> mopup_jump_over1 (Suc (2 * n), Bk # l, xs) lm n ires"
+apply(auto simp: mopup_bef_erase_a.simps mopup_jump_over1.simps)
+apply(case_tac m, simp)
+apply(rule_tac x = "Suc ln" in exI, rule_tac x = 0 in exI,
+ simp add: tape_of_nl_abv)
+apply(case_tac "drop (Suc n) lm", auto simp: tape_of_nat_list.simps )
+done
+
+lemma Suc_Suc_div: "\<lbrakk>0 < s; s mod 2 = Suc 0; Suc (Suc s) \<le> 2 * n\<rbrakk>
+ \<Longrightarrow> (Suc (Suc (s div 2))) \<le> n"
+apply(arith)
+done
+
+lemma mopup_bef_erase_a_2_a[simp]:
+ "\<lbrakk>n < length lm; 0 < s; s mod 2 = Suc 0;
+ mopup_bef_erase_a (s, l, Bk # xs) lm n ires;
+ Suc (Suc s) \<le> 2 * n\<rbrakk> \<Longrightarrow>
+ mopup_bef_erase_a (Suc (Suc s), Bk # l, xs) lm n ires"
+apply(auto simp: mopup_bef_erase_a.simps )
+apply(subgoal_tac "drop (Suc (Suc (s div 2))) lm \<noteq> []")
+apply(case_tac m, simp)
+apply(rule_tac x = "Suc (abc_lm_v lm (Suc (s div 2)))" in exI,
+ rule_tac x = rn in exI, simp, simp)
+apply(subgoal_tac "(Suc (Suc (s div 2))) \<le> n", simp,
+ rule_tac Suc_Suc_div, auto)
+done
+
+lemma mopup_false2:
+ "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n;
+ s mod 2 = Suc 0; Suc s \<noteq> 2 * n;
+ \<not> Suc (Suc s) \<le> 2 * n\<rbrakk> \<Longrightarrow> RR"
+apply(arith)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n;
+ s mod 2 = Suc 0;
+ mopup_bef_erase_a (s, l, Bk # xs) lm n ires;
+ r = Bk # xs\<rbrakk>
+ \<Longrightarrow> (Suc s = 2 * n \<longrightarrow>
+ mopup_jump_over1 (Suc (2 * n), Bk # l, xs) lm n ires) \<and>
+ (Suc s \<noteq> 2 * n \<longrightarrow>
+ (Suc (Suc s) \<le> 2 * n \<longrightarrow>
+ mopup_bef_erase_a (Suc (Suc s), Bk # l, xs) lm n ires) \<and>
+ (\<not> Suc (Suc s) \<le> 2 * n \<longrightarrow>
+ mopup_aft_erase_a (Suc (Suc s), Bk # l, xs) lm n ires))"
+apply(auto elim: mopup_false2)
+done
+
+lemma [simp]: "mopup_bef_erase_a (s, l, []) lm n ires \<Longrightarrow>
+ mopup_bef_erase_a (s, l, [Bk]) lm n ires"
+apply(auto simp: mopup_bef_erase_a.simps)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n; s mod 2 = Suc 0;
+ mopup_bef_erase_a (s, l, []) lm n ires; r = []\<rbrakk>
+ \<Longrightarrow> (Suc s = 2 * n \<longrightarrow>
+ mopup_jump_over1 (Suc (2 * n), Bk # l, []) lm n ires) \<and>
+ (Suc s \<noteq> 2 * n \<longrightarrow>
+ (Suc (Suc s) \<le> 2 * n \<longrightarrow>
+ mopup_bef_erase_a (Suc (Suc s), Bk # l, []) lm n ires) \<and>
+ (\<not> Suc (Suc s) \<le> 2 * n \<longrightarrow>
+ mopup_aft_erase_a (Suc (Suc s), Bk # l, []) lm n ires))"
+apply(auto)
+done
+
+lemma "mopup_bef_erase_b (s, l, Oc # xs) lm n ires \<Longrightarrow> l \<noteq> []"
+apply(auto simp: mopup_bef_erase_b.simps)
+done
+
+lemma [simp]: "mopup_bef_erase_b (s, l, Oc # xs) lm n ires = False"
+apply(auto simp: mopup_bef_erase_b.simps )
+done
+
+lemma [simp]: "\<lbrakk>0 < s; s \<le> 2 *n; s mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow>
+ (s - Suc 0) mod 2 = Suc 0"
+apply(arith)
+done
+
+lemma [simp]: "\<lbrakk>0 < s; s \<le> 2 *n; s mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow>
+ s - Suc 0 \<le> 2 * n"
+apply(simp)
+done
+
+lemma [simp]: "\<lbrakk>0 < s; s \<le> 2 *n; s mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow> \<not> s \<le> Suc 0"
+apply(arith)
+done
+
+lemma [simp]: "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n;
+ s mod 2 \<noteq> Suc 0;
+ mopup_bef_erase_b (s, l, Bk # xs) lm n ires; r = Bk # xs\<rbrakk>
+ \<Longrightarrow> mopup_bef_erase_a (s - Suc 0, Bk # l, xs) lm n ires"
+apply(auto simp: mopup_bef_erase_b.simps mopup_bef_erase_a.simps)
+done
+
+lemma [simp]: "\<lbrakk>mopup_bef_erase_b (s, l, []) lm n ires\<rbrakk> \<Longrightarrow>
+ mopup_bef_erase_a (s - Suc 0, Bk # l, []) lm n ires"
+apply(auto simp: mopup_bef_erase_b.simps mopup_bef_erase_a.simps)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm;
+ mopup_jump_over1 (Suc (2 * n), l, Oc # xs) lm n ires;
+ r = Oc # xs\<rbrakk>
+ \<Longrightarrow> mopup_jump_over1 (Suc (2 * n), Oc # l, xs) lm n ires"
+apply(auto simp: mopup_jump_over1.simps)
+apply(rule_tac x = ln in exI, rule_tac x = "Suc m1" in exI,
+ rule_tac x = "m2 - 1" in exI)
+apply(case_tac "m2", simp, simp, rule_tac x = rn in exI, simp)
+apply(rule_tac x = ln in exI, rule_tac x = "Suc m1" in exI,
+ rule_tac x = "m2 - 1" in exI)
+apply(case_tac m2, simp, simp)
+done
+
+lemma mopup_jump_over1_2_aft_erase_a[simp]:
+ "\<lbrakk>n < length lm; mopup_jump_over1 (Suc (2 * n), l, Bk # xs) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, xs) lm n ires"
+apply(simp only: mopup_jump_over1.simps mopup_aft_erase_a.simps)
+apply(erule_tac exE)+
+apply(rule_tac x = ln in exI, rule_tac x = "Suc 0" in exI)
+apply(case_tac m2, simp)
+apply(rule_tac x = rn in exI, rule_tac x = "drop (Suc n) lm" in exI,
+ simp)
+apply(simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; mopup_jump_over1 (Suc (2 * n), l, []) lm n ires\<rbrakk> \<Longrightarrow>
+ mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, []) lm n ires"
+apply(rule mopup_jump_over1_2_aft_erase_a, simp)
+apply(auto simp: mopup_jump_over1.simps)
+apply(rule_tac x = ln in exI, rule_tac x = m1 in exI,
+ rule_tac x = m2 in exI, simp add: )
+apply(rule_tac x = 0 in exI, auto)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm;
+ mopup_aft_erase_a (Suc (Suc (2 * n)), l, Oc # xs) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_aft_erase_b (Suc (Suc (Suc (2 * n))), l, Bk # xs) lm n ires"
+apply(auto simp: mopup_aft_erase_a.simps mopup_aft_erase_b.simps )
+apply(case_tac ml, simp, case_tac rn, simp, simp)
+apply(case_tac list, auto simp: tape_of_nl_abv
+ tape_of_nat_list.simps )
+apply(case_tac a, simp, rule_tac x = rn in exI,
+ rule_tac x = "[]" in exI,
+ simp add: tape_of_nat_list.simps, simp)
+apply(rule_tac x = rn in exI, rule_tac x = "[nat]" in exI,
+ simp add: tape_of_nat_list.simps )
+apply(case_tac a, simp, rule_tac x = rn in exI,
+ rule_tac x = "aa # lista" in exI, simp, simp)
+apply(rule_tac x = rn in exI, rule_tac x = "nat # aa # lista" in exI,
+ simp add: tape_of_nat_list.simps )
+done
+
+lemma [simp]:
+ "mopup_aft_erase_a (Suc (Suc (2 * n)), l, Bk # xs) lm n ires \<Longrightarrow> l \<noteq> []"
+apply(auto simp: mopup_aft_erase_a.simps)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm;
+ mopup_aft_erase_a (Suc (Suc (2 * n)), l, Bk # xs) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_left_moving (5 + 2 * n, tl l, hd l # Bk # xs) lm n ires"
+apply(simp only: mopup_aft_erase_a.simps mopup_left_moving.simps)
+apply(erule exE)+
+apply(case_tac lnr, simp)
+apply(rule_tac x = lnl in exI, simp, rule_tac x = rn in exI, simp)
+apply(subgoal_tac "ml = []", simp)
+apply(rule_tac xs = xs and rn = rn in BkCons_nil, simp, auto)
+apply(subgoal_tac "ml = []", auto)
+apply(rule_tac xs = xs and rn = rn in BkCons_nil, simp)
+done
+
+lemma [simp]:
+ "mopup_aft_erase_a (Suc (Suc (2 * n)), l, []) lm n ires \<Longrightarrow> l \<noteq> []"
+apply(simp only: mopup_aft_erase_a.simps)
+apply(erule exE)+
+apply(auto)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; mopup_aft_erase_a (Suc (Suc (2 * n)), l, []) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_left_moving (5 + 2 * n, tl l, [hd l]) lm n ires"
+apply(simp only: mopup_aft_erase_a.simps mopup_left_moving.simps)
+apply(erule exE)+
+apply(subgoal_tac "ml = [] \<and> rn = 0", erule conjE, erule conjE, simp)
+apply(case_tac lnr, simp, rule_tac x = lnl in exI, simp,
+ rule_tac x = 0 in exI, simp)
+apply(rule_tac x = lnl in exI, rule_tac x = nat in exI,
+ rule_tac x = "Suc 0" in exI, simp)
+apply(case_tac ml, simp, case_tac rn, simp, simp)
+apply(case_tac list, auto simp: tape_of_nl_abv tape_of_nat_list.simps)
+done
+
+lemma [simp]: "mopup_aft_erase_b (2 * n + 3, l, Oc # xs) lm n ires = False"
+apply(auto simp: mopup_aft_erase_b.simps )
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm;
+ mopup_aft_erase_c (2 * n + 4, l, Oc # xs) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_aft_erase_b (Suc (Suc (Suc (2 * n))), l, Bk # xs) lm n ires"
+apply(auto simp: mopup_aft_erase_c.simps mopup_aft_erase_b.simps )
+apply(case_tac ml, simp, case_tac rn, simp, simp, simp)
+apply(case_tac list, auto simp: tape_of_nl_abv
+ tape_of_nat_list.simps tape_of_nat_abv )
+apply(case_tac a, rule_tac x = rn in exI,
+ rule_tac x = "[]" in exI, simp add: tape_of_nat_list.simps)
+apply(rule_tac x = rn in exI, rule_tac x = "[nat]" in exI,
+ simp add: tape_of_nat_list.simps )
+apply(case_tac a, simp, rule_tac x = rn in exI,
+ rule_tac x = "aa # lista" in exI, simp)
+apply(rule_tac x = rn in exI, rule_tac x = "nat # aa # lista" in exI,
+ simp add: tape_of_nat_list.simps )
+done
+
+lemma mopup_aft_erase_c_aft_erase_a[simp]:
+ "\<lbrakk>n < length lm; mopup_aft_erase_c (2 * n + 4, l, Bk # xs) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, xs) lm n ires"
+apply(simp only: mopup_aft_erase_c.simps mopup_aft_erase_a.simps )
+apply(erule_tac exE)+
+apply(erule conjE, erule conjE, erule disjE)
+apply(subgoal_tac "ml = []", simp, case_tac rn,
+ simp, simp, rule conjI)
+apply(rule_tac x = lnl in exI, rule_tac x = "Suc lnr" in exI, simp)
+apply(rule_tac x = nat in exI, rule_tac x = "[]" in exI, simp)
+apply(rule_tac xs = xs and rn = rn in BkCons_nil, simp, simp,
+ rule conjI)
+apply(rule_tac x = lnl in exI, rule_tac x = "Suc lnr" in exI, simp)
+apply(rule_tac x = rn in exI, rule_tac x = "ml" in exI, simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; mopup_aft_erase_c (2 * n + 4, l, []) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, []) lm n ires"
+apply(rule mopup_aft_erase_c_aft_erase_a, simp)
+apply(simp only: mopup_aft_erase_c.simps)
+apply(erule exE)+
+apply(rule_tac x = lnl in exI, rule_tac x = lnr in exI, simp add: )
+apply(rule_tac x = 0 in exI, rule_tac x = "[]" in exI, simp)
+done
+
+lemma mopup_aft_erase_b_2_aft_erase_c[simp]:
+ "\<lbrakk>n < length lm; mopup_aft_erase_b (2 * n + 3, l, Bk # xs) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_aft_erase_c (4 + 2 * n, Bk # l, xs) lm n ires"
+apply(auto simp: mopup_aft_erase_b.simps mopup_aft_erase_c.simps)
+apply(rule_tac x = "lnl" in exI, rule_tac x = "Suc lnr" in exI, simp)
+apply(rule_tac x = "lnl" in exI, rule_tac x = "Suc lnr" in exI, simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; mopup_aft_erase_b (2 * n + 3, l, []) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_aft_erase_c (4 + 2 * n, Bk # l, []) lm n ires"
+apply(rule_tac mopup_aft_erase_b_2_aft_erase_c, simp)
+apply(simp add: mopup_aft_erase_b.simps)
+done
+
+lemma [simp]:
+ "mopup_left_moving (2 * n + 5, l, Oc # xs) lm n ires \<Longrightarrow> l \<noteq> []"
+apply(auto simp: mopup_left_moving.simps)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; mopup_left_moving (2 * n + 5, l, Oc # xs) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_jump_over2 (2 * n + 6, tl l, hd l # Oc # xs) lm n ires"
+apply(simp only: mopup_left_moving.simps mopup_jump_over2.simps)
+apply(erule_tac exE)+
+apply(erule conjE, erule disjE, erule conjE)
+apply(case_tac rn, simp, simp add: )
+apply(case_tac "hd l", simp add: )
+apply(case_tac "abc_lm_v lm n", simp)
+apply(rule_tac x = "lnl" in exI, rule_tac x = rn in exI,
+ rule_tac x = "Suc 0" in exI, rule_tac x = 0 in exI)
+apply(case_tac lnl, simp, simp, simp add: exp_ind[THEN sym], simp)
+apply(case_tac "abc_lm_v lm n", simp)
+apply(case_tac lnl, simp, simp)
+apply(rule_tac x = lnl in exI, rule_tac x = rn in exI)
+apply(rule_tac x = nat in exI, rule_tac x = "Suc (Suc 0)" in exI, simp)
+done
+
+lemma [simp]: "mopup_left_moving (2 * n + 5, l, xs) lm n ires \<Longrightarrow> l \<noteq> []"
+apply(auto simp: mopup_left_moving.simps)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; mopup_left_moving (2 * n + 5, l, Bk # xs) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_left_moving (2 * n + 5, tl l, hd l # Bk # xs) lm n ires"
+apply(simp only: mopup_left_moving.simps)
+apply(erule exE)+
+apply(case_tac lnr, simp)
+apply(rule_tac x = lnl in exI, rule_tac x = 0 in exI,
+ rule_tac x = rn in exI, simp, simp)
+apply(rule_tac x = lnl in exI, rule_tac x = nat in exI, simp)
+done
+
+lemma [simp]:
+"\<lbrakk>n < length lm; mopup_left_moving (2 * n + 5, l, []) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_left_moving (2 * n + 5, tl l, [hd l]) lm n ires"
+apply(simp only: mopup_left_moving.simps)
+apply(erule exE)+
+apply(case_tac lnr, simp)
+apply(rule_tac x = lnl in exI, rule_tac x = 0 in exI,
+ rule_tac x = 0 in exI, simp, auto)
+done
+
+lemma [simp]:
+ "mopup_jump_over2 (2 * n + 6, l, Oc # xs) lm n ires \<Longrightarrow> l \<noteq> []"
+apply(auto simp: mopup_jump_over2.simps )
+done
+
+lemma [intro]: "\<exists>lna. Bk # Bk\<^bsup>ln\<^esup> = Bk\<^bsup>lna\<^esup> @ [Bk]"
+apply(simp only: exp_ind[THEN sym], auto)
+done
+
+lemma [simp]:
+"\<lbrakk>n < length lm; mopup_jump_over2 (2 * n + 6, l, Oc # xs) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_jump_over2 (2 * n + 6, tl l, hd l # Oc # xs) lm n ires"
+apply(simp only: mopup_jump_over2.simps)
+apply(erule_tac exE)+
+apply(simp add: , erule conjE, erule_tac conjE)
+apply(case_tac m1, simp)
+apply(rule_tac x = ln in exI, rule_tac x = rn in exI,
+ rule_tac x = 0 in exI, simp)
+apply(case_tac ln, simp, simp, simp only: exp_ind[THEN sym], simp)
+apply(rule_tac x = ln in exI, rule_tac x = rn in exI,
+ rule_tac x = nat in exI, rule_tac x = "Suc m2" in exI, simp)
+done
+
+lemma [simp]: "\<exists>rna. Oc # Oc\<^bsup>a\<^esup> @ Bk\<^bsup>rn\<^esup> = <a> @ Bk\<^bsup>rna\<^esup>"
+apply(case_tac a, auto simp: tape_of_nat_abv )
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; mopup_jump_over2 (2 * n + 6, l, Bk # xs) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_stop (0, Bk # l, xs) lm n ires"
+apply(auto simp: mopup_jump_over2.simps mopup_stop.simps)
+done
+
+lemma [simp]: "mopup_jump_over2 (2 * n + 6, l, []) lm n ires = False"
+apply(simp only: mopup_jump_over2.simps, simp)
+done
+
+lemma mopup_inv_step:
+ "\<lbrakk>n < length lm; mopup_inv (s, l, r) lm n ires\<rbrakk>
+ \<Longrightarrow> mopup_inv (t_step (s, l, r)
+ ((mop_bef n @ tshift mp_up (2 * n)), 0)) lm n ires"
+apply(auto split:if_splits simp add:t_step.simps,
+ tactic {* ALLGOALS (resolve_tac [@{thm "fetch_intro"}]) *})
+apply(simp_all add: mopupfetchs new_tape.simps)
+done
+
+declare mopup_inv.simps[simp del]
+
+lemma mopup_inv_steps:
+"\<lbrakk>n < length lm; mopup_inv (s, l, r) lm n ires\<rbrakk> \<Longrightarrow>
+ mopup_inv (t_steps (s, l, r)
+ ((mop_bef n @ tshift mp_up (2 * n)), 0) stp) lm n ires"
+apply(induct stp, simp add: t_steps.simps)
+apply(simp add: t_steps_ind)
+apply(case_tac "(t_steps (s, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stp)", simp)
+apply(rule_tac mopup_inv_step, simp, simp)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; Suc 0 \<le> n\<rbrakk> \<Longrightarrow>
+ mopup_bef_erase_a (Suc 0, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, <lm> @ Bk\<^bsup>rn\<^esup>) lm n ires"
+apply(auto simp: mopup_bef_erase_a.simps abc_lm_v.simps)
+apply(case_tac lm, simp, case_tac list, simp, simp)
+apply(rule_tac x = "Suc a" in exI, rule_tac x = rn in exI, simp)
+done
+
+lemma [simp]:
+ "lm \<noteq> [] \<Longrightarrow> mopup_jump_over1 (Suc 0, Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires, <lm> @ Bk\<^bsup>rn\<^esup>) lm 0 ires"
+apply(auto simp: mopup_jump_over1.simps)
+apply(rule_tac x = ln in exI, rule_tac x = 0 in exI, simp add: )
+apply(case_tac lm, simp, simp add: abc_lm_v.simps)
+apply(case_tac rn, simp)
+apply(case_tac list, rule_tac disjI2,
+ simp add: tape_of_nl_abv tape_of_nat_list.simps)
+apply(rule_tac disjI1,
+ simp add: tape_of_nl_abv tape_of_nat_list.simps )
+apply(rule_tac disjI1, case_tac list,
+ simp add: tape_of_nl_abv tape_of_nat_list.simps,
+ rule_tac x = nat in exI, simp)
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps )
+done
+
+lemma mopup_init:
+ "\<lbrakk>n < length lm; crsp_l ly (as, lm) (ac, l, r) ires\<rbrakk> \<Longrightarrow>
+ mopup_inv (Suc 0, l, r) lm n ires"
+apply(auto simp: crsp_l.simps mopup_inv.simps)
+apply(case_tac n, simp, auto simp: mopup_bef_erase_a.simps )
+apply(rule_tac x = "Suc (hd lm)" in exI, rule_tac x = rn in exI, simp)
+apply(case_tac lm, simp, case_tac list, simp, case_tac lista, simp add: abc_lm_v.simps)
+apply(simp add: tape_of_nl_abv tape_of_nat_list.simps abc_lm_v.simps)
+apply(simp add: mopup_jump_over1.simps)
+apply(rule_tac x = 0 in exI, rule_tac x = 0 in exI, auto)
+apply(case_tac [!] n, simp_all)
+apply(case_tac [!] lm, simp, case_tac list, simp)
+apply(case_tac rn, simp add: tape_of_nl_abv tape_of_nat_list.simps abc_lm_v.simps)
+apply(erule_tac x = nat in allE, simp add: tape_of_nl_abv tape_of_nat_list.simps abc_lm_v.simps)
+apply(simp add: abc_lm_v.simps, auto)
+apply(case_tac list, simp_all add: tape_of_nl_abv tape_of_nat_list.simps abc_lm_v.simps)
+apply(erule_tac x = rn in allE, simp_all)
+done
+
+(***Begin: mopup stop***)
+fun abc_mopup_stage1 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_mopup_stage1 (s, l, r) n =
+ (if s > 0 \<and> s \<le> 2*n then 6
+ else if s = 2*n + 1 then 4
+ else if s \<ge> 2*n + 2 \<and> s \<le> 2*n + 4 then 3
+ else if s = 2*n + 5 then 2
+ else if s = 2*n + 6 then 1
+ else 0)"
+
+fun abc_mopup_stage2 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_mopup_stage2 (s, l, r) n =
+ (if s > 0 \<and> s \<le> 2*n then length r
+ else if s = 2*n + 1 then length r
+ else if s = 2*n + 5 then length l
+ else if s = 2*n + 6 then length l
+ else if s \<ge> 2*n + 2 \<and> s \<le> 2*n + 4 then length r
+ else 0)"
+
+fun abc_mopup_stage3 :: "t_conf \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "abc_mopup_stage3 (s, l, r) n =
+ (if s > 0 \<and> s \<le> 2*n then
+ if hd r = Bk then 0
+ else 1
+ else if s = 2*n + 2 then 1
+ else if s = 2*n + 3 then 0
+ else if s = 2*n + 4 then 2
+ else 0)"
+
+fun abc_mopup_measure :: "(t_conf \<times> nat) \<Rightarrow> (nat \<times> nat \<times> nat)"
+ where
+ "abc_mopup_measure (c, n) =
+ (abc_mopup_stage1 c n, abc_mopup_stage2 c n,
+ abc_mopup_stage3 c n)"
+
+definition abc_mopup_LE ::
+ "(((nat \<times> block list \<times> block list) \<times> nat) \<times>
+ ((nat \<times> block list \<times> block list) \<times> nat)) set"
+ where
+ "abc_mopup_LE \<equiv> (inv_image lex_triple abc_mopup_measure)"
+
+lemma wf_abc_mopup_le[intro]: "wf abc_mopup_LE"
+by(auto intro:wf_inv_image wf_lex_triple simp:abc_mopup_LE_def)
+
+lemma [simp]: "mopup_bef_erase_a (a, aa, []) lm n ires = False"
+apply(auto simp: mopup_bef_erase_a.simps)
+done
+
+lemma [simp]: "mopup_bef_erase_b (a, aa, []) lm n ires = False"
+apply(auto simp: mopup_bef_erase_b.simps)
+done
+
+lemma [simp]: "mopup_aft_erase_b (2 * n + 3, aa, []) lm n ires = False"
+apply(auto simp: mopup_aft_erase_b.simps)
+done
+
+lemma mopup_halt_pre:
+ "\<lbrakk>n < length lm; mopup_inv (Suc 0, l, r) lm n ires; wf abc_mopup_LE\<rbrakk>
+ \<Longrightarrow> \<forall>na. \<not> (\<lambda>(s, l, r) n. s = 0) (t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) na) n \<longrightarrow>
+ ((t_steps (Suc 0, l, r) (mop_bef n @ tshift mp_up (2 * n), 0)
+ (Suc na), n),
+ t_steps (Suc 0, l, r) (mop_bef n @ tshift mp_up (2 * n), 0)
+ na, n) \<in> abc_mopup_LE"
+apply(rule allI, rule impI, simp add: t_steps_ind)
+apply(subgoal_tac "mopup_inv (t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) na) lm n ires")
+apply(case_tac "(t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) na)", simp)
+proof -
+ fix na a b c
+ assume "n < length lm" "mopup_inv (a, b, c) lm n ires" "0 < a"
+ thus "((t_step (a, b, c) (mop_bef n @ tshift mp_up (2 * n), 0), n),
+ (a, b, c), n) \<in> abc_mopup_LE"
+ apply(auto split:if_splits simp add:t_step.simps mopup_inv.simps,
+ tactic {* ALLGOALS (resolve_tac [@{thm "fetch_intro"}]) *})
+ apply(simp_all add: mopupfetchs new_tape.simps abc_mopup_LE_def
+ lex_triple_def lex_pair_def )
+ done
+next
+ fix na
+ assume "n < length lm" "mopup_inv (Suc 0, l, r) lm n ires"
+ thus "mopup_inv (t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) na) lm n ires"
+ apply(rule mopup_inv_steps)
+ done
+qed
+
+lemma mopup_halt: "\<lbrakk>n < length lm; crsp_l ly (as, lm) (s, l, r) ires\<rbrakk> \<Longrightarrow>
+ \<exists> stp. (\<lambda> (s, l, r). s = 0) (t_steps (Suc 0, l, r)
+ ((mop_bef n @ tshift mp_up (2 * n)), 0) stp)"
+apply(subgoal_tac "mopup_inv (Suc 0, l, r) lm n ires")
+apply(insert wf_abc_mopup_le)
+apply(insert halt_lemma[of abc_mopup_LE
+ "\<lambda> ((s, l, r), n). s = 0"
+ "\<lambda> stp. (t_steps (Suc 0, l, r) ((mop_bef n @ tshift mp_up (2 * n))
+ , 0) stp, n)"], auto)
+apply(insert mopup_halt_pre[of n lm l r], simp, erule exE)
+apply(rule_tac x = na in exI, case_tac "(t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) na)", simp)
+apply(rule_tac mopup_init, auto)
+done
+(***End: mopup stop****)
+(*
+lemma mopup_stop_cond: "mopup_inv (0, l, r) lm n ires \<Longrightarrow>
+ (\<exists>ln rn. ?l = Bk\<^bsup>ln\<^esup> @ Bk # Bk # ?ires \<and> ?r = <abc_lm_v ?lm ?n> @ Bk\<^bsup>rn\<^esup>) "
+ t_halt_conf (0, l, r) \<and> t_result r = Suc (abc_lm_v lm n)"
+apply(simp add: mopup_inv.simps mopup_stop.simps t_halt_conf.simps
+ t_result.simps, auto simp: tape_of_nat_abv)
+apply(rule_tac x = rn in exI,
+ rule_tac x = "Suc (abc_lm_v lm n)" in exI,
+ simp add: tape_of_nat_abv)
+apply(simp add: tape_of_nat_abv exponent_def)
+apply(subgoal_tac "takeWhile (\<lambda>a. a = Oc)
+ (replicate (abc_lm_v lm n) Oc @ replicate rn Bk)
+ = replicate (abc_lm_v lm n) Oc @ takeWhile (\<lambda>a. a = Oc)
+ (replicate rn Bk)", simp)
+apply(case_tac rn, simp, simp)
+apply(rule takeWhile_append2)
+apply(case_tac x, auto)
+done
+*)
+
+
+lemma mopup_halt_conf_pre:
+ "\<lbrakk>n < length lm; crsp_l ly (as, lm) (s, l, r) ires\<rbrakk>
+ \<Longrightarrow> \<exists> na. (\<lambda> (s', l', r'). s' = 0 \<and> mopup_stop (s', l', r') lm n ires)
+ (t_steps (Suc 0, l, r)
+ ((mop_bef n @ tshift mp_up (2 * n)), 0) na)"
+apply(subgoal_tac "\<exists> stp. (\<lambda> (s, l, r). s = 0)
+ (t_steps (Suc 0, l, r) ((mop_bef n @ tshift mp_up (2 * n)), 0) stp)",
+ erule exE)
+apply(rule_tac x = stp in exI,
+ case_tac "(t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stp)", simp)
+apply(subgoal_tac " mopup_inv (Suc 0, l, r) lm n ires")
+apply(subgoal_tac "mopup_inv (t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stp) lm n ires", simp)
+apply(simp only: mopup_inv.simps)
+apply(rule_tac mopup_inv_steps, simp, simp)
+apply(rule_tac mopup_init, simp, simp)
+apply(rule_tac mopup_halt, simp, simp)
+done
+
+thm mopup_stop.simps
+
+lemma mopup_halt_conf:
+ assumes len: "n < length lm"
+ and correspond: "crsp_l ly (as, lm) (s, l, r) ires"
+ shows
+ "\<exists> na. (\<lambda> (s', l', r'). ((\<exists>ln rn. s' = 0 \<and> l' = Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires \<and> r' = Oc\<^bsup>Suc (abc_lm_v lm n)\<^esup> @ Bk\<^bsup>rn\<^esup>)))
+ (t_steps (Suc 0, l, r)
+ ((mop_bef n @ tshift mp_up (2 * n)), 0) na)"
+using len correspond mopup_halt_conf_pre[of n lm ly as s l r ires]
+apply(simp add: mopup_stop.simps tape_of_nat_abv tape_of_nat_list.simps)
+done
+(*********End: mop_up****************************)
+
+
+subsubsection {* Final results about Abacus machine *}
+
+thm mopup_halt
+lemma mopup_halt_bef: "\<lbrakk>n < length lm; crsp_l ly (as, lm) (s, l, r) ires\<rbrakk>
+ \<Longrightarrow> \<exists>stp. (\<lambda>(s, l, r). s \<noteq> 0 \<and> ((\<lambda> (s', l', r'). s' = 0)
+ (t_step (s, l, r) (mop_bef n @ tshift mp_up (2 * n), 0))))
+ (t_steps (Suc 0, l, r) (mop_bef n @ tshift mp_up (2 * n), 0) stp)"
+apply(insert mopup_halt[of n lm ly as s l r ires], simp, erule_tac exE)
+proof -
+ fix stp
+ assume "n < length lm"
+ "crsp_l ly (as, lm) (s, l, r) ires"
+ "(\<lambda>(s, l, r). s = 0)
+ (t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stp)"
+ thus "\<exists>stp. (\<lambda>(s, ab). 0 < s \<and> (\<lambda>(s', l', r'). s' = 0)
+ (t_step (s, ab) (mop_bef n @ tshift mp_up (2 * n), 0)))
+ (t_steps (Suc 0, l, r) (mop_bef n @ tshift mp_up (2 * n), 0) stp)"
+ proof(induct stp, simp add: t_steps.simps, simp)
+ fix stpa
+ assume h1:
+ "(\<lambda>(s, l, r). s = 0) (t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stpa) \<Longrightarrow>
+ \<exists>stp. (\<lambda>(s, ab). 0 < s \<and> (\<lambda>(s', l', r'). s' = 0)
+ (t_step (s, ab) (mop_bef n @ tshift mp_up (2 * n), 0)))
+ (t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stp)"
+ and h2:
+ "(\<lambda>(s, l, r). s = 0) (t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) (Suc stpa))"
+ "n < length lm"
+ "crsp_l ly (as, lm) (s, l, r) ires"
+ thus "\<exists>stp. (\<lambda>(s, ab). 0 < s \<and> (\<lambda>(s', l', r'). s' = 0)
+ (t_step (s, ab) (mop_bef n @ tshift mp_up (2 * n), 0))) (
+ t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stp)"
+ apply(case_tac "(\<lambda>(s, l, r). s = 0) (t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stpa)",
+ simp)
+ apply(rule_tac x = "stpa" in exI)
+ apply(case_tac "(t_steps (Suc 0, l, r)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stpa)",
+ simp add: t_steps_ind)
+ done
+ qed
+qed
+
+lemma tshift_nth_state0: "\<lbrakk>n < length tp; tp ! n = (a, 0)\<rbrakk>
+ \<Longrightarrow> tshift tp off ! n = (a, 0)"
+apply(induct n, case_tac tp, simp)
+apply(auto simp: tshift.simps)
+done
+
+lemma shift_length: "length (tshift tp n) = length tp"
+apply(auto simp: tshift.simps)
+done
+
+lemma even_Suc_le: "\<lbrakk>y mod 2 = 0; 2 * x < y\<rbrakk> \<Longrightarrow> Suc (2 * x) < y"
+by arith
+
+lemma [simp]: "(4::nat) * n mod 2 = 0"
+by arith
+
+lemma tm_append_fetch_equal:
+ "\<lbrakk>t_ncorrect (tm_of aprog); s'> 0;
+ fetch (mop_bef n @ tshift mp_up (2 * n)) s' b = (a, 0)\<rbrakk>
+\<Longrightarrow> fetch (tm_of aprog @ tshift (mop_bef n @ tshift mp_up (2 * n))
+ (length (tm_of aprog) div 2)) (s' + length (tm_of aprog) div 2) b
+ = (a, 0)"
+apply(case_tac s', simp)
+apply(auto simp: fetch.simps nth_of.simps t_ncorrect.simps shift_length nth_append
+ tshift.simps split: list.splits block.splits split: if_splits)
+done
+
+lemma [simp]:
+ "\<lbrakk>t_ncorrect (tm_of aprog);
+ t_step (s', l', r') (mop_bef n @ tshift mp_up (2 * n), 0) =
+ (0, l'', r''); s' > 0\<rbrakk>
+ \<Longrightarrow> t_step (s' + length (tm_of aprog) div 2, l', r')
+ (tm_of aprog @ tshift (mop_bef n @ tshift mp_up (2 * n))
+ (length (tm_of aprog) div 2), 0) = (0, l'', r'')"
+apply(simp add: t_step.simps)
+apply(subgoal_tac
+ "(fetch (mop_bef n @ tshift mp_up (2 * n)) s'
+ (case r' of [] \<Rightarrow> Bk | Bk # xs \<Rightarrow> Bk | Oc # xs \<Rightarrow> Oc))
+ = (fetch (tm_of aprog @ tshift (mop_bef n @ tshift mp_up (2 * n))
+ (length (tm_of aprog) div 2)) (s' + length (tm_of aprog) div 2)
+ (case r' of [] \<Rightarrow> Bk | Bk # xs \<Rightarrow> Bk | Oc # xs \<Rightarrow> Oc))", simp)
+apply(case_tac "(fetch (mop_bef n @ tshift mp_up (2 * n)) s'
+ (case r' of [] \<Rightarrow> Bk | Bk # xs \<Rightarrow> Bk | Oc # xs \<Rightarrow> Oc))", simp)
+apply(drule_tac tm_append_fetch_equal, auto)
+done
+
+lemma [intro]:
+ "start_of (layout_of aprog) (length aprog) - Suc 0 =
+ length (tm_of aprog) div 2"
+apply(subgoal_tac "abc2t_correct aprog")
+apply(insert pre_lheq[of "concat (take (length aprog)
+ (tms_of aprog))" "length aprog" aprog], simp add: tm_of.simps)
+by auto
+
+lemma tm_append_stop_step:
+ "\<lbrakk>t_ncorrect (tm_of aprog);
+ t_ncorrect (mop_bef n @ tshift mp_up (2 * n)); n < length lm;
+ (t_steps (Suc 0, l, r) (mop_bef n @ tshift mp_up (2 * n), 0) stp) =
+ (s', l', r');
+ s' \<noteq> 0;
+ t_step (s', l', r') (mop_bef n @ tshift mp_up (2 * n), 0)
+ = (0, l'', r'')\<rbrakk>
+ \<Longrightarrow>
+(t_steps ((start_of (layout_of aprog) (length aprog), l, r))
+ (tm_of aprog @ tshift (mop_bef n @ tshift mp_up (2 * n))
+ (start_of (layout_of aprog) (length aprog) - Suc 0), 0) (Suc stp))
+ = (0, l'', r'')"
+apply(insert tm_append_steps_equal[of "tm_of aprog"
+ "(mop_bef n @ tshift mp_up (2 * n))"
+ "(start_of (layout_of aprog) (length aprog) - Suc 0)"
+ "Suc 0" l r stp], simp)
+apply(subgoal_tac "(start_of (layout_of aprog) (length aprog) - Suc 0)
+ = (length (tm_of aprog) div 2)", simp add: t_steps_ind)
+apply(case_tac
+ "(t_steps (start_of (layout_of aprog) (length aprog), l, r)
+ (tm_of aprog @ tshift (mop_bef n @ tshift mp_up (2 * n))
+ (length (tm_of aprog) div 2), 0) stp)", simp)
+apply(subgoal_tac "start_of (layout_of aprog) (length aprog) > 0",
+ case_tac "start_of (layout_of aprog) (length aprog)",
+ simp, simp)
+apply(rule startof_not0, auto)
+done
+
+(*
+lemma stop_conf: "mopup_inv (0, aca, bc) am n
+ \<Longrightarrow> t_halt_conf (0, aca, bc) \<and> t_result bc = Suc (abc_lm_v am n)"
+apply(case_tac n,
+ auto simp: mopup_inv.simps mopup_stop.simps t_halt_conf.simps
+ t_result.simps tape_of_nl_abv tape_of_nat_abv )
+apply(rule_tac x = "rn" in exI,
+ rule_tac x = "Suc (abc_lm_v am 0)" in exI, simp)
+apply(subgoal_tac "takeWhile (\<lambda>a. a = Oc) (Oc\<^bsup>abc_lm_v am 0\<^esup> @ Bk\<^bsup>rn\<^esup>)
+ = Oc\<^bsup>abc_lm_v am 0\<^esup> @ takeWhile (\<lambda>a. a = Oc) (Bk\<^bsup>rn\<^esup>)", simp)
+apply(simp add: exponent_def, case_tac rn, simp, simp)
+apply(rule_tac takeWhile_append2, simp add: exponent_def)
+apply(rule_tac x = rn in exI,
+ rule_tac x = "Suc (abc_lm_v am (Suc nat))" in exI, simp)
+apply(subgoal_tac
+ "takeWhile (\<lambda>a. a = Oc) (Oc\<^bsup>abc_lm_v am (Suc nat)\<^esup> @ Bk\<^bsup>rn\<^esup>) =
+ Oc\<^bsup>abc_lm_v am (Suc nat)\<^esup> @ takeWhile (\<lambda>a. a = Oc) (Bk\<^bsup>rn\<^esup>)", simp)
+apply(simp add: exponent_def, case_tac rn, simp, simp)
+apply(rule_tac takeWhile_append2, simp add: exponent_def)
+done
+*)
+
+
+lemma start_of_out_range:
+"as \<ge> length aprog \<Longrightarrow>
+ start_of (layout_of aprog) as =
+ start_of (layout_of aprog) (length aprog)"
+apply(induct as, simp)
+apply(case_tac "length aprog = Suc as", simp)
+apply(simp add: start_of.simps)
+done
+
+lemma [intro]: "t_ncorrect (tm_of aprog)"
+apply(simp add: tm_of.simps)
+apply(insert tms_mod2[of "length aprog" aprog],
+ simp add: t_ncorrect.simps)
+done
+
+lemma abacus_turing_eq_halt_case_pre:
+ "\<lbrakk>ly = layout_of aprog;
+ tprog = tm_of aprog;
+ crsp_l ly ac tc ires;
+ n < length am;
+ abc_steps_l ac aprog stp = (as, am);
+ mop_ss = start_of ly (length aprog);
+ as \<ge> length aprog\<rbrakk>
+ \<Longrightarrow> \<exists> stp. (\<lambda> (s, l, r). s = 0 \<and> mopup_inv (0, l, r) am n ires)
+ (t_steps tc (tprog @ (tMp n (mop_ss - 1)), 0) stp)"
+apply(insert steps_crsp[of ly aprog tprog ac tc ires "(as, am)" stp], auto)
+apply(case_tac "(t_steps tc (tm_of aprog, 0) n')",
+ simp add: tMp.simps)
+apply(subgoal_tac "t_ncorrect (mop_bef n @ tshift mp_up (2 * n))")
+proof -
+ fix n' a b c
+ assume h1:
+ "crsp_l (layout_of aprog) ac tc ires"
+ "abc_steps_l ac aprog stp = (as, am)"
+ "length aprog \<le> as"
+ "crsp_l (layout_of aprog) (as, am) (a, b, c) ires"
+ "t_steps tc (tm_of aprog, 0) n' = (a, b, c)"
+ "n < length am"
+ "t_ncorrect (mop_bef n @ tshift mp_up (2 * n))"
+ hence h2:
+ "t_steps tc (tm_of aprog @ tshift (mop_bef n @ tshift mp_up (2 * n))
+ (start_of (layout_of aprog) (length aprog) - Suc 0), 0) n'
+ = (a, b, c)"
+ apply(rule_tac tm_append_steps, simp)
+ apply(simp add: crsp_l.simps, auto)
+ apply(simp add: crsp_l.simps)
+ apply(rule startof_not0)
+ done
+ from h1 have h3:
+ "\<exists>stp. (\<lambda>(s, l, r). s \<noteq> 0 \<and> ((\<lambda> (s', l', r'). s' = 0)
+ (t_step (s, l, r) (mop_bef n @ tshift mp_up (2 * n), 0))))
+ (t_steps (Suc 0, b, c)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stp)"
+ apply(rule_tac mopup_halt_bef, auto)
+ done
+ from h1 and h2 and h3 show
+ "\<exists>stp. case t_steps tc (tm_of aprog @ abacus.tshift (mop_bef n @ abacus.tshift mp_up (2 * n))
+ (start_of (layout_of aprog) (length aprog) - Suc 0), 0) stp of (s, ab)
+ \<Rightarrow> s = 0 \<and> mopup_inv (0, ab) am n ires"
+ proof(erule_tac exE,
+ case_tac "(t_steps (Suc 0, b, c)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stpa)", simp,
+ case_tac "(t_step (aa, ba, ca)
+ (mop_bef n @ tshift mp_up (2 * n), 0))", simp)
+ fix stpa aa ba ca aaa baa caa
+ assume g1: "0 < aa \<and> aaa = 0"
+ "t_steps (Suc 0, b, c)
+ (mop_bef n @ tshift mp_up (2 * n), 0) stpa = (aa, ba,ca)"
+ "t_step (aa, ba, ca) (mop_bef n @ tshift mp_up (2 * n), 0)
+ = (0, baa, caa)"
+ from h1 and this have g2:
+ "t_steps (start_of (layout_of aprog) (length aprog), b, c)
+ (tm_of aprog @ tshift (mop_bef n @ tshift mp_up (2 * n))
+ (start_of (layout_of aprog) (length aprog) - Suc 0), 0)
+ (Suc stpa) = (0, baa, caa)"
+ apply(rule_tac tm_append_stop_step, auto)
+ done
+ from h1 and h2 and g1 and this show "?thesis"
+ apply(rule_tac x = "n' + Suc stpa" in exI)
+ apply(simp add: t_steps_ind del: t_steps.simps)
+ apply(subgoal_tac "a = start_of (layout_of aprog)
+ (length aprog)", simp)
+ apply(insert mopup_inv_steps[of n am "Suc 0" b c ires "Suc stpa"],
+ simp add: t_steps_ind)
+ apply(subgoal_tac "mopup_inv (Suc 0, b, c) am n ires", simp)
+ apply(rule_tac mopup_init, simp, simp)
+ apply(simp add: crsp_l.simps)
+ apply(erule_tac start_of_out_range)
+ done
+ qed
+next
+ show " t_ncorrect (mop_bef n @ tshift mp_up (2 * n))"
+ apply(auto simp: t_ncorrect.simps tshift.simps mp_up_def)
+ done
+qed
+
+text {*
+ One of the main theorems about Abacus compilation.
+*}
+
+lemma abacus_turing_eq_halt_case:
+ assumes layout:
+ -- {* There is an Abacus program @{text "aprog"} with layout @{text "ly"}: *}
+ "ly = layout_of aprog"
+ and complied:
+ -- {* The TM compiled from @{text "aprog"} is @{text "tprog"}: *}
+ "tprog = tm_of aprog"
+ and correspond:
+ -- {* TM configuration @{text "tc"} and Abacus configuration @{text "ac"}
+ are in correspondence: *}
+ "crsp_l ly ac tc ires"
+ and halt_state:
+ -- {* @{text "as"} is a program label outside the range of @{text "aprog"}. So
+ if Abacus is in such a state, it is in halt state: *}
+ "as \<ge> length aprog"
+ and abc_exec:
+ -- {* Supposing after @{text "stp"} step of execution, Abacus program @{text "aprog"}
+ reaches such a halt state: *}
+ "abc_steps_l ac aprog stp = (as, am)"
+ and rs_len:
+ -- {* @{text "n"} is a memory address in the range of Abacus memory @{text "am"}: *}
+ "n < length am"
+ and mopup_start:
+ -- {* The startling label for mopup mahines, according to the layout and Abacus program
+ should be @{text "mop_ss"}: *}
+ "mop_ss = start_of ly (length aprog)"
+ shows
+ -- {*
+ After @{text "stp"} steps of execution of the TM composed of @{text "tprog"} and the mopup
+ TM @{text "(tMp n (mop_ss - 1))"} will halt and gives rise to a configuration which
+ only hold the content of memory cell @{text "n"}:
+ *}
+ "\<exists> stp. (\<lambda> (s, l, r). \<exists> ln rn. s = 0 \<and> l = Bk\<^bsup>ln\<^esup> @ Bk # Bk # ires \<and> r = Oc\<^bsup>Suc (abc_lm_v am n)\<^esup> @ Bk\<^bsup>rn\<^esup>)
+ (t_steps tc (tprog @ (tMp n (mop_ss - 1)), 0) stp)"
+proof -
+ from layout complied correspond halt_state abc_exec rs_len mopup_start
+ and abacus_turing_eq_halt_case_pre [of ly aprog tprog ac tc ires n am stp as mop_ss]
+ show "?thesis"
+ apply(simp add: mopup_inv.simps mopup_stop.simps tape_of_nat_abv)
+ done
+qed
+
+lemma abc_unhalt_case_zero:
+"\<lbrakk>crsp_l (layout_of aprog) ac tc ires;
+ n < length am;
+ \<forall>stp. (\<lambda>(as, am). as < length aprog) (abc_steps_l ac aprog stp)\<rbrakk>
+ \<Longrightarrow> \<exists>astp bstp. 0 \<le> bstp \<and>
+ crsp_l (layout_of aprog) (abc_steps_l ac aprog astp)
+ (t_steps tc (tm_of aprog, 0) bstp) ires"
+apply(rule_tac x = "Suc 0" in exI)
+apply(case_tac " abc_steps_l ac aprog (Suc 0)", simp)
+proof -
+ fix a b
+ assume "crsp_l (layout_of aprog) ac tc ires"
+ "abc_steps_l ac aprog (Suc 0) = (a, b)"
+ thus "\<exists>bstp. crsp_l (layout_of aprog) (a, b)
+ (t_steps tc (tm_of aprog, 0) bstp) ires"
+ apply(insert steps_crsp[of "layout_of aprog" aprog
+ "tm_of aprog" ac tc ires "(a, b)" "Suc 0"], auto)
+ done
+qed
+
+declare abc_steps_l.simps[simp del]
+
+lemma abc_steps_ind:
+ "let (as, am) = abc_steps_l ac aprog stp in
+ abc_steps_l ac aprog (Suc stp) =
+ abc_step_l (as, am) (abc_fetch as aprog) "
+proof(simp)
+ show "(\<lambda>(as, am). abc_steps_l ac aprog (Suc stp) =
+ abc_step_l (as, am) (abc_fetch as aprog))
+ (abc_steps_l ac aprog stp)"
+ proof(induct stp arbitrary: ac)
+ fix ac
+ show "(\<lambda>(as, am). abc_steps_l ac aprog (Suc 0) =
+ abc_step_l (as, am) (abc_fetch as aprog))
+ (abc_steps_l ac aprog 0)"
+ apply(case_tac "ac:: nat \<times> nat list",
+ simp add: abc_steps_l.simps)
+ apply(case_tac "(abc_step_l (a, b) (abc_fetch a aprog))",
+ simp add: abc_steps_l.simps)
+ done
+ next
+ fix stp ac
+ assume h1:
+ "(\<And>ac. (\<lambda>(as, am). abc_steps_l ac aprog (Suc stp) =
+ abc_step_l (as, am) (abc_fetch as aprog))
+ (abc_steps_l ac aprog stp))"
+ thus
+ "(\<lambda>(as, am). abc_steps_l ac aprog (Suc (Suc stp)) =
+ abc_step_l (as, am) (abc_fetch as aprog))
+ (abc_steps_l ac aprog (Suc stp))"
+ apply(case_tac "ac::nat \<times> nat list", simp)
+ apply(subgoal_tac
+ "abc_steps_l (a, b) aprog (Suc (Suc stp)) =
+ abc_steps_l (abc_step_l (a, b) (abc_fetch a aprog))
+ aprog (Suc stp)", simp)
+ apply(case_tac "(abc_step_l (a, b) (abc_fetch a aprog))", simp)
+ proof -
+ fix a b aa ba
+ assume h2: "abc_step_l (a, b) (abc_fetch a aprog) = (aa, ba)"
+ from h1 and h2 show
+ "(\<lambda>(as, am). abc_steps_l (aa, ba) aprog (Suc stp) =
+ abc_step_l (as, am) (abc_fetch as aprog))
+ (abc_steps_l (a, b) aprog (Suc stp))"
+ apply(insert h1[of "(aa, ba)"])
+ apply(simp add: abc_steps_l.simps)
+ apply(insert h2, simp)
+ done
+ next
+ fix a b
+ show
+ "abc_steps_l (a, b) aprog (Suc (Suc stp)) =
+ abc_steps_l (abc_step_l (a, b) (abc_fetch a aprog))
+ aprog (Suc stp)"
+ apply(simp only: abc_steps_l.simps)
+ done
+ qed
+ qed
+qed
+
+lemma abc_unhalt_case_induct:
+ "\<lbrakk>crsp_l (layout_of aprog) ac tc ires;
+ n < length am;
+ \<forall>stp. (\<lambda>(as, am). as < length aprog) (abc_steps_l ac aprog stp);
+ stp \<le> bstp;
+ crsp_l (layout_of aprog) (abc_steps_l ac aprog astp)
+ (t_steps tc (tm_of aprog, 0) bstp) ires\<rbrakk>
+ \<Longrightarrow> \<exists>astp bstp. Suc stp \<le> bstp \<and> crsp_l (layout_of aprog)
+ (abc_steps_l ac aprog astp) (t_steps tc (tm_of aprog, 0) bstp) ires"
+apply(rule_tac x = "Suc astp" in exI)
+apply(case_tac "abc_steps_l ac aprog astp")
+proof -
+ fix a b
+ assume
+ "\<forall>stp. (\<lambda>(as, am). as < length aprog)
+ (abc_steps_l ac aprog stp)"
+ "stp \<le> bstp"
+ "crsp_l (layout_of aprog) (abc_steps_l ac aprog astp)
+ (t_steps tc (tm_of aprog, 0) bstp) ires"
+ "abc_steps_l ac aprog astp = (a, b)"
+ thus
+ "\<exists>bstp\<ge>Suc stp. crsp_l (layout_of aprog)
+ (abc_steps_l ac aprog (Suc astp))
+ (t_steps tc (tm_of aprog, 0) bstp) ires"
+ apply(insert crsp_inside[of "layout_of aprog" aprog
+ "tm_of aprog" a b "(t_steps tc (tm_of aprog, 0) bstp)" "ires"], auto)
+ apply(erule_tac x = astp in allE, auto)
+ apply(rule_tac x = "bstp + stpa" in exI, simp)
+ apply(insert abc_steps_ind[of ac aprog "astp"], simp)
+ done
+qed
+
+lemma abc_unhalt_case:
+ "\<lbrakk>crsp_l (layout_of aprog) ac tc ires;
+ \<forall>stp. (\<lambda>(as, am). as < length aprog) (abc_steps_l ac aprog stp)\<rbrakk>
+ \<Longrightarrow> (\<exists> astp bstp. bstp \<ge> stp \<and>
+ crsp_l (layout_of aprog) (abc_steps_l ac aprog astp)
+ (t_steps tc (tm_of aprog, 0) bstp) ires)"
+apply(induct stp)
+apply(rule_tac abc_unhalt_case_zero, auto)
+apply(rule_tac abc_unhalt_case_induct, auto)
+done
+
+lemma abacus_turing_eq_unhalt_case_pre:
+ "\<lbrakk>ly = layout_of aprog;
+ tprog = tm_of aprog;
+ crsp_l ly ac tc ires;
+ \<forall> stp. ((\<lambda> (as, am). as < length aprog)
+ (abc_steps_l ac aprog stp));
+ mop_ss = start_of ly (length aprog)\<rbrakk>
+ \<Longrightarrow> (\<not> (\<exists> stp. (\<lambda> (s, l, r). s = 0)
+ (t_steps tc (tprog @ (tMp n (mop_ss - 1)), 0) stp)))"
+ apply(auto)
+proof -
+ fix stp a b
+ assume h1:
+ "crsp_l (layout_of aprog) ac tc ires"
+ "\<forall>stp. (\<lambda>(as, am). as < length aprog) (abc_steps_l ac aprog stp)"
+ "t_steps tc (tm_of aprog @ tMp n (start_of (layout_of aprog)
+ (length aprog) - Suc 0), 0) stp = (0, a, b)"
+ thus "False"
+ proof(insert abc_unhalt_case[of aprog ac tc ires stp], auto,
+ case_tac "(abc_steps_l ac aprog astp)",
+ case_tac "(t_steps tc (tm_of aprog, 0) bstp)", simp)
+ fix astp bstp aa ba aaa baa c
+ assume h2:
+ "abc_steps_l ac aprog astp = (aa, ba)" "stp \<le> bstp"
+ "t_steps tc (tm_of aprog, 0) bstp = (aaa, baa, c)"
+ "crsp_l (layout_of aprog) (aa, ba) (aaa, baa, c) ires"
+ hence h3:
+ "t_steps tc (tm_of aprog @ tMp n
+ (start_of (layout_of aprog) (length aprog) - Suc 0), 0) bstp
+ = (aaa, baa, c)"
+ apply(intro tm_append_steps, auto)
+ apply(simp add: crsp_l.simps, rule startof_not0)
+ done
+ from h2 have h4: "\<exists> diff. bstp = stp + diff"
+ apply(rule_tac x = "bstp - stp" in exI, simp)
+ done
+ from h4 and h3 and h2 and h1 show "?thesis"
+ apply(auto)
+ apply(simp add: state0_ind crsp_l.simps)
+ apply(subgoal_tac "start_of (layout_of aprog) aa > 0", simp)
+ apply(rule startof_not0)
+ done
+ qed
+qed
+
+lemma abacus_turing_eq_unhalt_case:
+ assumes layout:
+ -- {* There is an Abacus program @{text "aprog"} with layout @{text "ly"}: *}
+ "ly = layout_of aprog"
+ and compiled:
+ -- {* The TM compiled from @{text "aprog"} is @{text "tprog"}: *}
+ "tprog = tm_of aprog"
+ and correspond:
+ -- {*
+ TM configuration @{text "tc"} and Abacus configuration @{text "ac"}
+ are in correspondence:
+ *}
+ "crsp_l ly ac tc ires"
+ and abc_unhalt:
+ -- {*
+ If, no matter how many steps the Abacus program @{text "aprog"} executes, it
+ may never reach a halt state.
+ *}
+ "\<forall> stp. ((\<lambda> (as, am). as < length aprog)
+ (abc_steps_l ac aprog stp))"
+ and mopup_start: "mop_ss = start_of ly (length aprog)"
+ shows
+ -- {*
+ The the TM composed of TM @{text "tprog"} and the moupup TM may never reach a halt state as well.
+ *}
+ "\<not> (\<exists> stp. (\<lambda> (s, l, r). s = 0)
+ (t_steps tc (tprog @ (tMp n (mop_ss - 1)), 0) stp))"
+ using layout compiled correspond abc_unhalt mopup_start
+ apply(rule_tac abacus_turing_eq_unhalt_case_pre, auto)
+ done
+
+definition abc_list_crsp:: "nat list \<Rightarrow> nat list \<Rightarrow> bool"
+ where
+ "abc_list_crsp xs ys = (\<exists> n. xs = ys @ 0\<^bsup>n\<^esup> \<or> ys = xs @ 0\<^bsup>n\<^esup>)"
+lemma [intro]: "abc_list_crsp (lm @ 0\<^bsup>m\<^esup>) lm"
+apply(auto simp: abc_list_crsp_def)
+done
+
+thm abc_lm_v.simps
+lemma abc_list_crsp_lm_v:
+ "abc_list_crsp lma lmb \<Longrightarrow> abc_lm_v lma n = abc_lm_v lmb n"
+apply(auto simp: abc_list_crsp_def abc_lm_v.simps
+ nth_append exponent_def)
+done
+
+lemma rep_app_cons_iff:
+ "k < n \<Longrightarrow> replicate n a[k:=b] =
+ replicate k a @ b # replicate (n - k - 1) a"
+apply(induct n arbitrary: k, simp)
+apply(simp split:nat.splits)
+done
+
+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)"
+apply(auto simp: abc_list_crsp_def abc_lm_v.simps abc_lm_s.simps)
+apply(simp_all add: list_update_append, auto simp: exponent_def)
+proof -
+ fix na
+ assume h: "m < length lmb + na" " \<not> m < length lmb"
+ hence "m - length lmb < na" by simp
+ hence "replicate na 0[(m- length lmb):= n] =
+ replicate (m - length lmb) 0 @ n #
+ replicate (na - (m - length lmb) - 1) 0"
+ apply(erule_tac rep_app_cons_iff)
+ done
+ thus "\<exists>nb. replicate na 0[m - length lmb := n] =
+ replicate (m - length lmb) 0 @ n # replicate nb 0 \<or>
+ replicate (m - length lmb) 0 @ [n] =
+ replicate na 0[m - length lmb := n] @ replicate nb 0"
+ apply(auto)
+ done
+next
+ fix na
+ assume h: "\<not> m < length lmb + na"
+ show
+ "\<exists>nb. replicate na 0 @ replicate (m - (length lmb + na)) 0 @ [n] =
+ replicate (m - length lmb) 0 @ n # replicate nb 0 \<or>
+ replicate (m - length lmb) 0 @ [n] =
+ replicate na 0 @
+ replicate (m - (length lmb + na)) 0 @ n # replicate nb 0"
+ apply(rule_tac x = 0 in exI, simp, auto)
+ using h
+ apply(simp add: replicate_add[THEN sym])
+ done
+next
+ fix na
+ assume h: "\<not> m < length lma" "m < length lma + na"
+ hence "m - length lma < na" by simp
+ hence
+ "replicate na 0[(m- length lma):= n] = replicate (m - length lma)
+ 0 @ n # replicate (na - (m - length lma) - 1) 0"
+ apply(erule_tac rep_app_cons_iff)
+ done
+ thus "\<exists>nb. replicate (m - length lma) 0 @ [n] =
+ replicate na 0[m - length lma := n] @ replicate nb 0
+ \<or> replicate na 0[m - length lma := n] =
+ replicate (m - length lma) 0 @ n # replicate nb 0"
+ apply(auto)
+ done
+next
+ fix na
+ assume "\<not> m < length lma + na"
+ thus " \<exists>nb. replicate (m - length lma) 0 @ [n] =
+ replicate na 0 @
+ replicate (m - (length lma + na)) 0 @ n # replicate nb 0
+ \<or> replicate na 0 @
+ replicate (m - (length lma + na)) 0 @ [n] =
+ replicate (m - length lma) 0 @ n # replicate nb 0"
+ apply(rule_tac x = 0 in exI, simp, auto)
+ apply(simp add: replicate_add[THEN sym])
+ done
+qed
+
+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(case_tac i, auto simp: abc_step_l.simps
+ abc_list_crsp_lm_s abc_list_crsp_lm_v Let_def
+ split: abc_inst.splits if_splits)
+done
+
+thm abc_step_l.simps
+
+lemma abc_steps_red:
+ "abc_steps_l ac aprog stp = (as, am) \<Longrightarrow>
+ abc_steps_l ac aprog (Suc stp) =
+ abc_step_l (as, am) (abc_fetch as aprog)"
+using abc_steps_ind[of ac aprog stp]
+apply(simp)
+done
+
+lemma abc_list_crsp_steps:
+ "\<lbrakk>abc_steps_l (0, lm @ 0\<^bsup>m\<^esup>) 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"
+apply(induct stp arbitrary: a lm', simp add: abc_steps_l.simps, auto)
+apply(case_tac "abc_steps_l (0, lm @ 0\<^bsup>m\<^esup>) aprog stp",
+ simp add: abc_steps_ind)
+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_steps_l (0, lm @ 0\<^bsup>m\<^esup>) aprog (Suc stp) = (a, lm')"
+ "abc_steps_l (0, lm @ 0\<^bsup>m\<^esup>) aprog stp = (aa, b)"
+ "aprog \<noteq> []"
+ hence g1: "abc_steps_l (0, lm @ 0\<^bsup>m\<^esup>) aprog (Suc stp)
+ = abc_step_l (aa, b) (abc_fetch aa aprog)"
+ apply(rule_tac abc_steps_red, simp)
+ done
+ 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_steps_red, simp)
+ done
+ show "\<exists>lma. abc_steps_l (0, lm) aprog (Suc stp) = (a, lma) \<and>
+ abc_list_crsp lm' lma"
+ using g1 g2 g3 h
+ apply(auto)
+ apply(case_tac "abc_step_l (aa, b) (abc_fetch aa aprog)",
+ case_tac "abc_step_l (aa, lma) (abc_fetch aa aprog)", simp)
+ apply(rule_tac abc_list_crsp_step, auto)
+ done
+qed
+
+text {* Begin: equvilence between steps and t_steps*}
+lemma [simp]: "(case ca of [] \<Rightarrow> Bk | Bk # xs \<Rightarrow> Bk | Oc # xs \<Rightarrow> Oc) =
+ (case ca of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)"
+by(case_tac ca, simp_all, case_tac a, simp, simp)
+
+text {* needed to interpret*}
+
+lemma steps_eq: "length t mod 2 = 0 \<Longrightarrow>
+ t_steps c (t, 0) stp = steps c t stp"
+apply(induct stp)
+apply(simp add: steps.simps t_steps.simps)
+apply(simp add:tstep_red t_steps_ind)
+apply(case_tac "steps c t stp", simp)
+apply(auto simp: t_step.simps tstep.simps)
+done
+
+text{* end: equvilence between steps and t_steps*}
+
+lemma crsp_l_start: "crsp_l ly (0, lm) (Suc 0, Bk # Bk # ires, <lm> @ Bk\<^bsup>rn\<^esup>) ires"
+apply(simp add: crsp_l.simps, auto simp: start_of.simps)
+done
+
+lemma t_ncorrect_app: "\<lbrakk>t_ncorrect t1; t_ncorrect t2\<rbrakk> \<Longrightarrow>
+ t_ncorrect (t1 @ t2)"
+apply(simp add: t_ncorrect.simps, auto)
+done
+
+lemma [simp]:
+ "(length (tm_of aprog) +
+ length (tMp n (start_of ly (length aprog) - Suc 0))) mod 2 = 0"
+apply(subgoal_tac
+ "t_ncorrect (tm_of aprog @ tMp n
+ (start_of ly (length aprog) - Suc 0))")
+apply(simp add: t_ncorrect.simps)
+apply(rule_tac t_ncorrect_app,
+ auto simp: tMp.simps t_ncorrect.simps tshift.simps mp_up_def)
+apply(subgoal_tac
+ "t_ncorrect (tm_of aprog)", simp add: t_ncorrect.simps)
+apply(auto)
+done
+
+lemma [simp]: "takeWhile (\<lambda>a. a = Oc)
+ (replicate rs Oc @ replicate rn Bk) = replicate rs Oc"
+apply(induct rs, auto)
+apply(induct rn, auto)
+done
+
+lemma abacus_turing_eq_halt':
+ "\<lbrakk>ly = layout_of aprog;
+ tprog = tm_of aprog;
+ n < length am;
+ abc_steps_l (0, lm) aprog stp = (as, am);
+ mop_ss = start_of ly (length aprog);
+ as \<ge> length aprog\<rbrakk>
+ \<Longrightarrow> \<exists> stp m l. steps (Suc 0, Bk # Bk # ires, <lm> @ Bk\<^bsup>rn\<^esup>)
+ (tprog @ (tMp n (mop_ss - 1))) stp
+ = (0, Bk\<^bsup>m\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (abc_lm_v am n)\<^esup> @ Bk\<^bsup>l\<^esup>)"
+apply(drule_tac tc = "(Suc 0, Bk # Bk # ires, <lm> @ Bk\<^bsup>rn\<^esup>)" in
+ abacus_turing_eq_halt_case, auto intro: crsp_l_start)
+apply(subgoal_tac
+ "length (tm_of aprog @ tMp n
+ (start_of ly (length aprog) - Suc 0)) mod 2 = 0")
+apply(simp add: steps_eq)
+apply(rule_tac x = stpa in exI,
+ simp add: exponent_def, auto)
+done
+
+
+thm tinres_steps
+lemma list_length: "xs = ys \<Longrightarrow> length xs = length ys"
+by simp
+lemma [elim]: "tinres (Bk\<^bsup>m\<^esup>) b \<Longrightarrow> \<exists>m. b = Bk\<^bsup>m\<^esup>"
+apply(auto simp: tinres_def)
+apply(rule_tac x = "m-n" in exI,
+ auto simp: exponent_def replicate_add[THEN sym])
+apply(case_tac "m < n", auto)
+apply(drule_tac list_length, auto)
+apply(subgoal_tac "\<exists> d. m = d + n", auto simp: replicate_add)
+apply(rule_tac x = "m - n" in exI, simp)
+done
+lemma [intro]: "tinres [Bk] (Bk\<^bsup>k\<^esup>) "
+apply(auto simp: tinres_def exponent_def)
+apply(case_tac k, auto)
+apply(rule_tac x = "Suc 0" in exI, simp)
+done
+
+lemma abacus_turing_eq_halt_pre:
+ "\<lbrakk>ly = layout_of aprog;
+ tprog = tm_of aprog;
+ n < length am;
+ abc_steps_l (0, lm) aprog stp = (as, am);
+ mop_ss = start_of ly (length aprog);
+ as \<ge> length aprog\<rbrakk>
+ \<Longrightarrow> \<exists> stp m l. steps (Suc 0, Bk # Bk # ires, <lm> @ Bk\<^bsup>rn\<^esup>)
+ (tprog @ (tMp n (mop_ss - 1))) stp
+ = (0, Bk\<^bsup>m\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (abc_lm_v am n)\<^esup> @ Bk\<^bsup>l\<^esup>)"
+using abacus_turing_eq_halt'
+apply(simp)
+done
+
+
+text {*
+ Main theorem for the case when the original Abacus program does halt.
+*}
+lemma abacus_turing_eq_halt:
+ assumes layout:
+ "ly = layout_of aprog"
+ -- {* There is an Abacus program @{text "aprog"} with layout @{text "ly"}: *}
+ and compiled: "tprog = tm_of aprog"
+ -- {* The TM compiled from @{text "aprog"} is @{text "tprog"}: *}
+ and halt_state:
+ -- {* @{text "as"} is a program label outside the range of @{text "aprog"}. So
+ if Abacus is in such a state, it is in halt state: *}
+ "as \<ge> length aprog"
+ and abc_exec:
+ -- {* Supposing after @{text "stp"} step of execution, Abacus program @{text "aprog"}
+ reaches such a halt state: *}
+ "abc_steps_l (0, lm) aprog stp = (as, am)"
+ and rs_locate:
+ -- {* @{text "n"} is a memory address in the range of Abacus memory @{text "am"}: *}
+ "n < length am"
+ and mopup_start:
+ -- {* The startling label for mopup mahines, according to the layout and Abacus program
+ should be @{text "mop_ss"}: *}
+ "mop_ss = start_of ly (length aprog)"
+ shows
+ -- {*
+ After @{text "stp"} steps of execution of the TM composed of @{text "tprog"} and the mopup
+ TM @{text "(tMp n (mop_ss - 1))"} will halt and gives rise to a configuration which
+ only hold the content of memory cell @{text "n"}:
+ *}
+ "\<exists> stp m l. steps (Suc 0, Bk # Bk # ires, <lm> @ Bk\<^bsup>rn\<^esup>) (tprog @ (tMp n (mop_ss - 1))) stp
+ = (0, Bk\<^bsup>m\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc (abc_lm_v am n)\<^esup> @ Bk\<^bsup>l\<^esup>)"
+ using layout compiled halt_state abc_exec rs_locate mopup_start
+ by(rule_tac abacus_turing_eq_halt_pre, auto)
+
+lemma abacus_turing_eq_uhalt':
+ "\<lbrakk>ly = layout_of aprog;
+ tprog = tm_of aprog;
+ \<forall> stp. ((\<lambda> (as, am). as < length aprog)
+ (abc_steps_l (0, lm) aprog stp));
+ mop_ss = start_of ly (length aprog)\<rbrakk>
+ \<Longrightarrow> (\<not> (\<exists> stp. isS0 (steps (Suc 0, [Bk, Bk], <lm>)
+ (tprog @ (tMp n (mop_ss - 1))) stp)))"
+apply(drule_tac tc = "(Suc 0, [Bk, Bk], <lm>)" and n = n and ires = "[]" in
+ abacus_turing_eq_unhalt_case, auto intro: crsp_l_start)
+apply(simp add: crsp_l.simps start_of.simps)
+apply(erule_tac x = stp in allE, erule_tac x = stp in allE)
+apply(subgoal_tac
+ "length (tm_of aprog @ tMp n
+ (start_of ly (length aprog) - Suc 0)) mod 2 = 0")
+apply(simp add: steps_eq, auto simp: isS0_def)
+done
+(*
+lemma abacus_turing_eq_uhalt_pre:
+ "\<lbrakk>ly = layout_of aprog;
+ tprog = tm_of aprog;
+ \<forall> stp. ((\<lambda> (as, am). as < length aprog)
+ (abc_steps_l (0, lm) aprog stp));
+ mop_ss = start_of ly (length aprog)\<rbrakk>
+ \<Longrightarrow> (\<not> (\<exists> stp. isS0 (steps (Suc 0, [Bk, Bk], <lm>)
+ (tprog @ (tMp n (mop_ss - 1))) stp)))"
+apply(drule_tac k = 0 and n = n in abacus_turing_eq_uhalt', auto)
+apply(erule_tac x = stp in allE, erule_tac x = stp in allE)
+apply(subgoal_tac "tinres ([Bk]) (Bk\<^bsup>k\<^esup>)")
+apply(case_tac "steps (Suc 0, Bk\<^bsup>k\<^esup>, <lm>)
+ (tm_of aprog @ tMp n (start_of ly (length aprog) - Suc 0)) stp")
+apply(case_tac
+ "steps (Suc 0, [Bk], <lm>)
+ (tm_of aprog @ tMp n (start_of ly (length aprog) - Suc 0)) stp")
+apply(drule_tac tinres_steps, auto simp: isS0_def)
+done
+*)
+text {*
+ Main theorem for the case when the original Abacus program does not halt.
+ *}
+lemma abacus_turing_eq_uhalt:
+ assumes layout:
+ -- {* There is an Abacus program @{text "aprog"} with layout @{text "ly"}: *}
+ "ly = layout_of aprog"
+ and compiled:
+ -- {* The TM compiled from @{text "aprog"} is @{text "tprog"}: *}
+ "tprog = tm_of aprog"
+ and abc_unhalt:
+ -- {*
+ If, no matter how many steps the Abacus program @{text "aprog"} executes, it
+ may never reach a halt state.
+ *}
+ "\<forall> stp. ((\<lambda> (as, am). as < length aprog)
+ (abc_steps_l (0, lm) aprog stp))"
+ and mop_start: "mop_ss = start_of ly (length aprog)"
+ shows
+ -- {*
+ The the TM composed of TM @{text "tprog"} and the moupup TM may never reach a halt state as well.
+ *}
+ "\<not> (\<exists> stp. isS0 (steps (Suc 0, [Bk, Bk], <lm>)
+ (tprog @ (tMp n (mop_ss - 1))) stp))"
+ using abacus_turing_eq_uhalt'
+ layout compiled abc_unhalt mop_start
+ by(auto)
+
+
+end
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/utm/document/root.tex Sat Sep 29 12:38:12 2012 +0000
@@ -0,0 +1,60 @@
+\documentclass[11pt,a4paper]{article}
+\usepackage{isabelle,isabellesym}
+
+% further packages required for unusual symbols (see also
+% isabellesym.sty), use only when needed
+
+%\usepackage{amssymb}
+ %for \<leadsto>, \<box>, \<diamond>, \<sqsupset>, \<mho>, \<Join>,
+ %\<lhd>, \<lesssim>, \<greatersim>, \<lessapprox>, \<greaterapprox>,
+ %\<triangleq>, \<yen>, \<lozenge>
+
+%\usepackage[greek,english]{babel}
+ %option greek for \<euro>
+ %option english (default language) for \<guillemotleft>, \<guillemotright>
+
+%\usepackage[only,bigsqcap]{stmaryrd}
+ %for \<Sqinter>
+
+%\usepackage{eufrak}
+ %for \<AA> ... \<ZZ>, \<aa> ... \<zz> (also included in amssymb)
+
+%\usepackage{textcomp}
+ %for \<onequarter>, \<onehalf>, \<threequarters>, \<degree>, \<cent>,
+ %\<currency>
+
+% this should be the last package used
+\usepackage{pdfsetup}
+
+% urls in roman style, theory text in math-similar italics
+\urlstyle{rm}
+\isabellestyle{it}
+
+% for uniform font size
+%\renewcommand{\isastyle}{\isastyleminor}
+
+
+\begin{document}
+
+\title{utm}
+\author{By xujian}
+\maketitle
+
+\tableofcontents
+
+% sane default for proof documents
+\parindent 0pt\parskip 0.5ex
+
+% generated text of all theories
+\input{session}
+
+% optional bibliography
+%\bibliographystyle{abbrv}
+%\bibliography{root}
+
+\end{document}
+
+%%% Local Variables:
+%%% mode: latex
+%%% TeX-master: t
+%%% End:
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/utm/rec_def.thy Sat Sep 29 12:38:12 2012 +0000
@@ -0,0 +1,87 @@
+theory rec_def
+imports Main
+begin
+
+section {*
+ Recursive functions
+*}
+
+text {*
+ Datatype of recursive operators.
+*}
+
+datatype recf =
+ -- {* The zero function, which always resturns @{text "0"} as result. *}
+ z |
+ -- {* The successor function, which increments its arguments. *}
+ s |
+ -- {*
+ The projection function, where @{text "id i j"} returns the @{text "j"}-th
+ argment out of the @{text "i"} arguments.
+ *}
+ id nat nat |
+ -- {*
+ The compostion operator, where "@{text "Cn n f [g1; g2; \<dots> ;gm]"}
+ computes @{text "f (g1(x1, x2, \<dots>, xn), g2(x1, x2, \<dots>, xn), \<dots> ,
+ gm(x1, x2, \<dots> , xn))"} for input argments @{text "x1, \<dots>, xn"}.
+ *}
+ Cn nat recf "recf list" |
+-- {*
+ The primitive resursive operator, where @{text "Pr n f g"} computes:
+ @{text "Pr n f g (x1, x2, \<dots>, xn-1, 0) = f(x1, \<dots>, xn-1)"}
+ and @{text "Pr n f g (x1, x2, \<dots>, xn-1, k') = g(x1, x2, \<dots>, xn-1, k,
+ Pr n f g (x1, \<dots>, xn-1, k))"}.
+ *}
+ Pr nat recf recf |
+-- {*
+ The minimization operator, where @{text "Mn n f (x1, x2, \<dots> , xn)"}
+ computes the first i such that @{text "f (x1, \<dots>, xn, i) = 0"} and for all
+ @{text "j"}, @{text "f (x1, x2, \<dots>, xn, j) > 0"}.
+ *}
+ Mn nat recf
+
+text {*
+ The semantis of recursive operators is given by an inductively defined
+ relation as follows, where
+ @{text "rec_calc_rel R [x1, x2, \<dots>, xn] r"} means the computation of
+ @{text "R"} over input arguments @{text "[x1, x2, \<dots>, xn"} terminates
+ and gives rise to a result @{text "r"}
+*}
+
+inductive rec_calc_rel :: "recf \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool"
+where
+ calc_z: "rec_calc_rel z [n] 0" |
+ calc_s: "rec_calc_rel s [n] (Suc n)" |
+ calc_id: "\<lbrakk>length args = i; j < i; args!j = r\<rbrakk> \<Longrightarrow> rec_calc_rel (id i j) args r" |
+ calc_cn: "\<lbrakk>length args = n;
+ \<forall> k < length gs. rec_calc_rel (gs ! k) args (rs ! k);
+ length rs = length gs;
+ rec_calc_rel f rs r\<rbrakk>
+ \<Longrightarrow> rec_calc_rel (Cn n f gs) args r" |
+ calc_pr_zero:
+ "\<lbrakk>length args = n;
+ rec_calc_rel f args r0 \<rbrakk>
+ \<Longrightarrow> rec_calc_rel (Pr n f g) (args @ [0]) r0" |
+ calc_pr_ind: "
+ \<lbrakk> length args = n;
+ rec_calc_rel (Pr n f g) (args @ [k]) rk;
+ rec_calc_rel g (args @ [k] @ [rk]) rk'\<rbrakk>
+ \<Longrightarrow> rec_calc_rel (Pr n f g) (args @ [Suc k]) rk'" |
+ calc_mn: "\<lbrakk>length args = n;
+ rec_calc_rel f (args@[r]) 0;
+ \<forall> i < r. (\<exists> ri. rec_calc_rel f (args@[i]) ri \<and> ri \<noteq> 0)\<rbrakk>
+ \<Longrightarrow> rec_calc_rel (Mn n f) args r"
+
+inductive_cases calc_pr_reverse:
+ "rec_calc_rel (Pr n f g) (lm) rSucy"
+
+inductive_cases calc_z_reverse: "rec_calc_rel z lm x"
+
+inductive_cases calc_s_reverse: "rec_calc_rel s lm x"
+
+inductive_cases calc_id_reverse: "rec_calc_rel (id m n) lm x"
+
+inductive_cases calc_cn_reverse: "rec_calc_rel (Cn n f gs) lm x"
+
+inductive_cases calc_mn_reverse:"rec_calc_rel (Mn n f) lm x"
+end
\ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/utm/recursive.thy Sat Sep 29 12:38:12 2012 +0000
@@ -0,0 +1,5024 @@
+theory recursive
+imports Main rec_def abacus
+begin
+
+section {*
+ Compiling from recursive functions to Abacus machines
+ *}
+
+text {*
+ Some auxilliary Abacus machines used to construct the result Abacus machines.
+*}
+
+text {*
+ @{text "get_paras_num recf"} returns the arity of recursive function @{text "recf"}.
+*}
+fun get_paras_num :: "recf \<Rightarrow> nat"
+ where
+ "get_paras_num z = 1" |
+ "get_paras_num s = 1" |
+ "get_paras_num (id m n) = m" |
+ "get_paras_num (Cn n f gs) = n" |
+ "get_paras_num (Pr n f g) = Suc n" |
+ "get_paras_num (Mn n f) = n"
+
+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 empty :: "nat \<Rightarrow> nat \<Rightarrow> abc_prog"
+ where
+ "empty m n = [Dec m 3, Inc n, Goto 0]"
+
+fun abc_inst_shift :: "abc_inst \<Rightarrow> nat \<Rightarrow> abc_inst"
+ where
+ "abc_inst_shift (Inc m) n = Inc m" |
+ "abc_inst_shift (Dec m e) n = Dec m (e + n)" |
+ "abc_inst_shift (Goto m) n = Goto (m + n)"
+
+fun abc_shift :: "abc_inst list \<Rightarrow> nat \<Rightarrow> abc_inst list"
+ where
+ "abc_shift xs n = map (\<lambda> x. abc_inst_shift x n) xs"
+
+fun abc_append :: "abc_inst list \<Rightarrow> abc_inst list \<Rightarrow>
+ abc_inst list" (infixl "[+]" 60)
+ where
+ "abc_append al bl = (let al_len = length al in
+ al @ abc_shift bl al_len)"
+
+text {*
+ The compilation of @{text "z"}-operator.
+*}
+definition rec_ci_z :: "abc_inst list"
+ where
+ "rec_ci_z \<equiv> [Goto 1]"
+
+text {*
+ The compilation of @{text "s"}-operator.
+*}
+definition rec_ci_s :: "abc_inst list"
+ where
+ "rec_ci_s \<equiv> (addition 0 1 2 [+] [Inc 1])"
+
+
+text {*
+ The compilation of @{text "id i j"}-operator
+*}
+
+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 [+] empty (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 [+] empty gpara p [+] cn_merge_gs gs (Suc p))"
+
+
+text {*
+ The compiler of recursive functions, where @{text "rec_ci recf"} return
+ @{text "(ap, arity, fp)"}, where @{text "ap"} is the Abacus program, @{text "arity"} is the
+ arity of the recursive function @{text "recf"},
+@{text "fp"} is the amount of memory which is going to be
+ used by @{text "ap"} for its execution.
+*}
+
+function 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) (f # gs) in
+ let (fprog, fpara, fn) = hd cied_gs 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 (tl cied_gs) pstr [+] mv_boxes 0 qstr n [+]
+ mv_boxes pstr 0 (length gs) [+] fprog [+]
+ empty fpara pstr [+] empty_boxes (length gs) [+]
+ empty 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
+ (empty n p [+] fprog [+] empty 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) )"
+ by pat_completeness auto
+termination
+proof
+term size
+ show "wf (measure size)" by auto
+next
+ fix n f gs x
+ assume "(x::recf) \<in> set (f # gs)"
+ thus "(x, Cn n f gs) \<in> measure size"
+ by(induct gs, auto)
+next
+ fix n f g
+ show "(f, Pr n f g) \<in> measure size" by auto
+next
+ fix n f g x xa y xb ya
+ show "(g, Pr n f g) \<in> measure size" by auto
+next
+ fix n f
+ show "(f, Mn n f) \<in> measure size" by auto
+qed
+
+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] abc_append.simps[simp del]
+ empty.simps[simp del] addition.simps[simp del]
+
+thm rec_calc_rel.induct
+
+declare abc_steps_l.simps[simp del] abc_fetch.simps[simp del]
+ abc_step_l.simps[simp del]
+
+lemma abc_steps_add:
+ "abc_steps_l (as, lm) ap (m + n) =
+ abc_steps_l (abc_steps_l (as, lm) ap m) ap n"
+apply(induct m arbitrary: n as lm, simp add: abc_steps_l.simps)
+proof -
+ fix m n as lm
+ assume ind:
+ "\<And>n as lm. abc_steps_l (as, lm) ap (m + n) =
+ abc_steps_l (abc_steps_l (as, lm) ap m) ap n"
+ show "abc_steps_l (as, lm) ap (Suc m + n) =
+ abc_steps_l (abc_steps_l (as, lm) ap (Suc m)) ap n"
+ apply(insert ind[of as lm "Suc n"], simp)
+ apply(insert ind[of as lm "Suc 0"], simp add: abc_steps_l.simps)
+ apply(case_tac "(abc_steps_l (as, lm) ap m)", simp)
+ apply(simp add: abc_steps_l.simps)
+ apply(case_tac "abc_step_l (a, b) (abc_fetch a ap)",
+ simp add: abc_steps_l.simps)
+ done
+qed
+
+(*lemmas: rec_ci and rec_calc_rel*)
+
+lemma rec_calc_inj_case_z:
+ "\<lbrakk>rec_calc_rel z l x; rec_calc_rel z l y\<rbrakk> \<Longrightarrow> x = y"
+apply(auto elim: calc_z_reverse)
+done
+
+lemma rec_calc_inj_case_s:
+ "\<lbrakk>rec_calc_rel s l x; rec_calc_rel s l y\<rbrakk> \<Longrightarrow> x = y"
+apply(auto elim: calc_s_reverse)
+done
+
+lemma rec_calc_inj_case_id:
+ "\<lbrakk>rec_calc_rel (recf.id nat1 nat2) l x;
+ rec_calc_rel (recf.id nat1 nat2) l y\<rbrakk> \<Longrightarrow> x = y"
+apply(auto elim: calc_id_reverse)
+done
+
+lemma rec_calc_inj_case_mn:
+ assumes ind: "\<And> l x y. \<lbrakk>rec_calc_rel f l x; rec_calc_rel f l y\<rbrakk>
+ \<Longrightarrow> x = y"
+ and h: "rec_calc_rel (Mn n f) l x" "rec_calc_rel (Mn n f) l y"
+ shows "x = y"
+ apply(insert h)
+ apply(elim calc_mn_reverse)
+ apply(case_tac "x > y", simp)
+ apply(erule_tac x = "y" in allE, auto)
+proof -
+ fix v va
+ assume "rec_calc_rel f (l @ [y]) 0"
+ "rec_calc_rel f (l @ [y]) v"
+ "0 < v"
+ thus "False"
+ apply(insert ind[of "l @ [y]" 0 v], simp)
+ done
+next
+ fix v va
+ assume
+ "rec_calc_rel f (l @ [x]) 0"
+ "\<forall>x<y. \<exists>v. rec_calc_rel f (l @ [x]) v \<and> 0 < v" "\<not> y < x"
+ thus "x = y"
+ apply(erule_tac x = "x" in allE)
+ apply(case_tac "x = y", auto)
+ apply(drule_tac y = v in ind, simp, simp)
+ done
+qed
+
+lemma rec_calc_inj_case_pr:
+ assumes f_ind:
+ "\<And>l x y. \<lbrakk>rec_calc_rel f l x; rec_calc_rel f l y\<rbrakk> \<Longrightarrow> x = y"
+ and g_ind:
+ "\<And>x xa y xb ya l xc yb.
+ \<lbrakk>x = rec_ci f; (xa, y) = x; (xb, ya) = y;
+ rec_calc_rel g l xc; rec_calc_rel g l yb\<rbrakk> \<Longrightarrow> xc = yb"
+ and h: "rec_calc_rel (Pr n f g) l x" "rec_calc_rel (Pr n f g) l y"
+ shows "x = y"
+ apply(case_tac "rec_ci f")
+proof -
+ fix a b c
+ assume "rec_ci f = (a, b, c)"
+ hence ng_ind:
+ "\<And> l xc yb. \<lbrakk>rec_calc_rel g l xc; rec_calc_rel g l yb\<rbrakk>
+ \<Longrightarrow> xc = yb"
+ apply(insert g_ind[of "(a, b, c)" "a" "(b, c)" b c], simp)
+ done
+ from h show "x = y"
+ apply(erule_tac calc_pr_reverse, erule_tac calc_pr_reverse)
+ apply(erule f_ind, simp, simp)
+ apply(erule_tac calc_pr_reverse, simp, simp)
+ proof -
+ fix la ya ry laa yaa rya
+ assume k1: "rec_calc_rel g (la @ [ya, ry]) x"
+ "rec_calc_rel g (la @ [ya, rya]) y"
+ and k2: "rec_calc_rel (Pr (length la) f g) (la @ [ya]) ry"
+ "rec_calc_rel (Pr (length la) f g) (la @ [ya]) rya"
+ from k2 have "ry = rya"
+ apply(induct ya arbitrary: ry rya)
+ apply(erule_tac calc_pr_reverse,
+ erule_tac calc_pr_reverse, simp)
+ apply(erule f_ind, simp, simp, simp)
+ apply(erule_tac calc_pr_reverse, simp)
+ apply(erule_tac rSucy = rya in calc_pr_reverse, simp, simp)
+ proof -
+ fix ya ry rya l y ryb laa yb ryc
+ assume ind:
+ "\<And>ry rya. \<lbrakk>rec_calc_rel (Pr (length l) f g) (l @ [y]) ry;
+ rec_calc_rel (Pr (length l) f g) (l @ [y]) rya\<rbrakk> \<Longrightarrow> ry = rya"
+ and j: "rec_calc_rel (Pr (length l) f g) (l @ [y]) ryb"
+ "rec_calc_rel g (l @ [y, ryb]) ry"
+ "rec_calc_rel (Pr (length l) f g) (l @ [y]) ryc"
+ "rec_calc_rel g (l @ [y, ryc]) rya"
+ from j show "ry = rya"
+ apply(insert ind[of ryb ryc], simp)
+ apply(insert ng_ind[of "l @ [y, ryc]" ry rya], simp)
+ done
+ qed
+ from k1 and this show "x = y"
+ apply(simp)
+ apply(insert ng_ind[of "la @ [ya, rya]" x y], simp)
+ done
+ qed
+qed
+
+lemma Suc_nth_part_eq:
+ "\<forall>k<Suc (length list). (a # xs) ! k = (aa # list) ! k
+ \<Longrightarrow> \<forall>k<(length list). (xs) ! k = (list) ! k"
+apply(rule allI, rule impI)
+apply(erule_tac x = "Suc k" in allE, simp)
+done
+
+
+lemma list_eq_intro:
+ "\<lbrakk>length xs = length ys; \<forall> k < length xs. xs ! k = ys ! k\<rbrakk>
+ \<Longrightarrow> xs = ys"
+apply(induct xs arbitrary: ys, simp)
+apply(case_tac ys, simp, simp)
+proof -
+ fix a xs ys aa list
+ assume ind:
+ "\<And>ys. \<lbrakk>length list = length ys; \<forall>k<length ys. xs ! k = ys ! k\<rbrakk>
+ \<Longrightarrow> xs = ys"
+ and h: "length xs = length list"
+ "\<forall>k<Suc (length list). (a # xs) ! k = (aa # list) ! k"
+ from h show "a = aa \<and> xs = list"
+ apply(insert ind[of list], simp)
+ apply(frule Suc_nth_part_eq, simp)
+ apply(erule_tac x = "0" in allE, simp)
+ done
+qed
+
+lemma rec_calc_inj_case_cn:
+ assumes ind:
+ "\<And>x l xa y.
+ \<lbrakk>x = f \<or> x \<in> set gs; rec_calc_rel x l xa; rec_calc_rel x l y\<rbrakk>
+ \<Longrightarrow> xa = y"
+ and h: "rec_calc_rel (Cn n f gs) l x"
+ "rec_calc_rel (Cn n f gs) l y"
+ shows "x = y"
+ apply(insert h, elim calc_cn_reverse)
+ apply(subgoal_tac "rs = rsa")
+ apply(rule_tac x = f and l = rsa and xa = x and y = y in ind,
+ simp, simp, simp)
+ apply(intro list_eq_intro, simp, rule allI, rule impI)
+ apply(erule_tac x = k in allE, rule_tac x = k in allE, simp, simp)
+ apply(rule_tac x = "gs ! k" in ind, simp, simp, simp)
+ done
+
+lemma rec_calc_inj:
+ "\<lbrakk>rec_calc_rel f l x;
+ rec_calc_rel f l y\<rbrakk> \<Longrightarrow> x = y"
+apply(induct f arbitrary: l x y rule: rec_ci.induct)
+apply(simp add: rec_calc_inj_case_z)
+apply(simp add: rec_calc_inj_case_s)
+apply(simp add: rec_calc_inj_case_id, simp)
+apply(erule rec_calc_inj_case_cn,simp, simp)
+apply(erule rec_calc_inj_case_pr, auto)
+apply(erule rec_calc_inj_case_mn, auto)
+done
+
+
+lemma calc_rel_reverse_ind_step_ex:
+ "\<lbrakk>rec_calc_rel (Pr n f g) (lm @ [Suc x]) rs\<rbrakk>
+ \<Longrightarrow> \<exists> rs. rec_calc_rel (Pr n f g) (lm @ [x]) rs"
+apply(erule calc_pr_reverse, simp, simp)
+apply(rule_tac x = rk in exI, simp)
+done
+
+lemma [simp]: "Suc x \<le> y \<Longrightarrow> Suc (y - Suc x) = y - x"
+by arith
+
+lemma calc_pr_para_not_null:
+ "rec_calc_rel (Pr n f g) lm rs \<Longrightarrow> lm \<noteq> []"
+apply(erule calc_pr_reverse, simp, simp)
+done
+
+lemma calc_pr_less_ex:
+ "\<lbrakk>rec_calc_rel (Pr n f g) lm rs; x \<le> last lm\<rbrakk> \<Longrightarrow>
+ \<exists>rs. rec_calc_rel (Pr n f g) (butlast lm @ [last lm - x]) rs"
+apply(subgoal_tac "lm \<noteq> []")
+apply(induct x, rule_tac x = rs in exI, simp, simp, erule exE)
+apply(rule_tac rs = xa in calc_rel_reverse_ind_step_ex, simp)
+apply(simp add: calc_pr_para_not_null)
+done
+
+lemma calc_pr_zero_ex:
+ "rec_calc_rel (Pr n f g) lm rs \<Longrightarrow>
+ \<exists>rs. rec_calc_rel f (butlast lm) rs"
+apply(drule_tac x = "last lm" in calc_pr_less_ex, simp,
+ erule_tac exE, simp)
+apply(erule_tac calc_pr_reverse, simp)
+apply(rule_tac x = rs in exI, simp, simp)
+done
+
+
+lemma abc_steps_ind:
+ "abc_steps_l (as, am) ap (Suc stp) =
+ abc_steps_l (abc_steps_l (as, am) ap stp) ap (Suc 0)"
+apply(insert abc_steps_add[of as am ap stp "Suc 0"], simp)
+done
+
+lemma abc_steps_zero: "abc_steps_l asm ap 0 = asm"
+apply(case_tac asm, simp add: abc_steps_l.simps)
+done
+
+lemma abc_append_nth:
+ "n < length ap + length bp \<Longrightarrow>
+ (ap [+] bp) ! n =
+ (if n < length ap then ap ! n
+ else abc_inst_shift (bp ! (n - length ap)) (length ap))"
+apply(simp add: abc_append.simps nth_append map_nth split: if_splits)
+done
+
+lemma abc_state_keep:
+ "as \<ge> length bp \<Longrightarrow> abc_steps_l (as, lm) bp stp = (as, lm)"
+apply(induct stp, simp add: abc_steps_zero)
+apply(simp add: abc_steps_ind)
+apply(simp add: abc_steps_zero)
+apply(simp add: abc_steps_l.simps abc_fetch.simps abc_step_l.simps)
+done
+
+lemma abc_halt_equal:
+ "\<lbrakk>abc_steps_l (0, lm) bp stpa = (length bp, lm1);
+ abc_steps_l (0, lm) bp stpb = (length bp, lm2)\<rbrakk> \<Longrightarrow> lm1 = lm2"
+apply(case_tac "stpa - stpb > 0")
+apply(insert abc_steps_add[of 0 lm bp stpb "stpa - stpb"], simp)
+apply(insert abc_state_keep[of bp "length bp" lm2 "stpa - stpb"],
+ simp, simp add: abc_steps_zero)
+apply(insert abc_steps_add[of 0 lm bp stpa "stpb - stpa"], simp)
+apply(insert abc_state_keep[of bp "length bp" lm1 "stpb - stpa"],
+ simp)
+done
+
+lemma abc_halt_point_ex:
+ "\<lbrakk>\<exists>stp. abc_steps_l (0, lm) bp stp = (bs, lm');
+ bs = length bp; bp \<noteq> []\<rbrakk>
+ \<Longrightarrow> \<exists> stp. (\<lambda> (s, l). s < bs \<and>
+ (abc_steps_l (s, l) bp (Suc 0)) = (bs, lm'))
+ (abc_steps_l (0, lm) bp stp) "
+apply(erule_tac exE)
+proof -
+ fix stp
+ assume "bs = length bp"
+ "abc_steps_l (0, lm) bp stp = (bs, lm')"
+ "bp \<noteq> []"
+ thus
+ "\<exists>stp. (\<lambda>(s, l). s < bs \<and>
+ abc_steps_l (s, l) bp (Suc 0) = (bs, lm'))
+ (abc_steps_l (0, lm) bp stp)"
+ apply(induct stp, simp add: abc_steps_zero, simp)
+ proof -
+ fix stpa
+ assume ind:
+ "abc_steps_l (0, lm) bp stpa = (length bp, lm')
+ \<Longrightarrow> \<exists>stp. (\<lambda>(s, l). s < length bp \<and> abc_steps_l (s, l) bp
+ (Suc 0) = (length bp, lm')) (abc_steps_l (0, lm) bp stp)"
+ and h: "abc_steps_l (0, lm) bp (Suc stpa) = (length bp, lm')"
+ "abc_steps_l (0, lm) bp stp = (length bp, lm')"
+ "bp \<noteq> []"
+ from h show
+ "\<exists>stp. (\<lambda>(s, l). s < length bp \<and> abc_steps_l (s, l) bp (Suc 0)
+ = (length bp, lm')) (abc_steps_l (0, lm) bp stp)"
+ apply(case_tac "abc_steps_l (0, lm) bp stpa",
+ case_tac "a = length bp")
+ apply(insert ind, simp)
+ apply(subgoal_tac "b = lm'", simp)
+ apply(rule_tac abc_halt_equal, simp, simp)
+ apply(rule_tac x = stpa in exI, simp add: abc_steps_ind)
+ apply(simp add: abc_steps_zero)
+ apply(rule classical, simp add: abc_steps_l.simps
+ abc_fetch.simps abc_step_l.simps)
+ done
+ qed
+qed
+
+
+lemma abc_append_empty_r[simp]: "[] [+] ab = ab"
+apply(simp add: abc_append.simps abc_inst_shift.simps)
+apply(induct ab, simp, simp)
+apply(case_tac a, simp_all add: abc_inst_shift.simps)
+done
+
+lemma abc_append_empty_l[simp]: "ab [+] [] = ab"
+apply(simp add: abc_append.simps abc_inst_shift.simps)
+done
+
+
+lemma abc_append_length[simp]:
+ "length (ap [+] bp) = length ap + length bp"
+apply(simp add: abc_append.simps)
+done
+
+lemma abc_append_commute: "as [+] bs [+] cs = as [+] (bs [+] cs)"
+apply(simp add: abc_append.simps abc_shift.simps abc_inst_shift.simps)
+apply(induct cs, simp, simp)
+apply(case_tac a, auto simp: abc_inst_shift.simps)
+done
+
+lemma abc_halt_point_step[simp]:
+ "\<lbrakk>a < length bp; abc_steps_l (a, b) bp (Suc 0) = (length bp, lm')\<rbrakk>
+ \<Longrightarrow> abc_steps_l (length ap + a, b) (ap [+] bp [+] cp) (Suc 0) =
+ (length ap + length bp, lm')"
+apply(simp add: abc_steps_l.simps abc_fetch.simps abc_append_nth)
+apply(case_tac "bp ! a",
+ auto simp: abc_steps_l.simps abc_step_l.simps)
+done
+
+lemma abc_step_state_in:
+ "\<lbrakk>bs < length bp; abc_steps_l (a, b) bp (Suc 0) = (bs, l)\<rbrakk>
+ \<Longrightarrow> a < length bp"
+apply(simp add: abc_steps_l.simps abc_fetch.simps)
+apply(rule_tac classical,
+ simp add: abc_step_l.simps abc_steps_l.simps)
+done
+
+
+lemma abc_append_state_in_exc:
+ "\<lbrakk>bs < length bp; abc_steps_l (0, lm) bp stpa = (bs, l)\<rbrakk>
+ \<Longrightarrow> abc_steps_l (length ap, lm) (ap [+] bp [+] cp) stpa =
+ (length ap + bs, l)"
+apply(induct stpa arbitrary: bs l, simp add: abc_steps_zero)
+proof -
+ fix stpa bs l
+ assume ind:
+ "\<And>bs l. \<lbrakk>bs < length bp; abc_steps_l (0, lm) bp stpa = (bs, l)\<rbrakk>
+ \<Longrightarrow> abc_steps_l (length ap, lm) (ap [+] bp [+] cp) stpa =
+ (length ap + bs, l)"
+ and h: "bs < length bp"
+ "abc_steps_l (0, lm) bp (Suc stpa) = (bs, l)"
+ from h show
+ "abc_steps_l (length ap, lm) (ap [+] bp [+] cp) (Suc stpa) =
+ (length ap + bs, l)"
+ apply(simp add: abc_steps_ind)
+ apply(case_tac "(abc_steps_l (0, lm) bp stpa)", simp)
+ proof -
+ fix a b
+ assume g: "abc_steps_l (0, lm) bp stpa = (a, b)"
+ "abc_steps_l (a, b) bp (Suc 0) = (bs, l)"
+ from h and g have k1: "a < length bp"
+ apply(simp add: abc_step_state_in)
+ done
+ from h and g and k1 show
+ "abc_steps_l (abc_steps_l (length ap, lm) (ap [+] bp [+] cp) stpa)
+ (ap [+] bp [+] cp) (Suc 0) = (length ap + bs, l)"
+ apply(insert ind[of a b], simp)
+ apply(simp add: abc_steps_l.simps abc_fetch.simps
+ abc_append_nth)
+ apply(case_tac "bp ! a", auto simp:
+ abc_steps_l.simps abc_step_l.simps)
+ done
+ qed
+qed
+
+lemma [simp]: "abc_steps_l (0, am) [] stp = (0, am)"
+apply(induct stp, simp add: abc_steps_zero)
+apply(simp add: abc_steps_ind)
+apply(simp add: abc_steps_zero abc_steps_l.simps
+ abc_fetch.simps abc_step_l.simps)
+done
+
+lemma abc_append_exc1:
+ "\<lbrakk>\<exists> stp. abc_steps_l (0, lm) bp stp = (bs, lm');
+ bs = length bp;
+ as = length ap\<rbrakk>
+ \<Longrightarrow> \<exists> stp. abc_steps_l (as, lm) (ap [+] bp [+] cp) stp
+ = (as + bs, lm')"
+apply(case_tac "bp = []", erule_tac exE, simp,
+ rule_tac x = 0 in exI, simp add: abc_steps_zero)
+apply(frule_tac abc_halt_point_ex, simp, simp,
+ erule_tac exE, erule_tac exE)
+apply(rule_tac x = "stpa + Suc 0" in exI)
+apply(case_tac "(abc_steps_l (0, lm) bp stpa)",
+ simp add: abc_steps_ind)
+apply(subgoal_tac
+ "abc_steps_l (length ap, lm) (ap [+] bp [+] cp) stpa
+ = (length ap + a, b)", simp)
+apply(simp add: abc_steps_zero)
+apply(rule_tac abc_append_state_in_exc, simp, simp)
+done
+
+lemma abc_append_exc3:
+ "\<lbrakk>\<exists> stp. abc_steps_l (0, am) bp stp = (bs, bm); ss = length ap\<rbrakk>
+ \<Longrightarrow> \<exists> stp. abc_steps_l (ss, am) (ap [+] bp) stp = (bs + ss, bm)"
+apply(erule_tac exE)
+proof -
+ fix stp
+ assume h: "abc_steps_l (0, am) bp stp = (bs, bm)" "ss = length ap"
+ thus " \<exists>stp. abc_steps_l (ss, am) (ap [+] bp) stp = (bs + ss, bm)"
+ proof(induct stp arbitrary: bs bm)
+ fix bs bm
+ assume "abc_steps_l (0, am) bp 0 = (bs, bm)"
+ thus "\<exists>stp. abc_steps_l (ss, am) (ap [+] bp) stp = (bs + ss, bm)"
+ apply(rule_tac x = 0 in exI, simp add: abc_steps_l.simps)
+ done
+ next
+ fix stp bs bm
+ assume ind:
+ "\<And>bs bm. \<lbrakk>abc_steps_l (0, am) bp stp = (bs, bm);
+ ss = length ap\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (ss, am) (ap [+] bp) stp = (bs + ss, bm)"
+ and g: "abc_steps_l (0, am) bp (Suc stp) = (bs, bm)"
+ from g show
+ "\<exists>stp. abc_steps_l (ss, am) (ap [+] bp) stp = (bs + ss, bm)"
+ apply(insert abc_steps_add[of 0 am bp stp "Suc 0"], simp)
+ apply(case_tac "(abc_steps_l (0, am) bp stp)", simp)
+ proof -
+ fix a b
+ assume "(bs, bm) = abc_steps_l (a, b) bp (Suc 0)"
+ "abc_steps_l (0, am) bp (Suc stp) =
+ abc_steps_l (a, b) bp (Suc 0)"
+ "abc_steps_l (0, am) bp stp = (a, b)"
+ thus "?thesis"
+ apply(insert ind[of a b], simp add: h, erule_tac exE)
+ apply(rule_tac x = "Suc stp" in exI)
+ apply(simp only: abc_steps_ind, simp add: abc_steps_zero)
+ proof -
+ fix stp
+ assume "(bs, bm) = abc_steps_l (a, b) bp (Suc 0)"
+ thus "abc_steps_l (a + length ap, b) (ap [+] bp) (Suc 0)
+ = (bs + length ap, bm)"
+ apply(simp add: abc_steps_l.simps abc_steps_zero
+ abc_fetch.simps split: if_splits)
+ apply(case_tac "bp ! a",
+ simp_all add: abc_inst_shift.simps abc_append_nth
+ abc_steps_l.simps abc_steps_zero abc_step_l.simps)
+ apply(auto)
+ done
+ qed
+ qed
+ qed
+qed
+
+lemma abc_add_equal:
+ "\<lbrakk>ap \<noteq> [];
+ abc_steps_l (0, am) ap astp = (a, b);
+ a < length ap\<rbrakk>
+ \<Longrightarrow> (abc_steps_l (0, am) (ap @ bp) astp) = (a, b)"
+apply(induct astp arbitrary: a b, simp add: abc_steps_l.simps, simp)
+apply(simp add: abc_steps_ind)
+apply(case_tac "(abc_steps_l (0, am) ap astp)")
+proof -
+ fix astp a b aa ba
+ assume ind:
+ "\<And>a b. \<lbrakk>abc_steps_l (0, am) ap astp = (a, b);
+ a < length ap\<rbrakk> \<Longrightarrow>
+ abc_steps_l (0, am) (ap @ bp) astp = (a, b)"
+ and h: "abc_steps_l (abc_steps_l (0, am) ap astp) ap (Suc 0)
+ = (a, b)"
+ "a < length ap"
+ "abc_steps_l (0, am) ap astp = (aa, ba)"
+ from h show "abc_steps_l (abc_steps_l (0, am) (ap @ bp) astp)
+ (ap @ bp) (Suc 0) = (a, b)"
+ apply(insert ind[of aa ba], simp)
+ apply(subgoal_tac "aa < length ap", simp)
+ apply(simp add: abc_steps_l.simps abc_fetch.simps
+ nth_append abc_steps_zero)
+ apply(rule abc_step_state_in, auto)
+ done
+qed
+
+
+lemma abc_add_exc1:
+ "\<lbrakk>\<exists> astp. abc_steps_l (0, am) ap astp = (as, bm); as = length ap\<rbrakk>
+ \<Longrightarrow> \<exists> stp. abc_steps_l (0, am) (ap @ bp) stp = (as, bm)"
+apply(case_tac "ap = []", simp,
+ rule_tac x = 0 in exI, simp add: abc_steps_zero)
+apply(drule_tac abc_halt_point_ex, simp, simp)
+apply(erule_tac exE, case_tac "(abc_steps_l (0, am) ap astp)", simp)
+apply(rule_tac x = "Suc astp" in exI, simp add: abc_steps_ind, auto)
+apply(frule_tac bp = bp in abc_add_equal, simp, simp, simp)
+apply(simp add: abc_steps_l.simps abc_steps_zero
+ abc_fetch.simps nth_append)
+done
+
+declare abc_shift.simps[simp del]
+
+lemma abc_append_exc2:
+ "\<lbrakk>\<exists> astp. abc_steps_l (0, am) ap astp = (as, bm); as = length ap;
+ \<exists> bstp. abc_steps_l (0, bm) bp bstp = (bs, bm'); bs = length bp;
+ cs = as + bs; bp \<noteq> []\<rbrakk>
+ \<Longrightarrow> \<exists> stp. abc_steps_l (0, am) (ap [+] bp) stp = (cs, bm')"
+apply(insert abc_append_exc1[of bm bp bs bm' as ap "[]"], simp)
+apply(drule_tac bp = "abc_shift bp (length ap)" in abc_add_exc1, simp)
+apply(subgoal_tac "ap @ abc_shift bp (length ap) = ap [+] bp",
+ simp, auto)
+apply(rule_tac x = "stpa + stp" in exI, simp add: abc_steps_add)
+apply(simp add: abc_append.simps)
+done
+lemma exp_length[simp]: "length (a\<^bsup>b\<^esup>) = b"
+by(simp add: exponent_def)
+lemma exponent_add_iff: "a\<^bsup>b\<^esup> @ a\<^bsup>c \<^esup>@ xs = a\<^bsup>b + c \<^esup>@ xs"
+apply(auto simp: exponent_def replicate_add)
+done
+lemma exponent_cons_iff: "a # a\<^bsup>c \<^esup>@ xs = a\<^bsup>Suc c \<^esup>@ xs"
+apply(auto simp: exponent_def replicate_add)
+done
+
+
+lemma [simp]: "length lm = n \<Longrightarrow>
+ abc_steps_l (Suc 0, lm @ Suc x # 0 # suf_lm)
+ [Inc n, Dec (Suc n) 3, Goto (Suc 0)] (Suc (Suc 0))
+ = (3, lm @ Suc x # 0 # suf_lm)"
+apply(simp add: abc_steps_l.simps abc_fetch.simps
+ abc_step_l.simps abc_lm_v.simps abc_lm_s.simps
+ nth_append list_update_append)
+done
+
+lemma [simp]:
+ "length lm = n \<Longrightarrow>
+ abc_steps_l (Suc 0, lm @ Suc x # Suc y # suf_lm)
+ [Inc n, Dec (Suc n) 3, Goto (Suc 0)] (Suc (Suc 0))
+ = (Suc 0, lm @ Suc x # y # suf_lm)"
+apply(simp add: abc_steps_l.simps abc_fetch.simps
+ abc_step_l.simps abc_lm_v.simps abc_lm_s.simps
+ nth_append list_update_append)
+done
+
+lemma pr_cycle_part_middle_inv:
+ "\<lbrakk>length lm = n\<rbrakk> \<Longrightarrow>
+ \<exists> stp. abc_steps_l (0, lm @ x # y # suf_lm)
+ [Inc n, Dec (Suc n) 3, Goto (Suc 0)] stp
+ = (3, lm @ Suc x # 0 # suf_lm)"
+proof -
+ assume h: "length lm = n"
+ hence k1: "\<exists> stp. abc_steps_l (0, lm @ x # y # suf_lm)
+ [Inc n, Dec (Suc n) 3, Goto (Suc 0)] stp
+ = (Suc 0, lm @ Suc x # y # suf_lm)"
+ apply(rule_tac x = "Suc 0" in exI)
+ apply(simp add: abc_steps_l.simps abc_step_l.simps
+ abc_lm_v.simps abc_lm_s.simps nth_append
+ list_update_append abc_fetch.simps)
+ done
+ from h have k2:
+ "\<exists> stp. abc_steps_l (Suc 0, lm @ Suc x # y # suf_lm)
+ [Inc n, Dec (Suc n) 3, Goto (Suc 0)] stp
+ = (3, lm @ Suc x # 0 # suf_lm)"
+ apply(induct y)
+ apply(rule_tac x = "Suc (Suc 0)" in exI, simp, simp,
+ erule_tac exE)
+ apply(rule_tac x = "Suc (Suc 0) + stp" in exI,
+ simp only: abc_steps_add, simp)
+ done
+ from k1 and k2 show
+ "\<exists> stp. abc_steps_l (0, lm @ x # y # suf_lm)
+ [Inc n, Dec (Suc n) 3, Goto (Suc 0)] stp
+ = (3, lm @ Suc x # 0 # suf_lm)"
+ apply(erule_tac exE, erule_tac exE)
+ apply(rule_tac x = "stp + stpa" in exI, simp add: abc_steps_add)
+ done
+qed
+
+lemma [simp]:
+ "length lm = Suc n \<Longrightarrow>
+ (abc_steps_l (length ap, lm @ x # Suc y # suf_lm)
+ (ap @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length ap)])
+ (Suc (Suc (Suc 0))))
+ = (length ap, lm @ Suc x # y # suf_lm)"
+apply(simp add: abc_steps_l.simps abc_fetch.simps abc_step_l.simps
+ abc_lm_v.simps list_update_append nth_append abc_lm_s.simps)
+done
+
+lemma switch_para_inv:
+ assumes bp_def:"bp = ap @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto ss]"
+ and h: "rec_ci (Pr n f g) = (aprog, rs_pos, a_md)"
+ "ss = length ap"
+ "length lm = Suc n"
+ shows " \<exists>stp. abc_steps_l (ss, lm @ x # y # suf_lm) bp stp =
+ (0, lm @ (x + y) # 0 # suf_lm)"
+apply(induct y arbitrary: x)
+apply(rule_tac x = "Suc 0" in exI,
+ simp add: bp_def empty.simps abc_steps_l.simps
+ abc_fetch.simps h abc_step_l.simps
+ abc_lm_v.simps list_update_append nth_append
+ abc_lm_s.simps)
+proof -
+ fix y x
+ assume ind:
+ "\<And>x. \<exists>stp. abc_steps_l (ss, lm @ x # y # suf_lm) bp stp =
+ (0, lm @ (x + y) # 0 # suf_lm)"
+ show "\<exists>stp. abc_steps_l (ss, lm @ x # Suc y # suf_lm) bp stp =
+ (0, lm @ (x + Suc y) # 0 # suf_lm)"
+ apply(insert ind[of "Suc x"], erule_tac exE)
+ apply(rule_tac x = "Suc (Suc (Suc 0)) + stp" in exI,
+ simp only: abc_steps_add bp_def h)
+ apply(simp add: h)
+ done
+qed
+
+lemma [simp]:
+ "length lm = rs_pos \<and> Suc (Suc rs_pos) < a_md \<and> 0 < rs_pos \<Longrightarrow>
+ a_md - Suc 0 < Suc (Suc (Suc (a_md + length suf_lm -
+ Suc (Suc (Suc 0)))))"
+apply(arith)
+done
+
+lemma [simp]:
+ "Suc (Suc rs_pos) < a_md \<and> 0 < rs_pos \<Longrightarrow>
+ \<not> a_md - Suc 0 < rs_pos - Suc 0"
+apply(arith)
+done
+
+lemma [simp]:
+ "Suc (Suc rs_pos) < a_md \<and> 0 < rs_pos \<Longrightarrow>
+ \<not> a_md - rs_pos < Suc (Suc (a_md - Suc (Suc rs_pos)))"
+apply(arith)
+done
+
+lemma butlast_append_last: "lm \<noteq> [] \<Longrightarrow> lm = butlast lm @ [last lm]"
+apply(auto)
+done
+
+lemma [simp]: "rec_ci (Pr n f g) = (aprog, rs_pos, a_md)
+ \<Longrightarrow> (Suc (Suc rs_pos)) < a_md"
+apply(simp add: rec_ci.simps)
+apply(case_tac "rec_ci f", simp)
+apply(case_tac "rec_ci g", simp)
+apply(arith)
+done
+
+(*
+lemma pr_para_ge_suc0: "rec_calc_rel (Pr n f g) lm xs \<Longrightarrow> 0 < n"
+apply(erule calc_pr_reverse, simp, simp)
+done
+*)
+
+lemma ci_pr_para_eq: "rec_ci (Pr n f g) = (aprog, rs_pos, a_md)
+ \<Longrightarrow> rs_pos = Suc n"
+apply(simp add: rec_ci.simps)
+apply(case_tac "rec_ci g", case_tac "rec_ci f", simp)
+done
+
+lemma [intro]:
+ "\<lbrakk>rec_ci z = (aprog, rs_pos, a_md); rec_calc_rel z lm xs\<rbrakk>
+ \<Longrightarrow> length lm = rs_pos"
+apply(simp add: rec_ci.simps rec_ci_z_def)
+apply(erule_tac calc_z_reverse, simp)
+done
+
+lemma [intro]:
+ "\<lbrakk>rec_ci s = (aprog, rs_pos, a_md); rec_calc_rel s lm xs\<rbrakk>
+ \<Longrightarrow> length lm = rs_pos"
+apply(simp add: rec_ci.simps rec_ci_s_def)
+apply(erule_tac calc_s_reverse, simp)
+done
+
+lemma [intro]:
+ "\<lbrakk>rec_ci (recf.id nat1 nat2) = (aprog, rs_pos, a_md);
+ rec_calc_rel (recf.id nat1 nat2) lm xs\<rbrakk> \<Longrightarrow> length lm = rs_pos"
+apply(simp add: rec_ci.simps rec_ci_id.simps)
+apply(erule_tac calc_id_reverse, simp)
+done
+
+lemma [intro]:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Cn n f gs) lm xs\<rbrakk> \<Longrightarrow> length lm = rs_pos"
+apply(erule_tac calc_cn_reverse, simp)
+apply(simp add: rec_ci.simps)
+apply(case_tac "rec_ci f", simp)
+done
+
+lemma [intro]:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Pr n f g) lm xs\<rbrakk> \<Longrightarrow> length lm = rs_pos"
+apply(erule_tac calc_pr_reverse, simp)
+apply(drule_tac ci_pr_para_eq, simp, simp)
+apply(drule_tac ci_pr_para_eq, simp)
+done
+
+lemma [intro]:
+ "\<lbrakk>rec_ci (Mn n f) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Mn n f) lm xs\<rbrakk> \<Longrightarrow> length lm = rs_pos"
+apply(erule_tac calc_mn_reverse)
+apply(simp add: rec_ci.simps)
+apply(case_tac "rec_ci f", simp)
+done
+
+lemma para_pattern:
+ "\<lbrakk>rec_ci f = (aprog, rs_pos, a_md); rec_calc_rel f lm xs\<rbrakk>
+ \<Longrightarrow> length lm = rs_pos"
+apply(case_tac f, auto)
+done
+
+lemma ci_pr_g_paras:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci g = (a, aa, ba);
+ rec_calc_rel (Pr n f g) (lm @ [x]) rs; x > 0\<rbrakk> \<Longrightarrow>
+ aa = Suc rs_pos "
+apply(erule calc_pr_reverse, simp)
+apply(subgoal_tac "length (args @ [k, rk]) = aa", simp)
+apply(subgoal_tac "rs_pos = Suc n", simp)
+apply(simp add: ci_pr_para_eq)
+apply(erule para_pattern, simp)
+done
+
+lemma ci_pr_g_md_less:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci g = (a, aa, ba)\<rbrakk> \<Longrightarrow> ba < a_md"
+apply(simp add: rec_ci.simps)
+apply(case_tac "rec_ci f", auto)
+done
+
+lemma [intro]: "rec_ci z = (ap, rp, ad) \<Longrightarrow> rp < ad"
+ by(simp add: rec_ci.simps)
+
+lemma [intro]: "rec_ci s = (ap, rp, ad) \<Longrightarrow> rp < ad"
+ by(simp add: rec_ci.simps)
+
+lemma [intro]: "rec_ci (recf.id nat1 nat2) = (ap, rp, ad) \<Longrightarrow> rp < ad"
+ by(simp add: rec_ci.simps)
+
+lemma [intro]: "rec_ci (Cn n f gs) = (ap, rp, ad) \<Longrightarrow> rp < ad"
+apply(simp add: rec_ci.simps)
+apply(case_tac "rec_ci f", simp)
+done
+
+lemma [intro]: "rec_ci (Pr n f g) = (ap, rp, ad) \<Longrightarrow> rp < ad"
+apply(simp add: rec_ci.simps)
+by(case_tac "rec_ci f", case_tac "rec_ci g", auto)
+
+lemma [intro]: "rec_ci (Mn n f) = (ap, rp, ad) \<Longrightarrow> rp < ad"
+apply(simp add: rec_ci.simps)
+apply(case_tac "rec_ci f", simp)
+apply(arith)
+done
+
+lemma ci_ad_ge_paras: "rec_ci f = (ap, rp, ad) \<Longrightarrow> ad > rp"
+apply(case_tac f, auto)
+done
+
+lemma [elim]: "\<lbrakk>a [+] b = []; a \<noteq> [] \<or> b \<noteq> []\<rbrakk> \<Longrightarrow> RR"
+apply(auto simp: abc_append.simps abc_shift.simps)
+done
+
+lemma [intro]: "rec_ci z = ([], aa, ba) \<Longrightarrow> False"
+by(simp add: rec_ci.simps rec_ci_z_def)
+
+lemma [intro]: "rec_ci s = ([], aa, ba) \<Longrightarrow> False"
+by(auto simp: rec_ci.simps rec_ci_s_def addition.simps)
+
+lemma [intro]: "rec_ci (id m n) = ([], aa, ba) \<Longrightarrow> False"
+by(auto simp: rec_ci.simps rec_ci_id.simps addition.simps)
+
+lemma [intro]: "rec_ci (Cn n f gs) = ([], aa, ba) \<Longrightarrow> False"
+apply(case_tac "rec_ci f", auto simp: rec_ci.simps abc_append.simps)
+apply(simp add: abc_shift.simps empty.simps)
+done
+
+lemma [intro]: "rec_ci (Pr n f g) = ([], aa, ba) \<Longrightarrow> False"
+apply(simp add: rec_ci.simps)
+apply(case_tac "rec_ci f", case_tac "rec_ci g")
+by(auto)
+
+lemma [intro]: "rec_ci (Mn n f) = ([], aa, ba) \<Longrightarrow> False"
+apply(case_tac "rec_ci f", auto simp: rec_ci.simps)
+done
+
+lemma rec_ci_not_null: "rec_ci g = (a, aa, ba) \<Longrightarrow> a \<noteq> []"
+by(case_tac g, auto)
+
+lemma calc_pr_g_def:
+ "\<lbrakk>rec_calc_rel (Pr rs_pos f g) (lm @ [Suc x]) rsa;
+ rec_calc_rel (Pr rs_pos f g) (lm @ [x]) rsxa\<rbrakk>
+ \<Longrightarrow> rec_calc_rel g (lm @ [x, rsxa]) rsa"
+apply(erule_tac calc_pr_reverse, simp, simp)
+apply(subgoal_tac "rsxa = rk", simp)
+apply(erule_tac rec_calc_inj, auto)
+done
+
+lemma ci_pr_md_def:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci g = (a, aa, ba); rec_ci f = (ab, ac, bc)\<rbrakk>
+ \<Longrightarrow> a_md = Suc (max (n + 3) (max bc ba))"
+by(simp add: rec_ci.simps)
+
+lemma ci_pr_f_paras:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Pr n f g) lm rs;
+ rec_ci f = (ab, ac, bc)\<rbrakk> \<Longrightarrow> ac = rs_pos - Suc 0"
+apply(subgoal_tac "\<exists>rs. rec_calc_rel f (butlast lm) rs",
+ erule_tac exE)
+apply(drule_tac f = f and lm = "butlast lm" in para_pattern,
+ simp, simp)
+apply(drule_tac para_pattern, simp)
+apply(subgoal_tac "lm \<noteq> []", simp)
+apply(erule_tac calc_pr_reverse, simp, simp)
+apply(erule calc_pr_zero_ex)
+done
+
+lemma ci_pr_md_ge_f: "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci f = (ab, ac, bc)\<rbrakk> \<Longrightarrow> Suc bc \<le> a_md"
+apply(case_tac "rec_ci g")
+apply(simp add: rec_ci.simps, auto)
+done
+
+lemma ci_pr_md_ge_g: "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci g = (ab, ac, bc)\<rbrakk> \<Longrightarrow> bc < a_md"
+apply(case_tac "rec_ci f")
+apply(simp add: rec_ci.simps, auto)
+done
+
+lemma rec_calc_rel_def0:
+ "\<lbrakk>rec_calc_rel (Pr n f g) lm rs; rec_calc_rel f (butlast lm) rsa\<rbrakk>
+ \<Longrightarrow> rec_calc_rel (Pr n f g) (butlast lm @ [0]) rsa"
+ apply(rule_tac calc_pr_zero, simp)
+apply(erule_tac calc_pr_reverse, simp, simp, simp)
+done
+
+lemma [simp]: "length (empty m n) = 3"
+by (auto simp: empty.simps)
+(*
+lemma
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Pr n f g) lm rs;
+ rec_ci g = (a, aa, ba);
+ rec_ci f = (ab, ac, bc)\<rbrakk>
+\<Longrightarrow> \<exists>ap bp cp. aprog = ap [+] bp [+] cp \<and> length ap = 3 + length ab \<and> bp = recursive.empty (n - Suc 0) n 3"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "recursive.empty (n - Suc 0) (max (Suc (Suc n)) (max bc ba)) 3 [+] ab" in exI, simp)
+apply(rule_tac x = "([Dec (max (Suc (Suc n)) (max bc ba)) (length a + 7)] [+] a [+]
+ [Inc (n - Suc 0), Dec n 3, Goto (Suc 0)]) @ [Dec (Suc n) 0, Inc n, Goto (length a + 4)]" in exI, simp)
+apply(auto simp: abc_append_commute)
+done
+
+lemma "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci g = (a, aa, ba); rec_ci f = (ab, ac, bc)\<rbrakk>
+ \<Longrightarrow> \<exists>ap bp cp. aprog = ap [+] bp [+] cp \<and> length ap = 3 \<and> bp = ab"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "recursive.empty (n - Suc 0) (max (Suc (Suc n)) (max bc ba)) 3" in exI, simp)
+apply(rule_tac x = "recursive.empty (n - Suc 0) n 3 [+]
+ ([Dec (max (Suc (Suc n)) (max bc ba)) (length a + 7)] [+] a
+ [+] [Inc (n - Suc 0), Dec n 3, Goto (Suc 0)]) @ [Dec (Suc n) 0, Inc n, Goto (length a + 4)]" in exI, auto)
+apply(simp add: abc_append_commute)
+done
+*)
+
+lemma [simp]: "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md); rec_calc_rel (Pr n f g) lm rs\<rbrakk>
+ \<Longrightarrow> rs_pos = Suc n"
+apply(simp add: ci_pr_para_eq)
+done
+
+
+lemma [simp]: "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md); rec_calc_rel (Pr n f g) lm rs\<rbrakk>
+ \<Longrightarrow> length lm = Suc n"
+apply(subgoal_tac "rs_pos = Suc n", rule_tac para_pattern, simp, simp)
+apply(case_tac "rec_ci f", case_tac "rec_ci g", simp add: rec_ci.simps)
+done
+
+lemma [simp]: "rec_ci (Pr n f g) = (a, rs_pos, a_md) \<Longrightarrow> Suc (Suc n) < a_md"
+apply(case_tac "rec_ci f", case_tac "rec_ci g", simp add: rec_ci.simps)
+apply arith
+done
+
+lemma [simp]: "rec_ci (Pr n f g) = (aprog, rs_pos, a_md) \<Longrightarrow> 0 < rs_pos"
+apply(case_tac "rec_ci f", case_tac "rec_ci g")
+apply(simp add: rec_ci.simps)
+done
+
+lemma [simp]: "Suc (Suc rs_pos) < a_md \<Longrightarrow>
+ butlast lm @ (last lm - xa) # (rsa::nat) # 0 # 0\<^bsup>a_md - Suc (Suc (Suc rs_pos))\<^esup> @ xa # suf_lm =
+ butlast lm @ (last lm - xa) # rsa # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm"
+apply(simp add: exp_ind_def[THEN sym])
+done
+
+lemma pr_cycle_part_ind:
+ assumes g_ind:
+ "\<And>lm rs suf_lm. rec_calc_rel g lm rs \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>ba - aa\<^esup> @ suf_lm) a stp =
+ (length a, lm @ rs # 0\<^bsup>ba - Suc aa\<^esup> @ suf_lm)"
+ and ap_def:
+ "ap = ([Dec (a_md - Suc 0) (length a + 7)] [+]
+ (a [+] [Inc (rs_pos - Suc 0), Dec rs_pos 3, Goto (Suc 0)])) @
+ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length a + 4)]"
+ and h: "rec_ci (Pr n f g) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Pr n f g)
+ (butlast lm @ [last lm - Suc xa]) rsxa"
+ "Suc xa \<le> last lm"
+ "rec_ci g = (a, aa, ba)"
+ "rec_calc_rel (Pr n f g) (butlast lm @ [last lm - xa]) rsa"
+ "lm \<noteq> []"
+ shows
+ "\<exists>stp. abc_steps_l
+ (0, butlast lm @ (last lm - Suc xa) # rsxa #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ Suc xa # suf_lm) ap stp =
+ (0, butlast lm @ (last lm - xa) # rsa
+ # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm)"
+proof -
+ have k1: "\<exists>stp. abc_steps_l (0, butlast lm @ (last lm - Suc xa) #
+ rsxa # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ Suc xa # suf_lm) ap stp =
+ (length a + 4, butlast lm @ (last lm - xa) # 0 # rsa #
+ 0\<^bsup>a_md - Suc (Suc (Suc rs_pos))\<^esup> @ xa # suf_lm)"
+ apply(simp add: ap_def, rule_tac abc_add_exc1)
+ apply(rule_tac as = "Suc 0" and
+ bm = "butlast lm @ (last lm - Suc xa) #
+ rsxa # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm" in abc_append_exc2,
+ auto)
+ proof -
+ show
+ "\<exists>astp. abc_steps_l (0, butlast lm @ (last lm - Suc xa) # rsxa
+ # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ Suc xa # suf_lm)
+ [Dec (a_md - Suc 0)(length a + 7)] astp =
+ (Suc 0, butlast lm @ (last lm - Suc xa) #
+ rsxa # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm)"
+ apply(rule_tac x = "Suc 0" in exI,
+ simp add: abc_steps_l.simps abc_step_l.simps
+ abc_fetch.simps)
+ apply(subgoal_tac "length lm = Suc n \<and> rs_pos = Suc n \<and>
+ a_md > Suc (Suc rs_pos)")
+ apply(simp add: abc_lm_v.simps nth_append abc_lm_s.simps)
+ apply(insert nth_append[of
+ "(last lm - Suc xa) # rsxa # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup>"
+ "Suc xa # suf_lm" "(a_md - rs_pos)"], simp)
+ apply(simp add: list_update_append del: list_update.simps)
+ apply(insert list_update_append[of "(last lm - Suc xa) # rsxa #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup>"
+ "Suc xa # suf_lm" "a_md - rs_pos" "xa"], simp)
+ apply(case_tac a_md, simp, simp)
+ apply(insert h, simp)
+ apply(insert para_pattern[of "Pr n f g" aprog rs_pos a_md
+ "(butlast lm @ [last lm - Suc xa])" rsxa], simp)
+ done
+ next
+ show "\<exists>bstp. abc_steps_l (0, butlast lm @ (last lm - Suc xa) #
+ rsxa # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm) (a [+]
+ [Inc (rs_pos - Suc 0), Dec rs_pos 3, Goto (Suc 0)]) bstp =
+ (3 + length a, butlast lm @ (last lm - xa) # 0 # rsa #
+ 0\<^bsup>a_md - Suc (Suc (Suc rs_pos))\<^esup> @ xa # suf_lm)"
+ apply(rule_tac as = "length a" and
+ bm = "butlast lm @ (last lm - Suc xa) # rsxa # rsa #
+ 0\<^bsup>a_md - Suc (Suc (Suc rs_pos))\<^esup> @ xa # suf_lm"
+ in abc_append_exc2, simp_all)
+ proof -
+ from h have j1: "aa = Suc rs_pos \<and> a_md > ba \<and> ba > Suc rs_pos"
+ apply(insert h)
+ apply(insert ci_pr_g_paras[of n f g aprog rs_pos
+ a_md a aa ba "butlast lm" "last lm - xa" rsa], simp)
+ apply(drule_tac ci_pr_md_ge_g, auto)
+ apply(erule_tac ci_ad_ge_paras)
+ done
+ from h have j2: "rec_calc_rel g (butlast lm @
+ [last lm - Suc xa, rsxa]) rsa"
+ apply(rule_tac calc_pr_g_def, simp, simp)
+ done
+ from j1 and j2 show
+ "\<exists>astp. abc_steps_l (0, butlast lm @ (last lm - Suc xa) #
+ rsxa # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm) a astp =
+ (length a, butlast lm @ (last lm - Suc xa) # rsxa # rsa
+ # 0\<^bsup>a_md - Suc (Suc (Suc rs_pos))\<^esup> @ xa # suf_lm)"
+ apply(insert g_ind[of
+ "butlast lm @ (last lm - Suc xa) # [rsxa]" rsa
+ "0\<^bsup>a_md - ba - Suc 0 \<^esup> @ xa # suf_lm"], simp, auto)
+ apply(simp add: exponent_add_iff)
+ apply(rule_tac x = stp in exI, simp add: numeral_3_eq_3)
+ done
+ next
+ from h have j3: "length lm = rs_pos \<and> rs_pos > 0"
+ apply(rule_tac conjI)
+ apply(drule_tac lm = "(butlast lm @ [last lm - Suc xa])"
+ and xs = rsxa in para_pattern, simp, simp, simp)
+ done
+ from h have j4: "Suc (last lm - Suc xa) = last lm - xa"
+ apply(case_tac "last lm", simp, simp)
+ done
+ from j3 and j4 show
+ "\<exists>bstp. abc_steps_l (0, butlast lm @ (last lm - Suc xa) # rsxa #
+ rsa # 0\<^bsup>a_md - Suc (Suc (Suc rs_pos))\<^esup> @ xa # suf_lm)
+ [Inc (rs_pos - Suc 0), Dec rs_pos 3, Goto (Suc 0)] bstp =
+ (3, butlast lm @ (last lm - xa) # 0 # rsa #
+ 0\<^bsup>a_md - Suc (Suc (Suc rs_pos))\<^esup> @ xa # suf_lm)"
+ apply(insert pr_cycle_part_middle_inv[of "butlast lm"
+ "rs_pos - Suc 0" "(last lm - Suc xa)" rsxa
+ "rsa # 0\<^bsup>a_md - Suc (Suc (Suc rs_pos))\<^esup> @ xa # suf_lm"], simp)
+ done
+ qed
+ qed
+ from h have k2:
+ "\<exists>stp. abc_steps_l (length a + 4, butlast lm @ (last lm - xa) # 0
+ # rsa # 0\<^bsup>a_md - Suc (Suc (Suc rs_pos))\<^esup> @ xa # suf_lm) ap stp =
+ (0, butlast lm @ (last lm - xa) # rsa # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm)"
+ apply(insert switch_para_inv[of ap
+ "([Dec (a_md - Suc 0) (length a + 7)] [+]
+ (a [+] [Inc (rs_pos - Suc 0), Dec rs_pos 3, Goto (Suc 0)]))"
+ n "length a + 4" f g aprog rs_pos a_md
+ "butlast lm @ [last lm - xa]" 0 rsa
+ "0\<^bsup>a_md - Suc (Suc (Suc rs_pos))\<^esup> @ xa # suf_lm"])
+ apply(simp add: h ap_def)
+ apply(subgoal_tac "length lm = Suc n \<and> Suc (Suc rs_pos) < a_md",
+ simp)
+ apply(insert h, simp)
+ apply(frule_tac lm = "(butlast lm @ [last lm - Suc xa])"
+ and xs = rsxa in para_pattern, simp, simp)
+ done
+ from k1 and k2 show "?thesis"
+ apply(auto)
+ apply(rule_tac x = "stp + stpa" in exI, simp add: abc_steps_add)
+ done
+qed
+
+lemma ci_pr_ex1:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci g = (a, aa, ba);
+ rec_ci f = (ab, ac, bc)\<rbrakk>
+\<Longrightarrow> \<exists>ap bp. length ap = 6 + length ab \<and>
+ aprog = ap [+] bp \<and>
+ bp = ([Dec (a_md - Suc 0) (length a + 7)] [+] (a [+]
+ [Inc (rs_pos - Suc 0), Dec rs_pos 3, Goto (Suc 0)])) @
+ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length a + 4)]"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "recursive.empty n (max (Suc (Suc (Suc n)))
+ (max bc ba)) [+] ab [+] recursive.empty n (Suc n)" in exI,
+ simp)
+apply(auto simp add: abc_append_commute add3_Suc)
+done
+
+lemma pr_cycle_part:
+ "\<lbrakk>\<And>lm rs suf_lm. rec_calc_rel g lm rs \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>ba - aa\<^esup> @ suf_lm) a stp =
+ (length a, lm @ rs # 0\<^bsup>ba - Suc aa\<^esup> @ suf_lm);
+ rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Pr n f g) lm rs;
+ rec_ci g = (a, aa, ba);
+ rec_calc_rel (Pr n f g) (butlast lm @ [last lm - x]) rsx;
+ rec_ci f = (ab, ac, bc);
+ lm \<noteq> [];
+ x \<le> last lm\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (6 + length ab, butlast lm @ (last lm - x) #
+ rsx # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ x # suf_lm) aprog stp =
+ (6 + length ab, butlast lm @ last lm # rs #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ 0 # suf_lm)"
+proof -
+ assume g_ind:
+ "\<And>lm rs suf_lm. rec_calc_rel g lm rs \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>ba - aa\<^esup> @ suf_lm) a stp =
+ (length a, lm @ rs # 0\<^bsup>ba - Suc aa\<^esup> @ suf_lm)"
+ and h: "rec_ci (Pr n f g) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Pr n f g) lm rs"
+ "rec_ci g = (a, aa, ba)"
+ "rec_calc_rel (Pr n f g) (butlast lm @ [last lm - x]) rsx"
+ "lm \<noteq> []"
+ "x \<le> last lm"
+ "rec_ci f = (ab, ac, bc)"
+ from h show
+ "\<exists>stp. abc_steps_l (6 + length ab, butlast lm @ (last lm - x) #
+ rsx # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ x # suf_lm) aprog stp =
+ (6 + length ab, butlast lm @ last lm # rs #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ 0 # suf_lm)"
+ proof(induct x arbitrary: rsx, simp_all)
+ fix rsxa
+ assume "rec_calc_rel (Pr n f g) lm rsxa"
+ "rec_calc_rel (Pr n f g) lm rs"
+ from h and this have "rs = rsxa"
+ apply(subgoal_tac "lm \<noteq> [] \<and> rs_pos = Suc n", simp)
+ apply(rule_tac rec_calc_inj, simp, simp)
+ apply(simp)
+ done
+ thus "\<exists>stp. abc_steps_l (6 + length ab, butlast lm @ last lm #
+ rsxa # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ 0 # suf_lm) aprog stp =
+ (6 + length ab, butlast lm @ last lm # rs #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ 0 # suf_lm)"
+ by(rule_tac x = 0 in exI, simp add: abc_steps_l.simps)
+ next
+ fix xa rsxa
+ assume ind:
+ "\<And>rsx. rec_calc_rel (Pr n f g) (butlast lm @ [last lm - xa]) rsx
+ \<Longrightarrow> \<exists>stp. abc_steps_l (6 + length ab, butlast lm @ (last lm - xa) #
+ rsx # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm) aprog stp =
+ (6 + length ab, butlast lm @ last lm # rs #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ 0 # suf_lm)"
+ and g: "rec_calc_rel (Pr n f g)
+ (butlast lm @ [last lm - Suc xa]) rsxa"
+ "Suc xa \<le> last lm"
+ "rec_ci (Pr n f g) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Pr n f g) lm rs"
+ "rec_ci g = (a, aa, ba)"
+ "rec_ci f = (ab, ac, bc)" "lm \<noteq> []"
+ from g have k1:
+ "\<exists> rs. rec_calc_rel (Pr n f g) (butlast lm @ [last lm - xa]) rs"
+ apply(rule_tac rs = rs in calc_pr_less_ex, simp, simp)
+ done
+ from g and this show
+ "\<exists>stp. abc_steps_l (6 + length ab,
+ butlast lm @ (last lm - Suc xa) # rsxa #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ Suc xa # suf_lm) aprog stp =
+ (6 + length ab, butlast lm @ last lm # rs #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ 0 # suf_lm)"
+ proof(erule_tac exE)
+ fix rsa
+ assume k2: "rec_calc_rel (Pr n f g)
+ (butlast lm @ [last lm - xa]) rsa"
+ from g and k2 have
+ "\<exists>stp. abc_steps_l (6 + length ab, butlast lm @
+ (last lm - Suc xa) # rsxa #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ Suc xa # suf_lm) aprog stp
+ = (6 + length ab, butlast lm @ (last lm - xa) # rsa #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm)"
+ proof -
+ from g have k2_1:
+ "\<exists> ap bp. length ap = 6 + length ab \<and>
+ aprog = ap [+] bp \<and>
+ bp = ([Dec (a_md - Suc 0) (length a + 7)] [+]
+ (a [+] [Inc (rs_pos - Suc 0), Dec rs_pos 3,
+ Goto (Suc 0)])) @
+ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length a + 4)]"
+ apply(rule_tac ci_pr_ex1, auto)
+ done
+ from k2_1 and k2 and g show "?thesis"
+ proof(erule_tac exE, erule_tac exE)
+ fix ap bp
+ assume
+ "length ap = 6 + length ab \<and>
+ aprog = ap [+] bp \<and> bp =
+ ([Dec (a_md - Suc 0) (length a + 7)] [+]
+ (a [+] [Inc (rs_pos - Suc 0), Dec rs_pos 3,
+ Goto (Suc 0)])) @
+ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length a + 4)]"
+ from g and this and k2 and g_ind show "?thesis"
+ apply(insert abc_append_exc3[of
+ "butlast lm @ (last lm - Suc xa) # rsxa #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ Suc xa # suf_lm" bp 0
+ "butlast lm @ (last lm - xa) # rsa #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm" "length ap" ap],
+ simp)
+ apply(subgoal_tac
+ "\<exists>stp. abc_steps_l (0, butlast lm @ (last lm - Suc xa)
+ # rsxa # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ Suc xa #
+ suf_lm) bp stp =
+ (0, butlast lm @ (last lm - xa) # rsa #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ xa # suf_lm)",
+ simp, erule_tac conjE, erule conjE)
+ apply(erule pr_cycle_part_ind, auto)
+ done
+ qed
+ qed
+ from g and k2 and this show "?thesis"
+ apply(erule_tac exE)
+ apply(insert ind[of rsa], simp)
+ apply(erule_tac exE)
+ apply(rule_tac x = "stp + stpa" in exI,
+ simp add: abc_steps_add)
+ done
+ qed
+ qed
+qed
+
+lemma ci_pr_length:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci g = (a, aa, ba);
+ rec_ci f = (ab, ac, bc)\<rbrakk>
+ \<Longrightarrow> length aprog = 13 + length ab + length a"
+apply(auto simp: rec_ci.simps)
+done
+
+thm empty.simps
+term max
+fun empty_inv :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool"
+ where
+ "empty_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 empty_stage1 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "empty_stage1 (as, lm) m =
+ (if as = 3 then 0
+ else 1)"
+
+fun empty_stage2 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "empty_stage2 (as, lm) m = (lm ! m)"
+
+fun empty_stage3 :: "nat \<times> nat list \<Rightarrow> nat \<Rightarrow> nat"
+ where
+ "empty_stage3 (as, lm) m = (if as = 1 then 3
+ else if as = 2 then 2
+ else if as = 0 then 1
+ else 0)"
+
+
+
+fun empty_measure :: "((nat \<times> nat list) \<times> nat) \<Rightarrow> (nat \<times> nat \<times> nat)"
+ where
+ "empty_measure ((as, lm), m) =
+ (empty_stage1 (as, lm) m, empty_stage2 (as, lm) m,
+ empty_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 empty_LE ::
+ "(((nat \<times> nat list) \<times> nat) \<times> ((nat \<times> nat list) \<times> nat)) set"
+ where
+ "empty_LE \<equiv> (inv_image lex_triple empty_measure)"
+
+lemma wf_lex_triple: "wf lex_triple"
+ by (auto intro:wf_lex_prod simp:lex_triple_def lex_pair_def)
+
+lemma wf_empty_le[intro]: "wf empty_LE"
+by(auto intro:wf_inv_image wf_lex_triple simp: empty_LE_def)
+
+declare empty_inv.simps[simp del]
+
+lemma empty_inv_init:
+"\<lbrakk>m < length initlm; n < length initlm; m \<noteq> n\<rbrakk> \<Longrightarrow>
+ empty_inv (0, initlm) m n initlm"
+apply(simp add: abc_steps_l.simps empty_inv.simps)
+apply(rule_tac x = "initlm ! m" in exI,
+ rule_tac x = "initlm ! n" in exI, simp)
+done
+
+lemma [simp]: "abc_fetch 0 (recursive.empty m n) = Some (Dec m 3)"
+apply(simp add: empty.simps abc_fetch.simps)
+done
+
+lemma [simp]: "abc_fetch (Suc 0) (recursive.empty m n) =
+ Some (Inc n)"
+apply(simp add: empty.simps abc_fetch.simps)
+done
+
+lemma [simp]: "abc_fetch 2 (recursive.empty m n) = Some (Goto 0)"
+apply(simp add: empty.simps abc_fetch.simps)
+done
+
+lemma [simp]: "abc_fetch 3 (recursive.empty m n) = None"
+apply(simp add: empty.simps abc_fetch.simps)
+done
+
+lemma [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,
+ simp, auto)
+apply(subgoal_tac
+ "initlm[m := k, n := l, m := k - Suc 0] =
+ initlm[n := l, m := k, m := k - Suc 0]")
+apply(simp add: list_update_overwrite )
+apply(simp add: list_update_swap)
+apply(simp add: list_update_swap)
+done
+
+lemma [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 [simp]:
+ "\<lbrakk>length initlm > max m n; m \<noteq> n\<rbrakk> \<Longrightarrow>
+ \<forall>na. \<not> (\<lambda>(as, lm) m. as = 3)
+ (abc_steps_l (0, initlm) (recursive.empty m n) na) m \<and>
+ empty_inv (abc_steps_l (0, initlm)
+ (recursive.empty m n) na) m n initlm \<longrightarrow>
+ empty_inv (abc_steps_l (0, initlm)
+ (recursive.empty m n) (Suc na)) m n initlm \<and>
+ ((abc_steps_l (0, initlm) (recursive.empty m n) (Suc na), m),
+ abc_steps_l (0, initlm) (recursive.empty m n) na, m) \<in> empty_LE"
+apply(rule allI, rule impI, simp add: abc_steps_ind)
+apply(case_tac "(abc_steps_l (0, initlm) (recursive.empty m n) na)",
+ simp)
+apply(auto split:if_splits simp add:abc_steps_l.simps empty_inv.simps)
+apply(auto simp add: empty_LE_def lex_triple_def lex_pair_def
+ abc_step_l.simps abc_steps_l.simps
+ empty_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 empty_inv_halt:
+ "\<lbrakk>length initlm > max m n; m \<noteq> n\<rbrakk> \<Longrightarrow>
+ \<exists> stp. (\<lambda> (as, lm). as = 3 \<and>
+ empty_inv (as, lm) m n initlm)
+ (abc_steps_l (0::nat, initlm) (empty m n) stp)"
+apply(insert halt_lemma2[of empty_LE
+ "\<lambda> ((as, lm), m). as = (3::nat)"
+ "\<lambda> stp. (abc_steps_l (0, initlm) (recursive.empty m n) stp, m)"
+ "\<lambda> ((as, lm), m). empty_inv (as, lm) m n initlm"])
+apply(insert wf_empty_le, simp add: empty_inv_init abc_steps_zero)
+apply(erule_tac exE)
+apply(rule_tac x = na in exI)
+apply(case_tac "(abc_steps_l (0, initlm) (recursive.empty m n) na)",
+ simp, auto)
+done
+
+lemma empty_halt_cond:
+ "\<lbrakk>m \<noteq> n; empty_inv (a, b) m n lm; a = 3\<rbrakk> \<Longrightarrow>
+ b = lm[n := lm ! m + lm ! n, m := 0]"
+apply(simp add: empty_inv.simps, auto)
+apply(simp add: list_update_swap)
+done
+
+lemma empty_ex:
+ "\<lbrakk>length lm > max m n; m \<noteq> n\<rbrakk> \<Longrightarrow>
+ \<exists> stp. abc_steps_l (0::nat, lm) (empty m n) stp
+ = (3, (lm[n := (lm ! m + lm ! n)])[m := 0::nat])"
+apply(drule empty_inv_halt, simp, erule_tac exE)
+apply(rule_tac x = stp in exI)
+apply(case_tac "abc_steps_l (0, lm) (recursive.empty m n) stp",
+ simp)
+apply(erule_tac empty_halt_cond, auto)
+done
+
+lemma [simp]:
+ "\<lbrakk>a_md = Suc (max (Suc (Suc n)) (max bc ba));
+ length lm = rs_pos \<and> rs_pos = n \<and> n > 0\<rbrakk>
+ \<Longrightarrow> n - Suc 0 < length lm +
+ (Suc (max (Suc (Suc n)) (max bc ba)) - rs_pos + length suf_lm) \<and>
+ Suc (Suc n) < length lm + (Suc (max (Suc (Suc n)) (max bc ba)) -
+ rs_pos + length suf_lm) \<and> bc < length lm + (Suc (max (Suc (Suc n))
+ (max bc ba)) - rs_pos + length suf_lm) \<and> ba < length lm +
+ (Suc (max (Suc (Suc n)) (max bc ba)) - rs_pos + length suf_lm)"
+apply(arith)
+done
+
+lemma [simp]:
+ "\<lbrakk>a_md = Suc (max (Suc (Suc n)) (max bc ba));
+ length lm = rs_pos \<and> rs_pos = n \<and> n > 0\<rbrakk>
+ \<Longrightarrow> n - Suc 0 < Suc (length suf_lm + max (Suc (Suc n)) (max bc ba)) \<and>
+ Suc n < length suf_lm + max (Suc (Suc n)) (max bc ba) \<and>
+ bc < Suc (length suf_lm + max (Suc (Suc n)) (max bc ba)) \<and>
+ ba < Suc (length suf_lm + max (Suc (Suc n)) (max bc ba))"
+apply(arith)
+done
+
+lemma [simp]: "n - Suc 0 \<noteq> max (Suc (Suc n)) (max bc ba)"
+apply(arith)
+done
+
+lemma [simp]:
+ "a_md \<ge> Suc bc \<and> rs_pos > 0 \<and> bc \<ge> rs_pos \<Longrightarrow>
+ bc - (rs_pos - Suc 0) + a_md - Suc bc = Suc (a_md - rs_pos - Suc 0)"
+apply(arith)
+done
+
+lemma [simp]: "length lm = n \<and> rs_pos = n \<and> 0 < rs_pos \<and>
+ Suc rs_pos < a_md
+ \<Longrightarrow> n - Suc 0 < Suc (Suc (a_md + length suf_lm - Suc (Suc 0)))
+ \<and> n < Suc (Suc (a_md + length suf_lm - Suc (Suc 0)))"
+apply(arith)
+done
+
+lemma [simp]: "length lm = n \<and> rs_pos = n \<and> 0 < rs_pos \<and>
+ Suc rs_pos < a_md \<Longrightarrow> n - Suc 0 \<noteq> n"
+by arith
+
+lemma ci_pr_ex2:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Pr n f g) lm rs;
+ rec_ci g = (a, aa, ba);
+ rec_ci f = (ab, ac, bc)\<rbrakk>
+ \<Longrightarrow> \<exists>ap bp. aprog = ap [+] bp \<and>
+ ap = empty n (max (Suc (Suc (Suc n))) (max bc ba))"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "(ab [+] (recursive.empty n (Suc n) [+]
+ ([Dec (max (n + 3) (max bc ba)) (length a + 7)]
+ [+] (a [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)])) @
+ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length a + 4)]))" in exI, auto)
+apply(simp add: abc_append_commute add3_Suc)
+done
+
+lemma [simp]:
+ "max (Suc (Suc (Suc n))) (max bc ba) - n <
+ Suc (max (Suc (Suc (Suc n))) (max bc ba)) - n"
+apply(arith)
+done
+lemma exp_nth[simp]: "n < m \<Longrightarrow> a\<^bsup>m\<^esup> ! n = a"
+apply(simp add: exponent_def)
+done
+
+lemma [simp]: "length lm = n \<and> rs_pos = n \<and> 0 < n \<Longrightarrow>
+ lm[n - Suc 0 := 0::nat] = butlast lm @ [0]"
+apply(auto)
+apply(insert list_update_append[of "butlast lm" "[last lm]"
+ "length lm - Suc 0" "0"], simp)
+done
+
+lemma [simp]: "\<lbrakk>length lm = n; 0 < n\<rbrakk> \<Longrightarrow> lm ! (n - Suc 0) = last lm"
+apply(insert nth_append[of "butlast lm" "[last lm]" "n - Suc 0"],
+ simp)
+apply(insert butlast_append_last[of lm], auto)
+done
+lemma exp_suc_iff: "a\<^bsup>b\<^esup> @ [a] = a\<^bsup>b + Suc 0\<^esup>"
+apply(simp add: exponent_def rep_ind del: replicate.simps)
+done
+
+lemma less_not_less[simp]: "n > 0 \<Longrightarrow> \<not> n < n - Suc 0"
+by auto
+
+lemma [simp]:
+ "Suc n < length suf_lm + max (Suc (Suc n)) (max bc ba) \<and>
+ bc < Suc (length suf_lm + max (Suc (Suc n))
+ (max bc ba)) \<and>
+ ba < Suc (length suf_lm + max (Suc (Suc n)) (max bc ba))"
+ by arith
+
+lemma [simp]: "length lm = n \<and> rs_pos = n \<and> n > 0 \<Longrightarrow>
+(lm @ 0\<^bsup>Suc (max (Suc (Suc n)) (max bc ba)) - n\<^esup> @ suf_lm)
+ [max (Suc (Suc n)) (max bc ba) :=
+ (lm @ 0\<^bsup>Suc (max (Suc (Suc n)) (max bc ba)) - n\<^esup> @ suf_lm) ! (n - Suc 0) +
+ (lm @ 0\<^bsup>Suc (max (Suc (Suc n)) (max bc ba)) - n\<^esup> @ suf_lm) !
+ max (Suc (Suc n)) (max bc ba), n - Suc 0 := 0::nat]
+ = butlast lm @ 0 # 0\<^bsup>max (Suc (Suc n)) (max bc ba) - n\<^esup> @ last lm # suf_lm"
+apply(simp add: nth_append exp_nth list_update_append)
+apply(insert list_update_append[of "0\<^bsup>(max (Suc (Suc n)) (max bc ba)) - n\<^esup>"
+ "[0]" "max (Suc (Suc n)) (max bc ba) - n" "last lm"], simp)
+apply(simp add: exp_suc_iff Suc_diff_le del: list_update.simps)
+done
+
+lemma exp_eq: "(a = b) = (c\<^bsup>a\<^esup> = c\<^bsup>b\<^esup>)"
+apply(auto simp: exponent_def)
+done
+
+lemma [simp]:
+ "\<lbrakk>length lm = n; 0 < n; Suc n < a_md\<rbrakk> \<Longrightarrow>
+ (butlast lm @ rsa # 0\<^bsup>a_md - Suc n\<^esup> @ last lm # suf_lm)
+ [n := (butlast lm @ rsa # 0\<^bsup>a_md - Suc n\<^esup> @ last lm # suf_lm) !
+ (n - Suc 0) + (butlast lm @ rsa # (0::nat)\<^bsup>a_md - Suc n\<^esup> @
+ last lm # suf_lm) ! n, n - Suc 0 := 0]
+ = butlast lm @ 0 # rsa # 0\<^bsup>a_md - Suc (Suc n)\<^esup> @ last lm # suf_lm"
+apply(simp add: nth_append exp_nth list_update_append)
+apply(case_tac "a_md - Suc n", simp, simp add: exponent_def)
+done
+
+lemma [simp]:
+ "Suc (Suc rs_pos) \<le> a_md \<and> length lm = rs_pos \<and> 0 < rs_pos
+ \<Longrightarrow> a_md - Suc 0 <
+ Suc (Suc (Suc (a_md + length suf_lm - Suc (Suc (Suc 0)))))"
+by arith
+
+lemma [simp]:
+ "Suc (Suc rs_pos) \<le> a_md \<and> length lm = rs_pos \<and> 0 < rs_pos \<Longrightarrow>
+ \<not> a_md - Suc 0 < rs_pos - Suc 0"
+by arith
+
+lemma [simp]: "Suc (Suc rs_pos) \<le> a_md \<Longrightarrow>
+ \<not> a_md - Suc 0 < rs_pos - Suc 0"
+by arith
+
+lemma [simp]: "\<lbrakk>Suc (Suc rs_pos) \<le> a_md\<rbrakk> \<Longrightarrow>
+ \<not> a_md - rs_pos < Suc (Suc (a_md - Suc (Suc rs_pos)))"
+by arith
+
+lemma [simp]:
+ "Suc (Suc rs_pos) \<le> a_md \<and> length lm = rs_pos \<and> 0 < rs_pos
+ \<Longrightarrow> (abc_lm_v (butlast lm @ last lm # rs # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @
+ 0 # suf_lm) (a_md - Suc 0) = 0 \<longrightarrow>
+ abc_lm_s (butlast lm @ last lm # rs # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @
+ 0 # suf_lm) (a_md - Suc 0) 0 =
+ lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm) \<and>
+ abc_lm_v (butlast lm @ last lm # rs # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @
+ 0 # suf_lm) (a_md - Suc 0) = 0"
+apply(simp add: abc_lm_v.simps nth_append abc_lm_s.simps)
+apply(insert nth_append[of "last lm # rs # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup>"
+ "0 # suf_lm" "(a_md - rs_pos)"], auto)
+apply(simp only: exp_suc_iff)
+apply(subgoal_tac "a_md - Suc 0 < a_md + length suf_lm", simp)
+apply(case_tac "lm = []", auto)
+done
+
+lemma pr_prog_ex[simp]: "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci g = (a, aa, ba); rec_ci f = (ab, ac, bc)\<rbrakk>
+ \<Longrightarrow> \<exists>cp. aprog = recursive.empty n (max (n + 3)
+ (max bc ba)) [+] cp"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "(ab [+] (recursive.empty n (Suc n) [+]
+ ([Dec (max (n + 3) (max bc ba)) (length a + 7)]
+ [+] (a [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)]))
+ @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length a + 4)]))" in exI)
+apply(auto simp: abc_append_commute)
+done
+
+lemma [simp]: "empty m n \<noteq> []"
+by (simp add: empty.simps)
+(*
+lemma [simp]: "\<lbrakk>rs_pos = n; 0 < rs_pos ; Suc rs_pos < a_md\<rbrakk> \<Longrightarrow>
+ n - Suc 0 < a_md + length suf_lm"
+by arith
+*)
+lemma [intro]:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci f = (ab, ac, bc)\<rbrakk> \<Longrightarrow>
+ \<exists>ap. (\<exists>cp. aprog = ap [+] ab [+] cp) \<and> length ap = 3"
+apply(case_tac "rec_ci g", simp add: rec_ci.simps)
+apply(rule_tac x = "empty n
+ (max (n + 3) (max bc c))" in exI, simp)
+apply(rule_tac x = "recursive.empty n (Suc n) [+]
+ ([Dec (max (n + 3) (max bc c)) (length a + 7)]
+ [+] a [+] [Inc n, Dec (Suc n) 3, Goto (Suc 0)])
+ @ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length a + 4)]" in exI,
+ auto)
+apply(simp add: abc_append_commute)
+done
+
+lemma [intro]:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci g = (a, aa, ba);
+ rec_ci f = (ab, ac, bc)\<rbrakk> \<Longrightarrow>
+ \<exists>ap. (\<exists>cp. aprog = ap [+] recursive.empty n (Suc n) [+] cp)
+ \<and> length ap = 3 + length ab"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "recursive.empty n (max (n + 3)
+ (max bc ba)) [+] ab" in exI, simp)
+apply(rule_tac x = "([Dec (max (n + 3) (max bc ba))
+ (length a + 7)] [+] a [+]
+ [Inc n, Dec (Suc n) 3, Goto (Suc 0)]) @
+ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length a + 4)]" in exI)
+apply(auto simp: abc_append_commute)
+done
+
+(*
+lemma [simp]:
+ "n - Suc 0 < Suc (max (Suc (Suc n)) (max bc ba) + length suf_lm) \<and>
+ Suc n < max (Suc (Suc n)) (max bc ba) + length suf_lm \<and>
+ bc < Suc (max (Suc (Suc n)) (max bc ba) + length suf_lm) \<and>
+ ba < Suc (max (Suc (Suc n)) (max bc ba) + length suf_lm)"
+by arith
+*)
+
+lemma [intro]:
+ "\<lbrakk>rec_ci (Pr n f g) = (aprog, rs_pos, a_md);
+ rec_ci g = (a, aa, ba);
+ rec_ci f = (ab, ac, bc)\<rbrakk>
+ \<Longrightarrow> \<exists>ap. (\<exists>cp. aprog = ap [+] ([Dec (a_md - Suc 0) (length a + 7)]
+ [+] (a [+] [Inc (rs_pos - Suc 0), Dec rs_pos 3,
+ Goto (Suc 0)])) @ [Dec (Suc (Suc n)) 0, Inc (Suc n),
+ Goto (length a + 4)] [+] cp) \<and>
+ length ap = 6 + length ab"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "recursive.empty n
+ (max (n + 3) (max bc ba)) [+] ab [+]
+ recursive.empty n (Suc n)" in exI, simp)
+apply(rule_tac x = "[]" in exI, auto)
+apply(simp add: abc_append_commute)
+done
+
+(*
+lemma [simp]: "\<lbrakk>rs_pos = n; 0 < rs_pos ; Suc rs_pos < a_md\<rbrakk> \<Longrightarrow>
+ n - Suc 0 < Suc (Suc (a_md + length suf_lm - 2)) \<and>
+ n < Suc (Suc (a_md + length suf_lm - 2))"
+by arith
+*)
+
+lemma [simp]:
+ "n < Suc (max (n + 3) (max bc ba) + length suf_lm) \<and>
+ Suc (Suc n) < max (n + 3) (max bc ba) + length suf_lm \<and>
+ bc < Suc (max (n + 3) (max bc ba) + length suf_lm) \<and>
+ ba < Suc (max (n + 3) (max bc ba) + length suf_lm)"
+by arith
+
+lemma [simp]: "n \<noteq> max (n + (3::nat)) (max bc ba)"
+by arith
+
+lemma [simp]:"length lm = Suc n \<Longrightarrow> lm[n := (0::nat)] = butlast lm @ [0]"
+apply(subgoal_tac "\<exists> xs x. lm = xs @ [x]", auto simp: list_update_append)
+apply(rule_tac x = "butlast lm" in exI, rule_tac x = "last lm" in exI)
+apply(case_tac lm, auto)
+done
+
+lemma [simp]: "length lm = Suc n \<Longrightarrow> lm ! n =last lm"
+apply(subgoal_tac "lm \<noteq> []")
+apply(simp add: last_conv_nth, case_tac lm, simp_all)
+done
+
+lemma [simp]: "length lm = Suc n \<Longrightarrow>
+ (lm @ (0::nat)\<^bsup>max (n + 3) (max bc ba) - n\<^esup> @ suf_lm)
+ [max (n + 3) (max bc ba) := (lm @ 0\<^bsup>max (n + 3) (max bc ba) - n\<^esup> @ suf_lm) ! n +
+ (lm @ 0\<^bsup>max (n + 3) (max bc ba) - n\<^esup> @ suf_lm) ! max (n + 3) (max bc ba), n := 0]
+ = butlast lm @ 0 # 0\<^bsup>max (n + 3) (max bc ba) - Suc n\<^esup> @ last lm # suf_lm"
+apply(auto simp: list_update_append nth_append)
+apply(subgoal_tac "(0\<^bsup>max (n + 3) (max bc ba) - n\<^esup>) = 0\<^bsup>max (n + 3) (max bc ba) - Suc n\<^esup> @ [0::nat]")
+apply(simp add: list_update_append)
+apply(simp add: exp_suc_iff)
+done
+
+lemma [simp]: "Suc (Suc n) < a_md \<Longrightarrow>
+ n < Suc (Suc (a_md + length suf_lm - 2)) \<and>
+ n < Suc (a_md + length suf_lm - 2)"
+by(arith)
+
+lemma [simp]: "\<lbrakk>length lm = Suc n; Suc (Suc n) < a_md\<rbrakk>
+ \<Longrightarrow>(butlast lm @ (rsa::nat) # 0\<^bsup>a_md - Suc (Suc n)\<^esup> @ last lm # suf_lm)
+ [Suc n := (butlast lm @ rsa # 0\<^bsup>a_md - Suc (Suc n)\<^esup> @ last lm # suf_lm) ! n +
+ (butlast lm @ rsa # 0\<^bsup>a_md - Suc (Suc n)\<^esup> @ last lm # suf_lm) ! Suc n, n := 0]
+ = butlast lm @ 0 # rsa # 0\<^bsup>a_md - Suc (Suc (Suc n))\<^esup> @ last lm # suf_lm"
+apply(auto simp: list_update_append)
+apply(subgoal_tac "(0\<^bsup>a_md - Suc (Suc n)\<^esup>) = (0::nat) # (0\<^bsup>a_md - Suc (Suc (Suc n))\<^esup>)", simp add: nth_append)
+apply(simp add: exp_ind_def[THEN sym])
+done
+
+lemma pr_case:
+ assumes nf_ind:
+ "\<And> lm rs suf_lm. rec_calc_rel f lm rs \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>bc - ac\<^esup> @ suf_lm) ab stp =
+ (length ab, lm @ rs # 0\<^bsup>bc - Suc ac\<^esup> @ suf_lm)"
+ and ng_ind: "\<And> lm rs suf_lm. rec_calc_rel g lm rs \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>ba - aa\<^esup> @ suf_lm) a stp =
+ (length a, lm @ rs # 0\<^bsup>ba - Suc aa\<^esup> @ suf_lm)"
+ and h: "rec_ci (Pr n f g) = (aprog, rs_pos, a_md)" "rec_calc_rel (Pr n f g) lm rs"
+ "rec_ci g = (a, aa, ba)" "rec_ci f = (ab, ac, bc)"
+ shows "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp = (length aprog, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+proof -
+ from h have k1: "\<exists> stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp
+ = (3, butlast lm @ 0 # 0\<^bsup>a_md - rs_pos - 1\<^esup> @ last lm # suf_lm)"
+ proof -
+ have "\<exists>bp cp. aprog = bp [+] cp \<and> bp = empty n
+ (max (n + 3) (max bc ba))"
+ apply(insert h, simp)
+ apply(erule pr_prog_ex, auto)
+ done
+ thus "?thesis"
+ apply(erule_tac exE, erule_tac exE, simp)
+ apply(subgoal_tac
+ "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm)
+ ([] [+] recursive.empty n
+ (max (n + 3) (max bc ba)) [+] cp) stp =
+ (0 + 3, butlast lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @
+ last lm # suf_lm)", simp)
+ apply(rule_tac abc_append_exc1, simp_all)
+ apply(insert empty_ex[of "n" "(max (n + 3)
+ (max bc ba))" "lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm"], simp)
+ apply(subgoal_tac "a_md = Suc (max (n + 3) (max bc ba))",
+ simp)
+ apply(subgoal_tac "length lm = Suc n \<and> rs_pos = Suc n", simp)
+ apply(insert h)
+ apply(simp add: para_pattern ci_pr_para_eq)
+ apply(rule ci_pr_md_def, auto)
+ done
+ qed
+ from h have k2:
+ "\<exists> stp. abc_steps_l (3, butlast lm @ 0 # 0\<^bsup>a_md - rs_pos - 1\<^esup> @
+ last lm # suf_lm) aprog stp
+ = (length aprog, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ proof -
+ from h have k2_1: "\<exists> rs. rec_calc_rel f (butlast lm) rs"
+ apply(erule_tac calc_pr_zero_ex)
+ done
+ thus "?thesis"
+ proof(erule_tac exE)
+ fix rsa
+ assume k2_2: "rec_calc_rel f (butlast lm) rsa"
+ from h and k2_2 have k2_2_1:
+ "\<exists> stp. abc_steps_l (3, butlast lm @ 0 # 0\<^bsup>a_md - rs_pos - 1\<^esup>
+ @ last lm # suf_lm) aprog stp
+ = (3 + length ab, butlast lm @ rsa # 0\<^bsup>a_md - rs_pos - 1\<^esup> @
+ last lm # suf_lm)"
+ proof -
+ from h have j1: "
+ \<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and> length ap = 3 \<and>
+ bp = ab"
+ apply(auto)
+ done
+ from h have j2: "ac = rs_pos - 1"
+ apply(drule_tac ci_pr_f_paras, simp, auto)
+ done
+ from h and j2 have j3: "a_md \<ge> Suc bc \<and> rs_pos > 0 \<and> bc \<ge> rs_pos"
+ apply(rule_tac conjI)
+ apply(erule_tac ab = ab and ac = ac in ci_pr_md_ge_f, simp)
+ apply(rule_tac context_conjI)
+ apply(simp_all add: rec_ci.simps)
+ apply(drule_tac ci_ad_ge_paras, drule_tac ci_ad_ge_paras)
+ apply(arith)
+ done
+ from j1 and j2 show "?thesis"
+ apply(auto simp del: abc_append_commute)
+ apply(rule_tac abc_append_exc1, simp_all)
+ apply(insert nf_ind[of "butlast lm" "rsa"
+ "0\<^bsup>a_md - bc - Suc 0\<^esup> @ last lm # suf_lm"],
+ simp add: k2_2 j2, erule_tac exE)
+ apply(simp add: exponent_add_iff j3)
+ apply(rule_tac x = "stp" in exI, simp)
+ done
+ qed
+ from h have k2_2_2:
+ "\<exists> stp. abc_steps_l (3 + length ab, butlast lm @ rsa #
+ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ last lm # suf_lm) aprog stp
+ = (6 + length ab, butlast lm @ 0 # rsa #
+ 0\<^bsup>a_md - rs_pos - 2\<^esup> @ last lm # suf_lm)"
+ proof -
+ from h have "\<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and>
+ length ap = 3 + length ab \<and> bp = recursive.empty n (Suc n)"
+ by auto
+ thus "?thesis"
+ proof(erule_tac exE, erule_tac exE, erule_tac exE,
+ erule_tac exE)
+ fix ap cp bp apa
+ assume "aprog = ap [+] bp [+] cp \<and> length ap = 3 +
+ length ab \<and> bp = recursive.empty n (Suc n)"
+ thus "?thesis"
+ apply(simp del: abc_append_commute)
+ apply(subgoal_tac
+ "\<exists>stp. abc_steps_l (3 + length ab,
+ butlast lm @ rsa # 0\<^bsup>a_md - Suc rs_pos\<^esup> @
+ last lm # suf_lm) (ap [+]
+ recursive.empty n (Suc n) [+] cp) stp =
+ ((3 + length ab) + 3, butlast lm @ 0 # rsa #
+ 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ last lm # suf_lm)", simp)
+ apply(rule_tac abc_append_exc1, simp_all)
+ apply(insert empty_ex[of n "Suc n"
+ "butlast lm @ rsa # 0\<^bsup>a_md - Suc rs_pos\<^esup> @
+ last lm # suf_lm"], simp)
+ apply(subgoal_tac "length lm = Suc n \<and> rs_pos = Suc n \<and> a_md > Suc (Suc n)", simp)
+ apply(insert h, simp)
+ done
+ qed
+ qed
+ from h have k2_3: "lm \<noteq> []"
+ apply(rule_tac calc_pr_para_not_null, simp)
+ done
+ from h and k2_2 and k2_3 have k2_2_3:
+ "\<exists> stp. abc_steps_l (6 + length ab, butlast lm @
+ (last lm - last lm) # rsa #
+ 0\<^bsup>a_md - (Suc (Suc rs_pos))\<^esup> @ last lm # suf_lm) aprog stp
+ = (6 + length ab, butlast lm @ last lm # rs #
+ 0\<^bsup>a_md - Suc (Suc (rs_pos))\<^esup> @ 0 # suf_lm)"
+ apply(rule_tac x = "last lm" and g = g in pr_cycle_part, auto)
+ apply(rule_tac ng_ind, simp)
+ apply(rule_tac rec_calc_rel_def0, simp, simp)
+ done
+ from h have k2_2_4:
+ "\<exists> stp. abc_steps_l (6 + length ab,
+ butlast lm @ last lm # rs # 0\<^bsup>a_md - rs_pos - 2\<^esup> @
+ 0 # suf_lm) aprog stp
+ = (13 + length ab + length a,
+ lm @ rs # 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ proof -
+ from h have
+ "\<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and>
+ length ap = 6 + length ab \<and>
+ bp = ([Dec (a_md - Suc 0) (length a + 7)] [+]
+ (a [+] [Inc (rs_pos - Suc 0),
+ Dec rs_pos 3, Goto (Suc 0)])) @
+ [Dec (Suc (Suc n)) 0, Inc (Suc n), Goto (length a + 4)]"
+ by auto
+ thus "?thesis"
+ apply(auto)
+ apply(subgoal_tac
+ "\<exists>stp. abc_steps_l (6 + length ab, butlast lm @
+ last lm # rs # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ 0 # suf_lm)
+ (ap [+] ([Dec (a_md - Suc 0) (length a + 7)] [+]
+ (a [+] [Inc (rs_pos - Suc 0), Dec rs_pos 3,
+ Goto (Suc 0)])) @ [Dec (Suc (Suc n)) 0, Inc (Suc n),
+ Goto (length a + 4)] [+] cp) stp =
+ (6 + length ab + (length a + 7) ,
+ lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)", simp)
+ apply(subgoal_tac "13 + (length ab + length a) =
+ 13 + length ab + length a", simp)
+ apply(arith)
+ apply(rule abc_append_exc1, simp_all)
+ apply(rule_tac x = "Suc 0" in exI,
+ simp add: abc_steps_l.simps abc_fetch.simps
+ nth_append abc_append_nth abc_step_l.simps)
+ apply(subgoal_tac "a_md > Suc (Suc rs_pos) \<and>
+ length lm = rs_pos \<and> rs_pos > 0", simp)
+ apply(insert h, simp)
+ apply(subgoal_tac "rs_pos = Suc n", simp, simp)
+ done
+ qed
+ from h have k2_2_5: "length aprog = 13 + length ab + length a"
+ apply(rule_tac ci_pr_length, simp_all)
+ done
+ from k2_2_1 and k2_2_2 and k2_2_3 and k2_2_4 and k2_2_5
+ show "?thesis"
+ apply(auto)
+ apply(rule_tac x = "stp + stpa + stpb + stpc" in exI,
+ simp add: abc_steps_add)
+ done
+ qed
+ qed
+ from k1 and k2 show
+ "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp
+ = (length aprog, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ apply(erule_tac exE)
+ apply(erule_tac exE)
+ apply(rule_tac x = "stp + stpa" in exI)
+ apply(simp add: abc_steps_add)
+ done
+qed
+
+thm rec_calc_rel.induct
+
+lemma eq_switch: "x = y \<Longrightarrow> y = x"
+by simp
+
+lemma [simp]:
+ "\<lbrakk>rec_ci f = (a, aa, ba);
+ rec_ci (Mn n f) = (aprog, rs_pos, a_md)\<rbrakk> \<Longrightarrow> \<exists>bp. aprog = a @ bp"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "[Dec (Suc n) (length a + 5),
+ Dec (Suc n) (length a + 3), Goto (Suc (length a)),
+ Inc n, Goto 0]" in exI, auto)
+done
+
+lemma ci_mn_para_eq[simp]:
+ "rec_ci (Mn n f) = (aprog, rs_pos, a_md) \<Longrightarrow> rs_pos = n"
+apply(case_tac "rec_ci f", simp add: rec_ci.simps)
+done
+(*
+lemma [simp]: "\<lbrakk>rec_ci f = (a, aa, ba); rec_ci (Mn n f) = (aprog, rs_pos, a_md); rec_calc_rel (Mn n f) lm rs\<rbrakk> \<Longrightarrow> aa = Suc rs_pos"
+apply(rule_tac calc_mn_reverse, simp)
+apply(insert para_pattern [of f a aa ba "lm @ [rs]" 0], simp)
+apply(subgoal_tac "rs_pos = length lm", simp)
+apply(drule_tac ci_mn_para_eq, simp)
+done
+*)
+lemma [simp]: "rec_ci f = (a, aa, ba) \<Longrightarrow> aa < ba"
+apply(simp add: ci_ad_ge_paras)
+done
+
+lemma [simp]: "\<lbrakk>rec_ci f = (a, aa, ba);
+ rec_ci (Mn n f) = (aprog, rs_pos, a_md)\<rbrakk>
+ \<Longrightarrow> ba \<le> a_md"
+apply(simp add: rec_ci.simps)
+by arith
+
+lemma mn_calc_f:
+ assumes ind:
+ "\<And>aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>rec_ci f = (aprog, rs_pos, a_md); rec_calc_rel f lm rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp
+ = (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ and h: "rec_ci f = (a, aa, ba)"
+ "rec_ci (Mn n f) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel f (lm @ [x]) rsx"
+ "aa = Suc n"
+ shows "\<exists>stp. abc_steps_l (0, lm @ x # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stp = (length a,
+ lm @ x # rsx # 0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ suf_lm)"
+proof -
+ from h have k1: "\<exists> ap bp. aprog = ap @ bp \<and> ap = a"
+ by simp
+ from h have k2: "rs_pos = n"
+ apply(erule_tac ci_mn_para_eq)
+ done
+ from h and k1 and k2 show "?thesis"
+
+ proof(erule_tac exE, erule_tac exE, simp,
+ rule_tac abc_add_exc1, auto)
+ fix bp
+ show
+ "\<exists>astp. abc_steps_l (0, lm @ x # 0\<^bsup>a_md - Suc n\<^esup> @ suf_lm) a astp
+ = (length a, lm @ x # rsx # 0\<^bsup>a_md - Suc (Suc n)\<^esup> @ suf_lm)"
+ apply(insert ind[of a "Suc n" ba "lm @ [x]" rsx
+ "0\<^bsup>a_md - ba\<^esup> @ suf_lm"], simp add: exponent_add_iff h k2)
+ apply(subgoal_tac "ba > aa \<and> a_md \<ge> ba \<and> aa = Suc n",
+ insert h, auto)
+ done
+ qed
+qed
+thm rec_ci.simps
+
+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)"
+
+thm halt_lemma2
+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 mn_inv_init:
+ "mn_ind_inv (abc_steps_l (length a, lm @ x # rsx # suf_lm) aprog 0)
+ (length a) x rsx suf_lm lm"
+apply(simp add: mn_ind_inv.simps abc_steps_zero)
+done
+
+lemma mn_halt_init:
+ "rec_ci f = (a, aa, ba) \<Longrightarrow>
+ \<not> (\<lambda>(as, lm') (ss, n). as = 0)
+ (abc_steps_l (length a, lm @ x # rsx # suf_lm) aprog 0)
+ (length a, n)"
+apply(simp add: abc_steps_zero)
+apply(erule_tac rec_ci_not_null)
+done
+
+thm rec_ci.simps
+lemma [simp]:
+ "\<lbrakk>rec_ci f = (a, aa, ba);
+ rec_ci (Mn n f) = (aprog, rs_pos, a_md)\<rbrakk>
+ \<Longrightarrow> abc_fetch (length a) aprog =
+ Some (Dec (Suc n) (length a + 5))"
+apply(simp add: rec_ci.simps abc_fetch.simps,
+ erule_tac conjE, erule_tac conjE, simp)
+apply(drule_tac eq_switch, drule_tac eq_switch, simp)
+done
+
+lemma [simp]: "\<lbrakk>rec_ci f = (a, aa, ba); rec_ci (Mn n f) = (aprog, rs_pos, a_md)\<rbrakk>
+ \<Longrightarrow> abc_fetch (Suc (length a)) aprog = Some (Dec (Suc n) (length a + 3))"
+apply(simp add: rec_ci.simps abc_fetch.simps, erule_tac conjE, erule_tac conjE, simp)
+apply(drule_tac eq_switch, drule_tac eq_switch, simp add: nth_append)
+done
+
+lemma [simp]:
+ "\<lbrakk>rec_ci f = (a, aa, ba);
+ rec_ci (Mn n f) = (aprog, rs_pos, a_md)\<rbrakk>
+ \<Longrightarrow> abc_fetch (Suc (Suc (length a))) aprog =
+ Some (Goto (length a + 1))"
+apply(simp add: rec_ci.simps abc_fetch.simps,
+ erule_tac conjE, erule_tac conjE, simp)
+apply(drule_tac eq_switch, drule_tac eq_switch, simp add: nth_append)
+done
+
+lemma [simp]:
+ "\<lbrakk>rec_ci f = (a, aa, ba);
+ rec_ci (Mn n f) = (aprog, rs_pos, a_md)\<rbrakk>
+ \<Longrightarrow> abc_fetch (length a + 3) aprog = Some (Inc n)"
+apply(simp add: rec_ci.simps abc_fetch.simps,
+ erule_tac conjE, erule_tac conjE, simp)
+apply(drule_tac eq_switch, drule_tac eq_switch, simp add: nth_append)
+done
+
+lemma [simp]: "\<lbrakk>rec_ci f = (a, aa, ba); rec_ci (Mn n f) = (aprog, rs_pos, a_md)\<rbrakk>
+ \<Longrightarrow> abc_fetch (length a + 4) aprog = Some (Goto 0)"
+apply(simp add: rec_ci.simps abc_fetch.simps, erule_tac conjE, erule_tac conjE, simp)
+apply(drule_tac eq_switch, drule_tac eq_switch, simp add: nth_append)
+done
+
+lemma [simp]:
+ "0 < rsx
+ \<Longrightarrow> \<exists>y. (lm @ x # rsx # suf_lm)[Suc (length lm) := rsx - Suc 0]
+ = lm @ x # y # suf_lm \<and> y \<le> rsx"
+apply(case_tac rsx, simp, simp)
+apply(rule_tac x = nat in exI, simp add: list_update_append)
+done
+
+lemma [simp]:
+ "\<lbrakk>y \<le> rsx; 0 < y\<rbrakk>
+ \<Longrightarrow> \<exists>ya. (lm @ x # y # suf_lm)[Suc (length lm) := y - Suc 0]
+ = lm @ x # ya # suf_lm \<and> ya \<le> rsx"
+apply(case_tac y, simp, simp)
+apply(rule_tac x = nat in exI, simp add: list_update_append)
+done
+
+lemma mn_halt_lemma:
+ "\<lbrakk>rec_ci f = (a, aa, ba);
+ rec_ci (Mn n f) = (aprog, rs_pos, a_md);
+ 0 < rsx; length lm = n\<rbrakk>
+ \<Longrightarrow>
+ \<forall>na. \<not> (\<lambda>(as, lm') (ss, n). as = 0)
+ (abc_steps_l (length a, lm @ x # rsx # suf_lm) aprog na)
+ (length a, n)
+ \<and> mn_ind_inv (abc_steps_l (length a, lm @ x # rsx # suf_lm)
+ aprog na) (length a) x rsx suf_lm lm
+\<longrightarrow> mn_ind_inv (abc_steps_l (length a, lm @ x # rsx # suf_lm) aprog
+ (Suc na)) (length a) x rsx suf_lm lm
+ \<and> ((abc_steps_l (length a, lm @ x # rsx # suf_lm) aprog (Suc na),
+ length a, n),
+ abc_steps_l (length a, lm @ x # rsx # suf_lm) aprog na,
+ length a, n) \<in> mn_LE"
+apply(rule allI, rule impI, simp add: abc_steps_ind)
+apply(case_tac "(abc_steps_l (length a, lm @ x # rsx # suf_lm)
+ aprog na)", simp)
+apply(auto split:if_splits simp add:abc_steps_l.simps
+ mn_ind_inv.simps abc_steps_zero)
+apply(auto simp add: 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
+ split: if_splits)
+apply(drule_tac rec_ci_not_null, simp)
+done
+
+lemma mn_halt:
+ "\<lbrakk>rec_ci f = (a, aa, ba);
+ rec_ci (Mn n f) = (aprog, rs_pos, a_md);
+ 0 < rsx; length lm = n\<rbrakk>
+ \<Longrightarrow> \<exists> stp. (\<lambda> (as, lm'). (as = 0 \<and>
+ mn_ind_inv (as, lm') (length a) x rsx suf_lm lm))
+ (abc_steps_l (length a, lm @ x # rsx # suf_lm) aprog stp)"
+apply(insert wf_mn_le)
+apply(insert halt_lemma2[of mn_LE
+ "\<lambda> ((as, lm'), ss, n). as = 0"
+ "\<lambda> stp. (abc_steps_l (length a, lm @ x # rsx # suf_lm) aprog stp,
+ length a, n)"
+ "\<lambda> ((as, lm'), ss, n). mn_ind_inv (as, lm') ss x rsx suf_lm lm"],
+ simp)
+apply(simp add: mn_halt_init mn_inv_init)
+apply(drule_tac x = x and suf_lm = suf_lm in mn_halt_lemma, auto)
+apply(rule_tac x = n in exI,
+ case_tac "(abc_steps_l (length a, lm @ x # rsx # suf_lm)
+ aprog n)", simp)
+done
+
+lemma [simp]: "Suc rs_pos < a_md \<Longrightarrow>
+ Suc (a_md - Suc (Suc rs_pos)) = a_md - Suc rs_pos"
+by arith
+
+term rec_ci
+(*
+lemma [simp]: "\<lbrakk>rec_ci (Mn n f) = (aprog, rs_pos, a_md); rec_calc_rel (Mn n f) lm rs\<rbrakk> \<Longrightarrow> Suc rs_pos < a_md"
+apply(case_tac "rec_ci f")
+apply(subgoal_tac "c > b \<and> b = Suc rs_pos \<and> a_md \<ge> c")
+apply(arith, auto)
+done
+*)
+lemma mn_ind_step:
+ assumes ind:
+ "\<And>aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>rec_ci f = (aprog, rs_pos, a_md);
+ rec_calc_rel f lm rs\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp
+ = (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ and h: "rec_ci f = (a, aa, ba)"
+ "rec_ci (Mn n f) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel f (lm @ [x]) rsx"
+ "rsx > 0"
+ "Suc rs_pos < a_md"
+ "aa = Suc rs_pos"
+ shows "\<exists>stp. abc_steps_l (0, lm @ x # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stp = (0, lm @ Suc x # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+thm abc_add_exc1
+proof -
+ have k1:
+ "\<exists> stp. abc_steps_l (0, lm @ x # 0\<^bsup>a_md - Suc (rs_pos)\<^esup> @ suf_lm)
+ aprog stp =
+ (length a, lm @ x # rsx # 0\<^bsup>a_md - Suc (Suc rs_pos) \<^esup>@ suf_lm)"
+ apply(insert h)
+ apply(auto intro: mn_calc_f ind)
+ done
+ from h have k2: "length lm = n"
+ apply(subgoal_tac "rs_pos = n")
+ apply(drule_tac para_pattern, simp, simp, simp)
+ done
+ from h have k3: "a_md > (Suc rs_pos)"
+ apply(simp)
+ done
+ from k2 and h and k3 have k4:
+ "\<exists> stp. abc_steps_l (length a,
+ lm @ x # rsx # 0\<^bsup>a_md - Suc (Suc rs_pos) \<^esup>@ suf_lm) aprog stp =
+ (0, lm @ Suc x # 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ apply(frule_tac x = x and
+ suf_lm = "0\<^bsup>a_md - Suc (Suc rs_pos)\<^esup> @ suf_lm" in mn_halt, auto)
+ apply(rule_tac x = "stp" in exI,
+ simp add: mn_ind_inv.simps rec_ci_not_null exponent_def)
+ apply(simp only: replicate.simps[THEN sym], simp)
+ done
+
+ from k1 and k4 show "?thesis"
+ apply(auto)
+ apply(rule_tac x = "stp + stpa" in exI, simp add: abc_steps_add)
+ done
+qed
+
+lemma [simp]:
+ "\<lbrakk>rec_ci f = (a, aa, ba); rec_ci (Mn n f) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Mn n f) lm rs\<rbrakk> \<Longrightarrow> aa = Suc rs_pos"
+apply(rule_tac calc_mn_reverse, simp)
+apply(insert para_pattern [of f a aa ba "lm @ [rs]" 0], simp)
+apply(subgoal_tac "rs_pos = length lm", simp)
+apply(drule_tac ci_mn_para_eq, simp)
+done
+
+lemma [simp]: "\<lbrakk>rec_ci (Mn n f) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Mn n f) lm rs\<rbrakk> \<Longrightarrow> Suc rs_pos < a_md"
+apply(case_tac "rec_ci f")
+apply(subgoal_tac "c > b \<and> b = Suc rs_pos \<and> a_md \<ge> c")
+apply(arith, auto)
+done
+
+lemma mn_ind_steps:
+ assumes ind:
+ "\<And>aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>rec_ci f = (aprog, rs_pos, a_md); rec_calc_rel f lm rs\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ and h: "rec_ci f = (a, aa, ba)"
+ "rec_ci (Mn n f) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Mn n f) lm rs"
+ "rec_calc_rel f (lm @ [rs]) 0"
+ "\<forall>x<rs. (\<exists> v. rec_calc_rel f (lm @ [x]) v \<and> 0 < v)"
+ "n = length lm"
+ "x \<le> rs"
+ shows "\<exists>stp. abc_steps_l (0, lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stp = (0, lm @ x # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+apply(insert h, induct x,
+ rule_tac x = 0 in exI, simp add: abc_steps_zero, simp)
+proof -
+ fix x
+ assume k1:
+ "\<exists>stp. abc_steps_l (0, lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stp = (0, lm @ x # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ and k2: "rec_ci (Mn (length lm) f) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Mn (length lm) f) lm rs"
+ "rec_calc_rel f (lm @ [rs]) 0"
+ "\<forall>x<rs.(\<exists> v. rec_calc_rel f (lm @ [x]) v \<and> v > 0)"
+ "n = length lm"
+ "Suc x \<le> rs"
+ "rec_ci f = (a, aa, ba)"
+ hence k2:
+ "\<exists>stp. abc_steps_l (0, lm @ x # 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm) aprog
+ stp = (0, lm @ Suc x # 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ apply(erule_tac x = x in allE)
+ apply(auto)
+ apply(rule_tac x = x in mn_ind_step)
+ apply(rule_tac ind, auto)
+ done
+ from k1 and k2 show
+ "\<exists>stp. abc_steps_l (0, lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stp = (0, lm @ Suc x # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ apply(auto)
+ apply(rule_tac x = "stp + stpa" in exI, simp only: abc_steps_add)
+ done
+qed
+
+lemma [simp]:
+"\<lbrakk>rec_ci f = (a, aa, ba);
+ rec_ci (Mn n f) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Mn n f) lm rs;
+ length lm = n\<rbrakk>
+ \<Longrightarrow> abc_lm_v (lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm) (Suc n) = 0"
+apply(auto simp: abc_lm_v.simps nth_append)
+done
+
+lemma [simp]:
+ "\<lbrakk>rec_ci f = (a, aa, ba);
+ rec_ci (Mn n f) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Mn n f) lm rs;
+ length lm = n\<rbrakk>
+ \<Longrightarrow> abc_lm_s (lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm) (Suc n) 0 =
+ lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm"
+apply(auto simp: abc_lm_s.simps list_update_append)
+done
+
+lemma mn_length:
+ "\<lbrakk>rec_ci f = (a, aa, ba);
+ rec_ci (Mn n f) = (aprog, rs_pos, a_md)\<rbrakk>
+ \<Longrightarrow> length aprog = length a + 5"
+apply(simp add: rec_ci.simps, erule_tac conjE)
+apply(drule_tac eq_switch, drule_tac eq_switch, simp)
+done
+
+lemma mn_final_step:
+ assumes ind:
+ "\<And>aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>rec_ci f = (aprog, rs_pos, a_md);
+ rec_calc_rel f lm rs\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ and h: "rec_ci f = (a, aa, ba)"
+ "rec_ci (Mn n f) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Mn n f) lm rs"
+ "rec_calc_rel f (lm @ [rs]) 0"
+ shows "\<exists>stp. abc_steps_l (0, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stp = (length aprog, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+proof -
+ from h and ind have k1:
+ "\<exists>stp. abc_steps_l (0, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stp = (length a, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ thm mn_calc_f
+ apply(insert mn_calc_f[of f a aa ba n aprog
+ rs_pos a_md lm rs 0 suf_lm], simp)
+ apply(subgoal_tac "aa = Suc n", simp add: exponent_cons_iff)
+ apply(subgoal_tac "rs_pos = n", simp, simp)
+ done
+ from h have k2: "length lm = n"
+ apply(subgoal_tac "rs_pos = n")
+ apply(drule_tac f = "Mn n f" in para_pattern, simp, simp, simp)
+ done
+ from h and k2 have k3:
+ "\<exists>stp. abc_steps_l (length a, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stp = (length a + 5, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ apply(rule_tac x = "Suc 0" in exI,
+ simp add: abc_step_l.simps abc_steps_l.simps)
+ done
+ from h have k4: "length aprog = length a + 5"
+ apply(simp add: mn_length)
+ done
+ from k1 and k3 and k4 show "?thesis"
+ apply(auto)
+ apply(rule_tac x = "stp + stpa" in exI, simp add: abc_steps_add)
+ done
+qed
+
+lemma mn_case:
+ assumes ind:
+ "\<And>aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>rec_ci f = (aprog, rs_pos, a_md); rec_calc_rel f lm rs\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ and h: "rec_ci (Mn n f) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Mn n f) lm rs"
+ shows "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp
+ = (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+apply(case_tac "rec_ci f", simp)
+apply(insert h, rule_tac calc_mn_reverse, simp)
+proof -
+ fix a b c v
+ assume h: "rec_ci f = (a, b, c)"
+ "rec_ci (Mn n f) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Mn n f) lm rs"
+ "rec_calc_rel f (lm @ [rs]) 0"
+ "\<forall>x<rs. \<exists>v. rec_calc_rel f (lm @ [x]) v \<and> 0 < v"
+ "n = length lm"
+ hence k1:
+ "\<exists>stp. abc_steps_l (0, lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm) aprog
+ stp = (0, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ thm mn_ind_steps
+ apply(auto intro: mn_ind_steps ind)
+ done
+ from h have k2:
+ "\<exists>stp. abc_steps_l (0, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm) aprog
+ stp = (length aprog, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ apply(auto intro: mn_final_step ind)
+ done
+ from k1 and k2 show
+ "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ apply(auto, insert h)
+ apply(subgoal_tac "Suc rs_pos < a_md")
+ apply(rule_tac x = "stp + stpa" in exI,
+ simp only: abc_steps_add exponent_cons_iff, simp, simp)
+ done
+qed
+
+lemma z_rs: "rec_calc_rel z lm rs \<Longrightarrow> rs = 0"
+apply(rule_tac calc_z_reverse, auto)
+done
+
+lemma z_case:
+ "\<lbrakk>rec_ci z = (aprog, rs_pos, a_md); rec_calc_rel z lm rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+apply(simp add: rec_ci.simps rec_ci_z_def, auto)
+apply(rule_tac x = "Suc 0" in exI, simp add: abc_steps_l.simps
+ abc_fetch.simps abc_step_l.simps z_rs)
+done
+thm addition.simps
+
+thm addition.simps
+thm rec_ci_s_def
+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 [simp]: "wf addition_LE"
+by(simp add: wf_inv_image wf_lex_triple addition_LE_def)
+
+declare addition_inv.simps[simp del]
+
+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)
+apply(rule_tac x = "lm ! m" in exI, simp)
+done
+
+thm addition.simps
+
+lemma [simp]: "abc_fetch 0 (addition m n p) = Some (Dec m 4)"
+by(simp add: abc_fetch.simps addition.simps)
+
+lemma [simp]: "abc_fetch (Suc 0) (addition m n p) = Some (Inc n)"
+by(simp add: abc_fetch.simps addition.simps)
+
+lemma [simp]: "abc_fetch 2 (addition m n p) = Some (Inc p)"
+by(simp add: abc_fetch.simps addition.simps)
+
+lemma [simp]: "abc_fetch 3 (addition m n p) = Some (Goto 0)"
+by(simp add: abc_fetch.simps addition.simps)
+
+lemma [simp]: "abc_fetch 4 (addition m n p) = Some (Dec p 7)"
+by(simp add: abc_fetch.simps addition.simps)
+
+lemma [simp]: "abc_fetch 5 (addition m n p) = Some (Inc m)"
+by(simp add: abc_fetch.simps addition.simps)
+
+lemma [simp]: "abc_fetch 6 (addition m n p) = Some (Goto 4)"
+by(simp add: abc_fetch.simps addition.simps)
+
+lemma [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(case_tac x, simp, simp)
+apply(rule_tac x = nat in exI, simp add: list_update_swap
+ list_update_overwrite)
+done
+
+lemma [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 [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 [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 [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 [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 [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 addition_halt_lemma:
+ "\<lbrakk>m \<noteq> n; max m n < p; length lm > p; lm ! p = 0\<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"
+apply(rule allI, rule impI, simp add: abc_steps_ind)
+apply(case_tac "(abc_steps_l (0, lm) (addition m n p) na)", simp)
+apply(auto split:if_splits simp add: addition_inv.simps
+ abc_steps_zero)
+apply(simp_all add: abc_steps_l.simps abc_steps_zero)
+apply(auto simp add: addition_LE_def lex_triple_def lex_pair_def
+ abc_step_l.simps addition_inv.simps
+ abc_lm_v.simps abc_lm_s.simps nth_append
+ split: if_splits)
+apply(rule_tac x = x in exI, simp)
+done
+
+lemma addition_ex:
+ "\<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). as = 7"
+ "\<lambda> stp. (abc_steps_l (0, lm) (addition m n p) stp, m, p)"
+ "\<lambda> ((as, lm'), m, p). addition_inv (as, lm') m n p lm"],
+ simp add: abc_steps_zero addition_inv_init)
+apply(drule_tac addition_halt_lemma, simp, simp, simp,
+ simp, erule_tac exE)
+apply(rule_tac x = na in exI,
+ case_tac "(abc_steps_l (0, lm) (addition m n p) na)", auto)
+done
+
+lemma [simp]: "length (addition m n p) = 7"
+by (simp add: addition.simps)
+
+lemma [elim]: "addition 0 (Suc 0) 2 = [] \<Longrightarrow> RR"
+by(simp add: addition.simps)
+
+lemma [simp]: "(0\<^bsup>2\<^esup>)[0 := n] = [n, 0::nat]"
+apply(subgoal_tac "2 = Suc 1",
+ simp only: replicate.simps exponent_def)
+apply(auto)
+done
+
+lemma [simp]:
+ "\<exists>stp. abc_steps_l (0, n # 0\<^bsup>2\<^esup> @ suf_lm)
+ (addition 0 (Suc 0) 2 [+] [Inc (Suc 0)]) stp =
+ (8, n # Suc n # 0 # suf_lm)"
+apply(rule_tac bm = "n # n # 0 # suf_lm" in abc_append_exc2, auto)
+apply(insert addition_ex[of 0 "Suc 0" 2 "n # 0\<^bsup>2\<^esup> @ suf_lm"],
+ simp add: nth_append numeral_2_eq_2, erule_tac exE)
+apply(rule_tac x = stp in exI,
+ case_tac "(abc_steps_l (0, n # 0\<^bsup>2\<^esup> @ suf_lm)
+ (addition 0 (Suc 0) 2) stp)",
+ simp add: addition_inv.simps nth_append list_update_append numeral_2_eq_2)
+apply(simp add: nth_append numeral_2_eq_2, erule_tac exE)
+apply(rule_tac x = "Suc 0" in exI,
+ simp add: abc_steps_l.simps abc_fetch.simps
+ abc_steps_zero abc_step_l.simps abc_lm_s.simps abc_lm_v.simps)
+done
+
+lemma s_case:
+ "\<lbrakk>rec_ci s = (aprog, rs_pos, a_md); rec_calc_rel s lm rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+apply(simp add: rec_ci.simps rec_ci_s_def, auto)
+apply(rule_tac calc_s_reverse, auto)
+done
+
+lemma [simp]:
+ "\<lbrakk>n < length lm; lm ! n = rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0 # 0 #suf_lm)
+ (addition n (length lm) (Suc (length lm))) stp
+ = (7, lm @ rs # 0 # suf_lm)"
+apply(insert addition_ex[of n "length lm"
+ "Suc (length lm)" "lm @ 0 # 0 # suf_lm"])
+apply(simp add: nth_append, erule_tac exE)
+apply(rule_tac x = stp in exI)
+apply(case_tac "abc_steps_l (0, lm @ 0 # 0 # suf_lm) (addition n (length lm)
+ (Suc (length lm))) stp", simp)
+apply(simp add: addition_inv.simps)
+apply(insert nth_append[of lm "0 # 0 # suf_lm" "n"], simp)
+done
+
+lemma [simp]: "0\<^bsup>2\<^esup> = [0, 0::nat]"
+apply(auto simp: exponent_def numeral_2_eq_2)
+done
+
+lemma id_case:
+ "\<lbrakk>rec_ci (id m n) = (aprog, rs_pos, a_md);
+ rec_calc_rel (id m n) lm rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+apply(simp add: rec_ci.simps rec_ci_id.simps, auto)
+apply(rule_tac calc_id_reverse, simp, simp)
+done
+
+lemma list_tl_induct:
+ "\<lbrakk>P []; \<And>a list. P list \<Longrightarrow> P (list @ [a::'a])\<rbrakk> \<Longrightarrow>
+ P ((list::'a list))"
+apply(case_tac "length list", simp)
+proof -
+ fix nat
+ assume ind: "\<And>a list. P list \<Longrightarrow> P (list @ [a])"
+ and h: "length list = Suc nat" "P []"
+ from h show "P list"
+ proof(induct nat arbitrary: list, case_tac lista, simp, simp)
+ fix lista a listaa
+ from h show "P [a]"
+ by(insert ind[of "[]"], simp add: h)
+ next
+ fix nat list
+ assume nind: "\<And>list. \<lbrakk>length list = Suc nat; P []\<rbrakk> \<Longrightarrow> P list"
+ and g: "length (list:: 'a list) = Suc (Suc nat)"
+ from g show "P (list::'a list)"
+ apply(insert nind[of "butlast list"], simp add: h)
+ apply(insert ind[of "butlast list" "last list"], simp)
+ apply(subgoal_tac "butlast list @ [last list] = list", simp)
+ apply(case_tac "list::'a list", simp, simp)
+ done
+ qed
+qed
+
+thm list.induct
+
+lemma nth_eq_butlast_nth: "\<lbrakk>length ys > Suc k\<rbrakk> \<Longrightarrow>
+ ys ! k = butlast ys ! k"
+apply(subgoal_tac "\<exists> xs y. ys = xs @ [y]", auto simp: nth_append)
+apply(rule_tac x = "butlast ys" in exI, rule_tac x = "last ys" in exI)
+apply(case_tac "ys = []", simp, simp)
+done
+
+lemma [simp]:
+"\<lbrakk>\<forall>k<Suc (length list). rec_calc_rel ((list @ [a]) ! k) lm (ys ! k);
+ length ys = Suc (length list)\<rbrakk>
+ \<Longrightarrow> \<forall>k<length list. rec_calc_rel (list ! k) lm (butlast ys ! k)"
+apply(rule allI, rule impI)
+apply(erule_tac x = k in allE, simp add: nth_append)
+apply(subgoal_tac "ys ! k = butlast ys ! k", simp)
+apply(rule_tac nth_eq_butlast_nth, arith)
+done
+
+
+thm cn_merge_gs.simps
+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, simp)
+apply(case_tac a, simp add: abc_append_commute)
+done
+
+lemma cn_merge_gs_length:
+ "length (cn_merge_gs (map rec_ci list) pstr) =
+ (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci list. length ap) + 3 * length list "
+apply(induct list arbitrary: pstr, simp, simp)
+apply(case_tac "rec_ci a", simp)
+done
+
+lemma [simp]: "Suc n \<le> pstr \<Longrightarrow> pstr + x - n > 0"
+by arith
+
+lemma [simp]:
+ "\<lbrakk>Suc (pstr + length list) \<le> a_md;
+ length ys = Suc (length list);
+ length lm = n;
+ Suc n \<le> pstr\<rbrakk>
+ \<Longrightarrow> (ys ! length list # 0\<^bsup>pstr - Suc n\<^esup> @ butlast ys @
+ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm) !
+ (pstr + length list - n) = (0 :: nat)"
+apply(insert nth_append[of "ys ! length list # 0\<^bsup>pstr - Suc n\<^esup> @
+ butlast ys" "0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm"
+ "(pstr + length list - n)"], simp add: nth_append)
+done
+
+lemma [simp]:
+ "\<lbrakk>Suc (pstr + length list) \<le> a_md;
+ length ys = Suc (length list);
+ length lm = n;
+ Suc n \<le> pstr\<rbrakk>
+ \<Longrightarrow> (lm @ last ys # 0\<^bsup>pstr - Suc n\<^esup> @ butlast ys @
+ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm)[pstr + length list :=
+ last ys, n := 0] =
+ lm @ 0::nat\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - Suc (pstr + length list)\<^esup> @ suf_lm"
+apply(insert list_update_length[of
+ "lm @ last ys # 0\<^bsup>pstr - Suc n\<^esup> @ butlast ys" 0
+ "0\<^bsup>a_md - Suc (pstr + length list)\<^esup> @ suf_lm" "last ys"], simp)
+apply(simp add: exponent_cons_iff)
+apply(insert list_update_length[of "lm"
+ "last ys" "0\<^bsup>pstr - Suc n\<^esup> @ butlast ys @
+ last ys # 0\<^bsup>a_md - Suc (pstr + length list)\<^esup> @ suf_lm" 0], simp)
+apply(simp add: exponent_cons_iff)
+apply(case_tac "ys = []", simp_all add: append_butlast_last_id)
+done
+
+
+lemma cn_merge_gs_ex:
+ "\<lbrakk>\<And>x aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>x \<in> set gs; rec_ci x = (aprog, rs_pos, a_md);
+ rec_calc_rel x lm rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp
+ = (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm);
+ pstr + length gs\<le> a_md;
+ \<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k);
+ length ys = length gs; length lm = n;
+ pstr \<ge> Max (set (Suc n # map (\<lambda>(aprog, p, n). n) (map rec_ci gs)))\<rbrakk>
+ \<Longrightarrow> \<exists> stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - n\<^esup> @ suf_lm)
+ (cn_merge_gs (map rec_ci gs) pstr) stp
+ = (listsum (map ((\<lambda>(ap, pos, n). length ap) \<circ> rec_ci) gs) +
+ 3 * length gs, lm @ 0\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - (pstr + length gs)\<^esup> @ suf_lm)"
+apply(induct gs arbitrary: ys rule: list_tl_induct)
+apply(simp add: exponent_add_iff, simp)
+proof -
+ fix a list ys
+ assume ind: "\<And>x aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>x = a \<or> x \<in> set list; rec_ci x = (aprog, rs_pos, a_md);
+ rec_calc_rel x lm rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ and ind2:
+ "\<And>ys. \<lbrakk>\<And>x aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>x \<in> set list; rec_ci x = (aprog, rs_pos, a_md);
+ rec_calc_rel x lm rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp
+ = (length aprog, lm @ rs # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm);
+ \<forall>k<length list. rec_calc_rel (list ! k) lm (ys ! k);
+ length ys = length list\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - n\<^esup> @ suf_lm)
+ (cn_merge_gs (map rec_ci list) pstr) stp =
+ (listsum (map ((\<lambda>(ap, pos, n). length ap) \<circ> rec_ci) list) +
+ 3 * length list,
+ lm @ 0\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm)"
+ and h: "Suc (pstr + length list) \<le> a_md"
+ "\<forall>k<Suc (length list).
+ rec_calc_rel ((list @ [a]) ! k) lm (ys ! k)"
+ "length ys = Suc (length list)"
+ "length lm = n"
+ "Suc n \<le> pstr \<and> (\<lambda>(aprog, p, n). n) (rec_ci a) \<le> pstr \<and>
+ (\<forall>a\<in>set list. (\<lambda>(aprog, p, n). n) (rec_ci a) \<le> pstr)"
+ from h have k1:
+ "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - n\<^esup> @ suf_lm)
+ (cn_merge_gs (map rec_ci list) pstr) stp =
+ (listsum (map ((\<lambda>(ap, pos, n). length ap) \<circ> rec_ci) list) +
+ 3 * length list, lm @ 0\<^bsup>pstr - n\<^esup> @ butlast ys @
+ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm) "
+ apply(rule_tac ind2)
+ apply(rule_tac ind, auto)
+ done
+ from k1 and h show
+ "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - n\<^esup> @ suf_lm)
+ (cn_merge_gs (map rec_ci list @ [rec_ci a]) pstr) stp =
+ (listsum (map ((\<lambda>(ap, pos, n). length ap) \<circ> rec_ci) list) +
+ (\<lambda>(ap, pos, n). length ap) (rec_ci a) + (3 + 3 * length list),
+ lm @ 0\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - Suc (pstr + length list)\<^esup> @ suf_lm)"
+ apply(simp add: cn_merge_gs_tl_app)
+ thm abc_append_exc2
+ apply(rule_tac as =
+ "(\<Sum>(ap, pos, n)\<leftarrow>map rec_ci list. length ap) + 3 * length list"
+ and bm = "lm @ 0\<^bsup>pstr - n\<^esup> @ butlast ys @
+ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm"
+ and bs = "(\<lambda>(ap, pos, n). length ap) (rec_ci a) + 3"
+ and bm' = "lm @ 0\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - Suc (pstr + length list)\<^esup> @
+ suf_lm" in abc_append_exc2, simp)
+ apply(simp add: cn_merge_gs_length)
+ proof -
+ from h show
+ "\<exists>bstp. abc_steps_l (0, lm @ 0\<^bsup>pstr - n\<^esup> @ butlast ys @
+ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm)
+ ((\<lambda>(gprog, gpara, gn). gprog [+] recursive.empty gpara
+ (pstr + length list)) (rec_ci a)) bstp =
+ ((\<lambda>(ap, pos, n). length ap) (rec_ci a) + 3,
+ lm @ 0\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - Suc (pstr + length list)\<^esup> @ suf_lm)"
+ apply(case_tac "rec_ci a", simp)
+ apply(rule_tac as = "length aa" and
+ bm = "lm @ (ys ! (length list)) #
+ 0\<^bsup>pstr - Suc n\<^esup> @ butlast ys @ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm"
+ and bs = "3" and bm' = "lm @ 0\<^bsup>pstr - n\<^esup> @ ys @
+ 0\<^bsup>a_md - Suc (pstr + length list)\<^esup> @ suf_lm" in abc_append_exc2)
+ proof -
+ fix aa b c
+ assume g: "rec_ci a = (aa, b, c)"
+ from h and g have k2: "b = n"
+ apply(erule_tac x = "length list" in allE, simp)
+ apply(subgoal_tac "length lm = b", simp)
+ apply(rule para_pattern, simp, simp)
+ done
+ from h and g and this show
+ "\<exists>astp. abc_steps_l (0, lm @ 0\<^bsup>pstr - n\<^esup> @ butlast ys @
+ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm) aa astp =
+ (length aa, lm @ ys ! length list # 0\<^bsup>pstr - Suc n\<^esup> @
+ butlast ys @ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm)"
+ apply(subgoal_tac "c \<ge> Suc n")
+ apply(insert ind[of a aa b c lm "ys ! length list"
+ "0\<^bsup>pstr - c\<^esup> @ butlast ys @ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm"], simp)
+ apply(erule_tac x = "length list" in allE,
+ simp add: exponent_add_iff)
+ apply(rule_tac Suc_leI, rule_tac ci_ad_ge_paras, simp)
+ done
+ next
+ fix aa b c
+ show "length aa = length aa" by simp
+ next
+ fix aa b c
+ assume "rec_ci a = (aa, b, c)"
+ from h and this show
+ "\<exists>bstp. abc_steps_l (0, lm @ ys ! length list #
+ 0\<^bsup>pstr - Suc n\<^esup> @ butlast ys @ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm)
+ (recursive.empty b (pstr + length list)) bstp =
+ (3, lm @ 0\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - Suc (pstr + length list)\<^esup> @ suf_lm)"
+ apply(insert empty_ex [of b "pstr + length list"
+ "lm @ ys ! length list # 0\<^bsup>pstr - Suc n\<^esup> @ butlast ys @
+ 0\<^bsup>a_md - (pstr + length list)\<^esup> @ suf_lm"], simp)
+ apply(subgoal_tac "b = n")
+ apply(simp add: nth_append split: if_splits)
+ apply(erule_tac x = "length list" in allE, simp)
+ apply(drule para_pattern, simp, simp)
+ done
+ next
+ fix aa b c
+ show "3 = length (recursive.empty b (pstr + length list))"
+ by simp
+ next
+ fix aa b aaa ba
+ show "length aa + 3 = length aa + 3" by simp
+ next
+ fix aa b c
+ show "empty b (pstr + length list) \<noteq> []"
+ by(simp add: empty.simps)
+ qed
+ next
+ show "(\<lambda>(ap, pos, n). length ap) (rec_ci a) + 3 =
+ length ((\<lambda>(gprog, gpara, gn). gprog [+]
+ recursive.empty gpara (pstr + length list)) (rec_ci a))"
+ by(case_tac "rec_ci a", simp)
+ next
+ show "listsum (map ((\<lambda>(ap, pos, n). length ap) \<circ> rec_ci) list) +
+ (\<lambda>(ap, pos, n). length ap) (rec_ci a) + (3 + 3 * length list)=
+ (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci list. length ap) + 3 * length list +
+ ((\<lambda>(ap, pos, n). length ap) (rec_ci a) + 3)" by simp
+ next
+ show "(\<lambda>(gprog, gpara, gn). gprog [+]
+ recursive.empty gpara (pstr + length list)) (rec_ci a) \<noteq> []"
+ by(case_tac "rec_ci a",
+ simp add: abc_append.simps abc_shift.simps)
+ qed
+qed
+
+declare drop_abc_lm_v_simp[simp del]
+
+lemma [simp]: "length (mv_boxes aa ba n) = 3*n"
+by(induct n, auto simp: mv_boxes.simps)
+
+lemma exp_suc: "a\<^bsup>Suc b\<^esup> = a\<^bsup>b\<^esup> @ [a]"
+by(simp add: exponent_def rep_ind del: replicate.simps)
+
+lemma [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 [simp]: "length lm1 = aa \<Longrightarrow>
+ (lm1 @ 0\<^bsup>n\<^esup> @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4) ! (aa + n) = last lm2"
+apply(simp add: nth_append)
+done
+
+lemma [simp]: "\<lbrakk>Suc n \<le> ba - aa; aa < ba\<rbrakk> \<Longrightarrow>
+ (ba < Suc (aa + (ba - Suc (aa + n) + n))) = False"
+apply arith
+done
+
+lemma [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\<^bsup>n\<^esup> @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4) ! (ba + n) = 0"
+using nth_append[of "lm1 @ 0\<Colon>'a\<^bsup>n\<^esup> @ last lm2 # lm3 @ butlast lm2"
+ "(0\<Colon>'a) # lm4" "ba + n"]
+apply(simp)
+done
+
+lemma [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\<^bsup>n\<^esup> @ last lm2 # lm3 @ butlast lm2 @ (0::nat) # lm4)
+ [ba + n := last lm2, aa + n := 0] =
+ lm1 @ 0 # 0\<^bsup>n\<^esup> @ lm3 @ lm2 @ lm4"
+using list_update_append[of "lm1 @ 0\<^bsup>n\<^esup> @ last lm2 # lm3 @ butlast lm2" "0 # lm4"
+ "ba + n" "last lm2"]
+apply(simp)
+apply(simp add: list_update_append)
+apply(simp only: exponent_cons_iff exp_suc, simp)
+apply(case_tac lm2, simp, simp)
+done
+
+
+lemma mv_boxes_ex:
+ "\<lbrakk>n \<le> ba - aa; ba > aa; length lm1 = aa;
+ length (lm2::nat list) = n; length lm3 = ba - aa - n\<rbrakk>
+ \<Longrightarrow> \<exists> stp. abc_steps_l (0, lm1 @ lm2 @ lm3 @ 0\<^bsup>n\<^esup> @ lm4)
+ (mv_boxes aa ba n) stp = (3 * n, lm1 @ 0\<^bsup>n\<^esup> @ lm3 @ lm2 @ lm4)"
+apply(induct n arbitrary: lm2 lm3 lm4, simp)
+apply(rule_tac x = 0 in exI, simp add: abc_steps_zero,
+ simp add: mv_boxes.simps del: exp_suc_iff)
+apply(rule_tac as = "3 *n" and bm = "lm1 @ 0\<^bsup>n\<^esup> @ last lm2 # lm3 @
+ butlast lm2 @ 0 # lm4" in abc_append_exc2, simp_all)
+apply(simp only: exponent_cons_iff, simp only: exp_suc, simp)
+proof -
+ fix n lm2 lm3 lm4
+ assume ind:
+ "\<And>lm2 lm3 lm4. \<lbrakk>length lm2 = n; length lm3 = ba - (aa + n)\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm1 @ lm2 @ lm3 @ 0\<^bsup>n\<^esup> @ lm4)
+ (mv_boxes aa ba n) stp = (3 * n, lm1 @ 0\<^bsup>n\<^esup> @ lm3 @ lm2 @ lm4)"
+ and h: "Suc n \<le> ba - aa" "aa < ba" "length (lm1::nat list) = aa"
+ "length (lm2::nat list) = Suc n"
+ "length (lm3::nat list) = ba - Suc (aa + n)"
+ from h show
+ "\<exists>astp. abc_steps_l (0, lm1 @ lm2 @ lm3 @ 0\<^bsup>n\<^esup> @ 0 # lm4)
+ (mv_boxes aa ba n) astp =
+ (3 * n, lm1 @ 0\<^bsup>n\<^esup> @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4)"
+ apply(insert ind[of "butlast lm2" "last lm2 # lm3" "0 # lm4"],
+ simp)
+ apply(subgoal_tac "lm1 @ butlast lm2 @ last lm2 # lm3 @ 0\<^bsup>n\<^esup> @
+ 0 # lm4 = lm1 @ lm2 @ lm3 @ 0\<^bsup>n\<^esup> @ 0 # lm4", simp, simp)
+ apply(case_tac "lm2 = []", simp, simp)
+ done
+next
+ fix n lm2 lm3 lm4
+ assume h: "Suc n \<le> ba - aa"
+ "aa < ba"
+ "length (lm1::nat list) = aa"
+ "length (lm2::nat list) = Suc n"
+ "length (lm3::nat list) = ba - Suc (aa + n)"
+ thus " \<exists>bstp. abc_steps_l (0, lm1 @ 0\<^bsup>n\<^esup> @ last lm2 # lm3 @
+ butlast lm2 @ 0 # lm4)
+ (recursive.empty (aa + n) (ba + n)) bstp
+ = (3, lm1 @ 0 # 0\<^bsup>n\<^esup> @ lm3 @ lm2 @ lm4)"
+ apply(insert empty_ex[of "aa + n" "ba + n"
+ "lm1 @ 0\<^bsup>n\<^esup> @ last lm2 # lm3 @ butlast lm2 @ 0 # lm4"], simp)
+ done
+qed
+(*
+lemma [simp]: "\<lbrakk>Suc n \<le> aa - ba;
+ ba < aa;
+ length lm2 = aa - Suc (ba + n)\<rbrakk>
+ \<Longrightarrow> ((0::nat) # lm2 @ 0\<^bsup>n\<^esup> @ last lm3 # lm4) ! (aa - ba)
+ = last lm3"
+proof -
+ assume h: "Suc n \<le> aa - ba"
+ and g: " ba < aa" "length lm2 = aa - Suc (ba + n)"
+ from h and g have k: "aa - ba = Suc (length lm2 + n)"
+ by arith
+ thus "((0::nat) # lm2 @ 0\<^bsup>n\<^esup> @ last lm3 # lm4) ! (aa - ba) = last lm3"
+ apply(simp, simp add: nth_append)
+ done
+qed
+*)
+
+lemma [simp]: "\<lbrakk>Suc n \<le> aa - ba; ba < aa; length lm1 = ba;
+ length lm2 = aa - Suc (ba + n); length lm3 = Suc n\<rbrakk>
+ \<Longrightarrow> (lm1 @ butlast lm3 @ 0 # lm2 @ 0\<^bsup>n\<^esup> @ last lm3 # lm4) ! (aa + n) = last lm3"
+using nth_append[of "lm1 @ butlast lm3 @ 0 # lm2 @ 0\<^bsup>n\<^esup>" "last lm3 # lm4" "aa + n"]
+apply(simp)
+done
+
+lemma [simp]: "\<lbrakk>Suc n \<le> aa - ba; ba < aa; length lm1 = ba;
+ length lm2 = aa - Suc (ba + n); length lm3 = Suc n\<rbrakk>
+ \<Longrightarrow> (lm1 @ butlast lm3 @ 0 # lm2 @ 0\<^bsup>n\<^esup> @ last lm3 # lm4) ! (ba + n) = 0"
+apply(simp add: nth_append)
+done
+
+
+lemma [simp]: "\<lbrakk>Suc n \<le> aa - ba; ba < aa; length lm1 = ba;
+ length lm2 = aa - Suc (ba + n); length lm3 = Suc n\<rbrakk>
+ \<Longrightarrow> (lm1 @ butlast lm3 @ 0 # lm2 @ 0\<^bsup>n\<^esup> @ last lm3 # lm4)[ba + n := last lm3, aa + n := 0]
+ = lm1 @ lm3 @ lm2 @ 0 # 0\<^bsup>n\<^esup> @ lm4"
+using list_update_append[of "lm1 @ butlast lm3" "(0\<Colon>'a) # lm2 @ 0\<Colon>'a\<^bsup>n\<^esup> @ last lm3 # lm4"]
+apply(simp)
+using list_update_append[of "lm1 @ butlast lm3 @ last lm3 # lm2 @ 0\<Colon>'a\<^bsup>n\<^esup>"
+ "last lm3 # lm4" "aa + n" "0"]
+apply(simp)
+apply(simp only: exp_ind_def[THEN sym] exp_suc, simp)
+apply(case_tac lm3, simp, simp)
+done
+
+
+lemma mv_boxes_ex2:
+ "\<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> \<exists> stp. abc_steps_l (0, lm1 @ 0\<^bsup>n\<^esup> @ lm2 @ lm3 @ lm4)
+ (mv_boxes aa ba n) stp =
+ (3 * n, lm1 @ lm3 @ lm2 @ 0\<^bsup>n\<^esup> @ lm4)"
+apply(induct n arbitrary: lm2 lm3 lm4, simp)
+apply(rule_tac x = 0 in exI, simp add: abc_steps_zero,
+ simp add: mv_boxes.simps del: exp_suc_iff)
+apply(rule_tac as = "3 *n" and bm = "lm1 @ butlast lm3 @ 0 # lm2 @
+ 0\<^bsup>n\<^esup> @ last lm3 # lm4" in abc_append_exc2, simp_all)
+apply(simp only: exponent_cons_iff, simp only: exp_suc, simp)
+proof -
+ fix n lm2 lm3 lm4
+ assume ind:
+"\<And>lm2 lm3 lm4. \<lbrakk>length lm2 = aa - (ba + n); length lm3 = n\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm1 @ 0\<^bsup>n\<^esup> @ lm2 @ lm3 @ lm4)
+ (mv_boxes aa ba n) stp =
+ (3 * n, lm1 @ lm3 @ lm2 @ 0\<^bsup>n\<^esup> @ lm4)"
+ and h: "Suc n \<le> aa - ba"
+ "ba < aa"
+ "length (lm1::nat list) = ba"
+ "length (lm2::nat list) = aa - Suc (ba + n)"
+ "length (lm3::nat list) = Suc n"
+ from h show
+ "\<exists>astp. abc_steps_l (0, lm1 @ 0\<^bsup>n\<^esup> @ 0 # lm2 @ lm3 @ lm4)
+ (mv_boxes aa ba n) astp =
+ (3 * n, lm1 @ butlast lm3 @ 0 # lm2 @ 0\<^bsup>n\<^esup> @ last lm3 # lm4)"
+ apply(insert ind[of "0 # lm2" "butlast lm3" "last lm3 # lm4"],
+ simp)
+ apply(subgoal_tac
+ "lm1 @ 0\<^bsup>n\<^esup> @ 0 # lm2 @ butlast lm3 @ last lm3 # lm4 =
+ lm1 @ 0\<^bsup>n\<^esup> @ 0 # lm2 @ lm3 @ lm4", simp, simp)
+ apply(case_tac "lm3 = []", simp, simp)
+ done
+next
+ fix n lm2 lm3 lm4
+ assume h:
+ "Suc n \<le> aa - ba"
+ "ba < aa"
+ "length lm1 = ba"
+ "length (lm2::nat list) = aa - Suc (ba + n)"
+ "length (lm3::nat list) = Suc n"
+ thus
+ "\<exists>bstp. abc_steps_l (0, lm1 @ butlast lm3 @ 0 # lm2 @ 0\<^bsup>n\<^esup> @
+ last lm3 # lm4)
+ (recursive.empty (aa + n) (ba + n)) bstp =
+ (3, lm1 @ lm3 @ lm2 @ 0 # 0\<^bsup>n\<^esup> @ lm4)"
+ apply(insert empty_ex[of "aa + n" "ba + n" "lm1 @ butlast lm3 @
+ 0 # lm2 @ 0\<^bsup>n\<^esup> @ last lm3 # lm4"], simp)
+ done
+qed
+
+lemma cn_merge_gs_len:
+ "length (cn_merge_gs (map rec_ci gs) pstr) =
+ (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 3 * length gs"
+apply(induct gs arbitrary: pstr, simp, simp)
+apply(case_tac "rec_ci a", simp)
+done
+
+lemma [simp]: "n < pstr \<Longrightarrow>
+ Suc (pstr + length ys - n) = Suc (pstr + length ys) - n"
+by arith
+
+lemma save_paras':
+ "\<lbrakk>length lm = n; pstr > n; a_md > pstr + length ys + n\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>pstr - n\<^esup> @ ys @
+ 0\<^bsup>a_md - pstr - length ys\<^esup> @ suf_lm)
+ (mv_boxes 0 (pstr + Suc (length ys)) n) stp
+ = (3 * n, 0\<^bsup>pstr\<^esup> @ ys @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+thm mv_boxes_ex
+apply(insert mv_boxes_ex[of n "pstr + Suc (length ys)" 0 "[]" "lm"
+ "0\<^bsup>pstr - n\<^esup> @ ys @ [0]" "0\<^bsup>a_md - pstr - length ys - n - Suc 0\<^esup> @ suf_lm"], simp)
+apply(erule_tac exE, rule_tac x = stp in exI,
+ simp add: exponent_add_iff)
+apply(simp only: exponent_cons_iff, simp)
+done
+
+lemma [simp]:
+ "(max ba (Max (insert ba (((\<lambda>(aprog, p, n). n) o rec_ci) ` set gs))))
+ = (Max (insert ba (((\<lambda>(aprog, p, n). n) o rec_ci) ` set gs)))"
+apply(rule min_max.sup_absorb2, auto)
+done
+
+lemma [simp]:
+ "((\<lambda>(aprog, p, n). n) ` rec_ci ` set gs) =
+ (((\<lambda>(aprog, p, n). n) o rec_ci) ` set gs)"
+apply(induct gs)
+apply(simp, simp)
+done
+
+lemma ci_cn_md_def:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_ci f = (a, aa, ba)\<rbrakk>
+ \<Longrightarrow> a_md = max (Suc n) (Max (insert ba (((\<lambda>(aprog, p, n). n) o
+ rec_ci) ` set gs))) + Suc (length gs) + n"
+apply(simp add: rec_ci.simps, auto)
+done
+
+lemma save_paras_prog_ex:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_ci f = (a, aa, ba);
+ pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))\<rbrakk>
+ \<Longrightarrow> \<exists>ap bp cp.
+ aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 3 * length gs \<and> bp = mv_boxes 0 (pstr + Suc (length gs)) n"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x =
+ "cn_merge_gs (map rec_ci gs) (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) o rec_ci) ` set gs))))" in exI,
+ simp add: cn_merge_gs_len)
+apply(rule_tac x =
+ "mv_boxes (max (Suc n) (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))))
+ 0 (length gs) [+] a [+]recursive.empty aa (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ empty_boxes (length gs) [+] recursive.empty (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) n [+]
+ mv_boxes (Suc (max (Suc n) (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci)
+ ` set gs))) + length gs)) 0 n" in exI, auto)
+apply(simp add: abc_append_commute)
+done
+
+lemma save_paras:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rs_pos = n;
+ \<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k);
+ length ys = length gs;
+ length lm = n;
+ rec_ci f = (a, aa, ba);
+ pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 3 * length gs, lm @ 0\<^bsup>pstr - n\<^esup> @ ys @
+ 0\<^bsup>a_md - pstr - length ys\<^esup> @ suf_lm) aprog stp =
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 3 * length gs + 3 * n,
+ 0\<^bsup>pstr\<^esup> @ ys @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+proof -
+ assume h:
+ "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "rs_pos = n"
+ "\<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k)"
+ "length ys = length gs"
+ "length lm = n"
+ "rec_ci f = (a, aa, ba)"
+ and g: "pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))"
+ from h and g have k1:
+ "\<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 3 *length gs \<and> bp = mv_boxes 0 (pstr + Suc (length ys)) n"
+ apply(drule_tac save_paras_prog_ex, auto)
+ done
+ from h have k2:
+ "\<exists> stp. abc_steps_l (0, lm @ 0\<^bsup>pstr - n\<^esup> @ ys @
+ 0\<^bsup>a_md - pstr - length ys\<^esup> @ suf_lm)
+ (mv_boxes 0 (pstr + Suc (length ys)) n) stp =
+ (3 * n, 0\<^bsup>pstr\<^esup> @ ys @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+ apply(rule_tac save_paras', simp, simp_all add: g)
+ apply(drule_tac a = a and aa = aa and ba = ba in
+ ci_cn_md_def, simp, simp)
+ done
+ from k1 show
+ "\<exists>stp. abc_steps_l ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 3 * length gs, lm @ 0\<^bsup>pstr - n\<^esup> @ ys @
+ 0\<^bsup>a_md - pstr - length ys\<^esup> @ suf_lm) aprog stp =
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 3 * length gs + 3 * n,
+ 0\<^bsup>pstr\<^esup> @ ys @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+ proof(erule_tac exE, erule_tac exE, erule_tac exE, erule_tac exE)
+ fix ap bp apa cp
+ assume "aprog = ap [+] bp [+] cp \<and> length ap =
+ (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 3 * length gs
+ \<and> bp = mv_boxes 0 (pstr + Suc (length ys)) n"
+ from this and k2 show "?thesis"
+ apply(simp)
+ apply(rule_tac abc_append_exc1, simp, simp, simp)
+ done
+ qed
+qed
+
+lemma ci_cn_para_eq:
+ "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md) \<Longrightarrow> rs_pos = n"
+apply(simp add: rec_ci.simps, case_tac "rec_ci f", simp)
+done
+
+lemma calc_gs_prog_ex:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_ci f = (a, aa, ba);
+ Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs)))) = pstr\<rbrakk>
+ \<Longrightarrow> \<exists>ap bp. aprog = ap [+] bp \<and>
+ ap = cn_merge_gs (map rec_ci gs) pstr"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "mv_boxes 0 (Suc (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) + length gs)) n [+]
+ mv_boxes (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) 0 (length gs) [+]
+ a [+] recursive.empty aa (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ empty_boxes (length gs) [+] recursive.empty (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) n [+]
+ mv_boxes (Suc (max (Suc n) (Max
+ (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) + length gs)) 0 n"
+ in exI)
+apply(auto simp: abc_append_commute)
+done
+
+lemma cn_calc_gs:
+ assumes ind:
+ "\<And>x aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>x \<in> set gs;
+ rec_ci x = (aprog, rs_pos, a_md);
+ rec_calc_rel x lm rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ and h: "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "\<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k)"
+ "length ys = length gs"
+ "length lm = n"
+ "rec_ci f = (a, aa, ba)"
+ "Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs)))) = pstr"
+ shows
+ "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 3 * length gs,
+ lm @ 0\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md -pstr - length ys\<^esup> @ suf_lm) "
+proof -
+ from h have k1:
+ "\<exists> ap bp. aprog = ap [+] bp \<and> ap =
+ cn_merge_gs (map rec_ci gs) pstr"
+ by(erule_tac calc_gs_prog_ex, auto)
+ from h have j1: "rs_pos = n"
+ by(simp add: ci_cn_para_eq)
+ from h have j2: "a_md \<ge> pstr"
+ by(drule_tac a = a and aa = aa and ba = ba in
+ ci_cn_md_def, simp, simp)
+ from h have j3: "pstr > n"
+ by(auto)
+ from j1 and j2 and j3 and h have k2:
+ "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm)
+ (cn_merge_gs (map rec_ci gs) pstr) stp
+ = ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 3 * length gs,
+ lm @ 0\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - pstr - length ys\<^esup> @ suf_lm)"
+ apply(simp)
+ apply(rule_tac cn_merge_gs_ex, rule_tac ind, simp, simp, auto)
+ apply(drule_tac a = a and aa = aa and ba = ba in
+ ci_cn_md_def, simp, simp)
+ apply(rule min_max.le_supI2, auto)
+ done
+ from k1 show "?thesis"
+ proof(erule_tac exE, erule_tac exE, simp)
+ fix ap bp
+ from k2 show
+ "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm)
+ (cn_merge_gs (map rec_ci gs) pstr [+] bp) stp =
+ (listsum (map ((\<lambda>(ap, pos, n). length ap) \<circ> rec_ci) gs) +
+ 3 * length gs,
+ lm @ 0\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - (pstr + length ys)\<^esup> @ suf_lm)"
+ apply(insert abc_append_exc1[of
+ "lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm"
+ "(cn_merge_gs (map rec_ci gs) pstr)"
+ "length (cn_merge_gs (map rec_ci gs) pstr)"
+ "lm @ 0\<^bsup>pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - pstr - length ys\<^esup> @ suf_lm" 0
+ "[]" bp], simp add: cn_merge_gs_len)
+ done
+ qed
+qed
+
+lemma reset_new_paras':
+ "\<lbrakk>length lm = n;
+ pstr > 0;
+ a_md \<ge> pstr + length ys + n;
+ pstr > length ys\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, 0\<^bsup>pstr\<^esup> @ ys @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @
+ suf_lm) (mv_boxes pstr 0 (length ys)) stp =
+ (3 * length ys, ys @ 0\<^bsup>pstr\<^esup> @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+thm mv_boxes_ex2
+apply(insert mv_boxes_ex2[of "length ys" "pstr" 0 "[]"
+ "0\<^bsup>pstr - length ys\<^esup>" "ys"
+ "0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm"],
+ simp add: exponent_add_iff)
+done
+
+lemma [simp]:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_calc_rel f ys rs; rec_ci f = (a, aa, ba);
+ pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))\<rbrakk>
+ \<Longrightarrow> length ys < pstr"
+apply(subgoal_tac "length ys = aa", simp)
+apply(subgoal_tac "aa < ba \<and> ba \<le> pstr",
+ rule basic_trans_rules(22), auto)
+apply(rule min_max.le_supI2)
+apply(auto)
+apply(erule_tac para_pattern, simp)
+done
+
+lemma reset_new_paras_prog_ex:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_ci f = (a, aa, ba);
+ Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs)))) = pstr\<rbrakk>
+ \<Longrightarrow> \<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 3 *length gs + 3 * n \<and> bp = mv_boxes pstr 0 (length gs)"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "cn_merge_gs (map rec_ci gs) (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ mv_boxes 0 (Suc (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) + length gs)) n" in exI,
+ simp add: cn_merge_gs_len)
+apply(rule_tac x = "a [+]
+ recursive.empty aa (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ empty_boxes (length gs) [+] recursive.empty
+ (max (Suc n) (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) n
+ [+] mv_boxes (Suc (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) + length gs)) 0 n" in exI,
+ auto simp: abc_append_commute)
+done
+
+
+lemma reset_new_paras:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rs_pos = n;
+ \<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k);
+ length ys = length gs;
+ length lm = n;
+ length ys = aa;
+ rec_ci f = (a, aa, ba);
+ pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))\<rbrakk>
+\<Longrightarrow> \<exists>stp. abc_steps_l ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 3 * length gs + 3 * n,
+ 0\<^bsup>pstr \<^esup>@ ys @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm) aprog stp =
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 6 * length gs + 3 * n,
+ ys @ 0\<^bsup>pstr\<^esup> @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+proof -
+ assume h:
+ "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "rs_pos = n"
+ "length ys = aa"
+ "\<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k)"
+ "length ys = length gs" "length lm = n"
+ "rec_ci f = (a, aa, ba)"
+ and g: "pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))"
+ thm rec_ci.simps
+ from h and g have k1:
+ "\<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and> length ap =
+ (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 3 *length gs + 3 * n \<and> bp = mv_boxes pstr 0 (length ys)"
+ by(drule_tac reset_new_paras_prog_ex, auto)
+ from h have k2:
+ "\<exists> stp. abc_steps_l (0, 0\<^bsup>pstr \<^esup>@ ys @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @
+ suf_lm) (mv_boxes pstr 0 (length ys)) stp =
+ (3 * (length ys),
+ ys @ 0\<^bsup>pstr\<^esup> @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+ apply(rule_tac reset_new_paras', simp)
+ apply(simp add: g)
+ apply(drule_tac a = a and aa = aa and ba = ba in ci_cn_md_def,
+ simp, simp add: g, simp)
+ apply(subgoal_tac "length gs = aa \<and> aa < ba \<and> ba \<le> pstr", arith,
+ simp add: para_pattern)
+ apply(insert g, auto intro: min_max.le_supI2)
+ done
+ from k1 show
+ "\<exists>stp. abc_steps_l ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 3
+ * length gs + 3 * n, 0\<^bsup>pstr\<^esup> @ ys @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @
+ suf_lm) aprog stp =
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 6 * length gs +
+ 3 * n, ys @ 0\<^bsup>pstr\<^esup> @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+ proof(erule_tac exE, erule_tac exE, erule_tac exE, erule_tac exE)
+ fix ap bp apa cp
+ assume "aprog = ap [+] bp [+] cp \<and> length ap =
+ (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 3 * length gs +
+ 3 * n \<and> bp = mv_boxes pstr 0 (length ys)"
+ from this and k2 show "?thesis"
+ apply(simp)
+ apply(drule_tac as =
+ "(\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 3 * length gs +
+ 3 * n" and ap = ap and cp = cp in abc_append_exc1, auto)
+ apply(rule_tac x = stp in exI, simp add: h)
+ using h
+ apply(simp)
+ done
+ qed
+qed
+
+thm rec_ci.simps
+
+lemma calc_f_prog_ex:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_ci f = (a, aa, ba);
+ Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs)))) = pstr\<rbrakk>
+ \<Longrightarrow> \<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 6 *length gs + 3 * n \<and> bp = a"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "cn_merge_gs (map rec_ci gs) (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ mv_boxes 0 (Suc (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) + length gs)) n [+]
+ mv_boxes (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) 0 (length gs)" in exI,
+ simp add: cn_merge_gs_len)
+apply(rule_tac x = "recursive.empty aa (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ empty_boxes (length gs) [+] recursive.empty (max (Suc n) (
+ Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) n [+]
+ mv_boxes (Suc (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) + length gs)) 0 n" in exI,
+ auto simp: abc_append_commute)
+done
+
+lemma calc_cn_f:
+ assumes ind:
+ "\<And>x aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>x \<in> set (f # gs);
+ rec_ci x = (aprog, rs_pos, a_md);
+ rec_calc_rel x lm rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ and h: "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Cn n f gs) lm rs"
+ "length ys = length gs"
+ "rec_calc_rel f ys rs"
+ "length lm = n"
+ "rec_ci f = (a, aa, ba)"
+ and p: "pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))"
+ shows "\<exists>stp. abc_steps_l
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 6 * length gs + 3 * n,
+ ys @ 0\<^bsup>pstr\<^esup> @ 0 # lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm) aprog stp =
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 6 * length gs +
+ 3 * n + length a,
+ ys @ rs # 0\<^bsup>pstr\<^esup> @ lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+proof -
+ from h have k1:
+ "\<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 6 *length gs + 3 * n \<and> bp = a"
+ by(drule_tac calc_f_prog_ex, auto)
+ from h and k1 show "?thesis"
+ proof (erule_tac exE, erule_tac exE, erule_tac exE, erule_tac exE)
+ fix ap bp apa cp
+ assume
+ "aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 6 * length gs + 3 * n \<and> bp = a"
+ from h and this show "?thesis"
+ apply(simp, rule_tac abc_append_exc1, simp_all)
+ apply(insert ind[of f "a" aa ba ys rs
+ "0\<^bsup>pstr - ba + length gs \<^esup> @ 0 # lm @
+ 0\<^bsup>a_md - Suc (pstr + length gs + n)\<^esup> @ suf_lm"], simp)
+ apply(subgoal_tac "ba > aa \<and> aa = length gs\<and> pstr \<ge> ba", simp)
+ apply(simp add: exponent_add_iff)
+ apply(case_tac pstr, simp add: p)
+ apply(simp only: exp_suc, simp)
+ apply(rule conjI, rule ci_ad_ge_paras, simp, rule conjI)
+ apply(subgoal_tac "length ys = aa", simp,
+ rule para_pattern, simp, simp)
+ apply(insert p, simp)
+ apply(auto intro: min_max.le_supI2)
+ done
+ qed
+qed
+(*
+lemma [simp]:
+ "\<lbrakk>pstr + length ys + n \<le> a_md; ys \<noteq> []\<rbrakk> \<Longrightarrow>
+ pstr < a_md + length suf_lm"
+apply(case_tac "length ys", simp)
+apply(arith)
+done
+*)
+lemma [simp]:
+ "pstr > length ys
+ \<Longrightarrow> (ys @ rs # 0\<^bsup>pstr\<^esup> @ lm @
+ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm) ! pstr = (0::nat)"
+apply(simp add: nth_append)
+done
+
+(*
+lemma [simp]: "\<lbrakk>length ys < pstr; pstr - length ys = Suc x\<rbrakk>
+ \<Longrightarrow> pstr - Suc (length ys) = x"
+by arith
+*)
+lemma [simp]: "pstr > length ys \<Longrightarrow>
+ (ys @ rs # 0\<^bsup>pstr\<^esup> @ lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)
+ [pstr := rs, length ys := 0] =
+ ys @ 0\<^bsup>pstr - length ys\<^esup> @ (rs::nat) # 0\<^bsup>length ys\<^esup> @ lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm"
+apply(auto simp: list_update_append)
+apply(case_tac "pstr - length ys",simp_all)
+using list_update_length[of
+ "0\<^bsup>pstr - Suc (length ys)\<^esup>" "0" "0\<^bsup>length ys\<^esup> @ lm @
+ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm" rs]
+apply(simp only: exponent_cons_iff exponent_add_iff, simp)
+apply(subgoal_tac "pstr - Suc (length ys) = nat", simp, simp)
+done
+
+lemma save_rs':
+ "\<lbrakk>pstr > length ys\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, ys @ rs # 0\<^bsup>pstr\<^esup> @ lm @
+ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)
+ (recursive.empty (length ys) pstr) stp =
+ (3, ys @ 0\<^bsup>pstr - (length ys)\<^esup> @ rs #
+ 0\<^bsup>length ys \<^esup> @ lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+apply(insert empty_ex[of "length ys" pstr
+ "ys @ rs # 0\<^bsup>pstr\<^esup> @ lm @ 0\<^bsup>a_md - Suc(pstr + length ys + n)\<^esup> @ suf_lm"],
+ simp)
+done
+
+
+lemma save_rs_prog_ex:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_ci f = (a, aa, ba);
+ Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs)))) = pstr\<rbrakk>
+ \<Longrightarrow> \<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 6 *length gs + 3 * n + length a
+ \<and> bp = empty aa pstr"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x =
+ "cn_merge_gs (map rec_ci gs) (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))))
+ [+] mv_boxes 0 (Suc (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) + length gs)) n [+]
+ mv_boxes (max (Suc n) (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))))
+ 0 (length gs) [+] a"
+ in exI, simp add: cn_merge_gs_len)
+apply(rule_tac x =
+ "empty_boxes (length gs) [+]
+ recursive.empty (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) n [+]
+ mv_boxes (Suc (max (Suc n) (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))
+ + length gs)) 0 n" in exI,
+ auto simp: abc_append_commute)
+done
+
+lemma save_rs:
+ assumes h:
+ "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Cn n f gs) lm rs"
+ "\<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k)"
+ "length ys = length gs"
+ "rec_calc_rel f ys rs"
+ "rec_ci f = (a, aa, ba)"
+ "length lm = n"
+ and pdef: "pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))"
+ shows "\<exists>stp. abc_steps_l
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 6 * length gs
+ + 3 * n + length a, ys @ rs # 0\<^bsup>pstr\<^esup> @ lm @
+ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm) aprog stp =
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 6 * length gs
+ + 3 * n + length a + 3,
+ ys @ 0\<^bsup>pstr - length ys \<^esup> @ rs # 0\<^bsup>length ys\<^esup> @ lm @
+ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+proof -
+ thm rec_ci.simps
+ from h and pdef have k1:
+ "\<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 6 *length gs + 3 * n + length a \<and> bp = empty (length ys) pstr "
+ apply(subgoal_tac "length ys = aa")
+ apply(drule_tac a = a and aa = aa and ba = ba in save_rs_prog_ex,
+ simp, simp, simp)
+ by(rule_tac para_pattern, simp, simp)
+ from k1 show
+ "\<exists>stp. abc_steps_l
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 6 * length gs + 3 * n
+ + length a, ys @ rs # 0\<^bsup>pstr \<^esup>@ lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup>
+ @ suf_lm) aprog stp =
+ ((\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 6 * length gs + 3 * n
+ + length a + 3, ys @ 0\<^bsup>pstr - length ys\<^esup> @ rs #
+ 0\<^bsup>length ys\<^esup> @ lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+ proof (erule_tac exE, erule_tac exE, erule_tac exE, erule_tac exE)
+ fix ap bp apa cp
+ assume "aprog = ap [+] bp [+] cp \<and> length ap =
+ (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) + 6 * length gs +
+ 3 * n + length a \<and> bp = recursive.empty (length ys) pstr"
+ thus"?thesis"
+ apply(simp, rule_tac abc_append_exc1, simp_all)
+ apply(rule_tac save_rs', insert h)
+ apply(subgoal_tac "length gs = aa \<and> pstr \<ge> ba \<and> ba > aa",
+ arith)
+ apply(simp add: para_pattern, insert pdef, auto)
+ apply(rule_tac min_max.le_supI2, simp)
+ done
+ qed
+qed
+
+lemma [simp]: "length (empty_boxes n) = 2*n"
+apply(induct n, simp, simp)
+done
+
+lemma empty_step_ex: "length lm = n \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, lm @ Suc x # suf_lm) [Dec n 2, Goto 0] stp
+ = (0, lm @ x # suf_lm)"
+apply(rule_tac x = "Suc (Suc 0)" in exI,
+ simp add: abc_steps_l.simps abc_step_l.simps abc_fetch.simps
+ abc_lm_v.simps abc_lm_s.simps nth_append list_update_append)
+done
+
+lemma empty_box_ex:
+ "\<lbrakk>length lm = n\<rbrakk> \<Longrightarrow>
+ \<exists> stp. abc_steps_l (0, lm @ x # suf_lm) [Dec n 2, Goto 0] stp =
+ (Suc (Suc 0), lm @ 0 # suf_lm)"
+apply(induct x)
+apply(rule_tac x = "Suc 0" in exI,
+ simp add: abc_steps_l.simps abc_fetch.simps abc_step_l.simps
+ abc_lm_v.simps nth_append abc_lm_s.simps, simp)
+apply(drule_tac x = x and suf_lm = suf_lm in empty_step_ex,
+ erule_tac exE, erule_tac exE)
+apply(rule_tac x = "stpa + stp" in exI, simp add: abc_steps_add)
+done
+
+lemma [simp]: "drop n lm = a # list \<Longrightarrow> list = drop (Suc n) lm"
+apply(induct n arbitrary: lm a list, simp)
+apply(case_tac "lm", simp, simp)
+done
+
+lemma empty_boxes_ex: "\<lbrakk>length lm \<ge> n\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm) (empty_boxes n) stp =
+ (2*n, 0\<^bsup>n\<^esup> @ drop n lm)"
+apply(induct n, simp, simp)
+apply(rule_tac abc_append_exc2, auto)
+apply(case_tac "drop n lm", simp, simp)
+proof -
+ fix n stp a list
+ assume h: "Suc n \<le> length lm" "drop n lm = a # list"
+ thus "\<exists>bstp. abc_steps_l (0, 0\<^bsup>n\<^esup> @ a # list) [Dec n 2, Goto 0] bstp =
+ (Suc (Suc 0), 0 # 0\<^bsup>n\<^esup> @ drop (Suc n) lm)"
+ apply(insert empty_box_ex[of "0\<^bsup>n\<^esup>" n a list], simp, erule_tac exE)
+ apply(rule_tac x = stp in exI, simp, simp only: exponent_cons_iff)
+ apply(simp add: exponent_def rep_ind del: replicate.simps)
+ done
+qed
+
+
+lemma empty_paras_prog_ex:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_ci f = (a, aa, ba);
+ Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs)))) = pstr\<rbrakk>
+ \<Longrightarrow> \<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 6 *length gs + 3 * n + length a + 3 \<and> bp = empty_boxes (length gs)"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "cn_merge_gs (map rec_ci gs) (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ mv_boxes 0 (Suc (max (Suc n) (Max
+ (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) + length gs)) n
+ [+] mv_boxes (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) 0 (length gs) [+]
+ a [+] recursive.empty aa (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))))"
+ in exI, simp add: cn_merge_gs_len)
+apply(rule_tac x = " recursive.empty (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) n [+]
+ mv_boxes (Suc (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) + length gs)) 0 n" in exI,
+ auto simp: abc_append_commute)
+done
+
+lemma empty_paras:
+ assumes h:
+ "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Cn n f gs) lm rs"
+ "\<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k)"
+ "length ys = length gs"
+ "rec_calc_rel f ys rs"
+ "rec_ci f = (a, aa, ba)"
+ and pdef: "pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))"
+ and starts: "ss = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 6 * length gs + 3 * n + length a + 3"
+ shows "\<exists>stp. abc_steps_l
+ (ss, ys @ 0\<^bsup>pstr - length ys\<^esup> @ rs # 0\<^bsup>length ys\<^esup>
+ @ lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm) aprog stp =
+ (ss + 2 * length gs, 0\<^bsup>pstr\<^esup> @ rs # 0\<^bsup>length ys \<^esup> @ lm @
+ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+proof -
+ from h and pdef and starts have k1:
+ "\<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 6 *length gs + 3 * n + length a + 3
+ \<and> bp = empty_boxes (length ys)"
+ by(drule_tac empty_paras_prog_ex, auto)
+ from h have j1: "aa < ba"
+ by(simp add: ci_ad_ge_paras)
+ from h have j2: "length gs = aa"
+ by(drule_tac f = f in para_pattern, simp, simp)
+ from h and pdef have j3: "ba \<le> pstr"
+ apply simp
+ apply(rule_tac min_max.le_supI2, simp)
+ done
+ from k1 show "?thesis"
+ proof (erule_tac exE, erule_tac exE, erule_tac exE, erule_tac exE)
+ fix ap bp apa cp
+ assume "aprog = ap [+] bp [+] cp \<and>
+ length ap = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 6 * length gs + 3 * n + length a + 3 \<and>
+ bp = empty_boxes (length ys)"
+ thus"?thesis"
+ apply(simp, rule_tac abc_append_exc1, simp_all add: starts h)
+ apply(insert empty_boxes_ex[of
+ "length gs" "ys @ 0\<^bsup>pstr - (length gs)\<^esup> @ rs #
+ 0\<^bsup>length gs\<^esup> @ lm @ 0\<^bsup>a_md - Suc (pstr + length gs + n)\<^esup> @ suf_lm"],
+ simp add: h)
+ apply(erule_tac exE, rule_tac x = stp in exI,
+ simp add: exponent_def replicate.simps[THEN sym]
+ replicate_add[THEN sym] del: replicate.simps)
+ apply(subgoal_tac "pstr >(length gs)", simp)
+ apply(subgoal_tac "ba > aa \<and> length gs = aa \<and> pstr \<ge> ba", simp)
+ apply(simp add: j1 j2 j3)
+ done
+ qed
+qed
+
+(*
+lemma [simp]: " n < pstr \<Longrightarrow>
+ (0\<^bsup>pstr\<^esup>)[n := rs] @ [0::nat] = 0\<^bsup>n\<^esup> @ rs # 0\<^bsup>pstr - n\<^esup>"
+apply(insert list_update_length[of "0\<^bsup>n\<^esup>" 0 "0\<^bsup>pstr - Suc n\<^esup>" rs])
+apply(insert exponent_cons_iff[of "0::nat" "pstr - Suc n" "[]"], simp)
+apply(insert exponent_add_iff[of "0::nat" n "pstr - n" "[]"], simp)
+apply(case_tac "pstr - n", simp, simp only: exp_suc, simp)
+apply(subgoal_tac "pstr - Suc n = nat", simp)
+by arith
+*)
+
+lemma restore_rs_prog_ex:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_ci f = (a, aa, ba);
+ Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs)))) = pstr;
+ ss = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 8 * length gs + 3 * n + length a + 3\<rbrakk>
+ \<Longrightarrow> \<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and> length ap = ss \<and>
+ bp = empty pstr n"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "cn_merge_gs (map rec_ci gs) (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ mv_boxes 0 (Suc (max (Suc n) (Max (insert ba (((\<lambda>(aprog, p, n). n)
+ \<circ> rec_ci) ` set gs))) + length gs)) n [+]
+ mv_boxes (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) 0 (length gs) [+]
+ a [+] recursive.empty aa (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ empty_boxes (length gs)" in exI, simp add: cn_merge_gs_len)
+apply(rule_tac x = "mv_boxes (Suc (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))
+ + length gs)) 0 n"
+ in exI, auto simp: abc_append_commute)
+done
+
+lemma exp_add: "a\<^bsup>b+c\<^esup> = a\<^bsup>b\<^esup> @ a\<^bsup>c\<^esup>"
+apply(simp add: exponent_def replicate_add)
+done
+
+lemma [simp]: "n < pstr \<Longrightarrow> (0\<^bsup>pstr\<^esup>)[n := rs] @ [0::nat] = 0\<^bsup>n\<^esup> @ rs # 0\<^bsup>pstr - n\<^esup>"
+using list_update_length[of "0\<^bsup>n\<^esup>" "0::nat" "0\<^bsup>pstr - Suc n\<^esup>" rs]
+apply(simp add: exp_ind_def[THEN sym] exp_add[THEN sym] exp_suc[THEN sym])
+done
+
+lemma restore_rs:
+ assumes h: "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Cn n f gs) lm rs"
+ "\<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k)"
+ "length ys = length gs"
+ "rec_calc_rel f ys rs"
+ "rec_ci f = (a, aa, ba)"
+ and pdef: "pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))"
+ and starts: "ss = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 8 * length gs + 3 * n + length a + 3"
+ shows "\<exists>stp. abc_steps_l
+ (ss, 0\<^bsup>pstr\<^esup> @ rs # 0\<^bsup>length ys \<^esup> @ lm @
+ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm) aprog stp =
+ (ss + 3, 0\<^bsup>n\<^esup> @ rs # 0\<^bsup>pstr - n\<^esup> @ 0\<^bsup>length ys \<^esup> @ lm @
+ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)"
+proof -
+ from h and pdef and starts have k1:
+ "\<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and> length ap = ss \<and>
+ bp = empty pstr n"
+ by(drule_tac restore_rs_prog_ex, auto)
+ from k1 show "?thesis"
+ proof (erule_tac exE, erule_tac exE, erule_tac exE, erule_tac exE)
+ fix ap bp apa cp
+ assume "aprog = ap [+] bp [+] cp \<and> length ap = ss \<and>
+ bp = recursive.empty pstr n"
+ thus"?thesis"
+ apply(simp, rule_tac abc_append_exc1, simp_all add: starts h)
+ apply(insert empty_ex[of pstr n "0\<^bsup>pstr\<^esup> @ rs # 0\<^bsup>length gs\<^esup> @
+ lm @ 0\<^bsup>a_md - Suc (pstr + length gs + n)\<^esup> @ suf_lm"], simp)
+ apply(subgoal_tac "pstr > n", simp)
+ apply(erule_tac exE, rule_tac x = stp in exI,
+ simp add: nth_append list_update_append)
+ apply(simp add: pdef)
+ done
+ qed
+qed
+
+lemma [simp]:"xs \<noteq> [] \<Longrightarrow> length xs \<ge> Suc 0"
+by(case_tac xs, auto)
+
+lemma [simp]: "n < max (Suc n) (max ba (Max (((\<lambda>(aprog, p, n). n) o
+ rec_ci) ` set gs)))"
+by(simp)
+
+lemma restore_paras_prog_ex:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_ci f = (a, aa, ba);
+ Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs)))) = pstr;
+ ss = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 8 * length gs + 3 * n + length a + 6\<rbrakk>
+ \<Longrightarrow> \<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and> length ap = ss \<and>
+ bp = mv_boxes (pstr + Suc (length gs)) (0::nat) n"
+apply(simp add: rec_ci.simps)
+apply(rule_tac x = "cn_merge_gs (map rec_ci gs) (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))))
+ [+] mv_boxes 0 (Suc (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))
+ + length gs)) n [+] mv_boxes (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) 0 (length gs) [+]
+ a [+] recursive.empty aa (max (Suc n)
+ (Max (insert ba (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ empty_boxes (length gs) [+]
+ recursive.empty (max (Suc n) (Max (insert ba
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) n" in exI, simp add: cn_merge_gs_len)
+apply(rule_tac x = "[]" in exI, auto simp: abc_append_commute)
+done
+
+lemma restore_paras:
+ assumes h: "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Cn n f gs) lm rs"
+ "\<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k)"
+ "length ys = length gs"
+ "rec_calc_rel f ys rs"
+ "rec_ci f = (a, aa, ba)"
+ and pdef:
+ "pstr = Max (set (Suc n # ba # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))"
+ and starts: "ss = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 8 * length gs + 3 * n + length a + 6"
+ shows "\<exists>stp. abc_steps_l (ss, 0\<^bsup>n\<^esup> @ rs # 0\<^bsup>pstr - n+ length ys\<^esup> @
+ lm @ 0\<^bsup>a_md - Suc (pstr + length ys + n)\<^esup> @ suf_lm)
+ aprog stp = (ss + 3 * n, lm @ rs # 0\<^bsup>a_md - Suc n\<^esup> @ suf_lm)"
+proof -
+ thm rec_ci.simps
+ from h and pdef and starts have k1:
+ "\<exists> ap bp cp. aprog = ap [+] bp [+] cp \<and> length ap = ss \<and>
+ bp = mv_boxes (pstr + Suc (length gs)) (0::nat) n"
+ by(drule_tac restore_paras_prog_ex, auto)
+ from k1 show "?thesis"
+ proof (erule_tac exE, erule_tac exE, erule_tac exE, erule_tac exE)
+ fix ap bp apa cp
+ assume "aprog = ap [+] bp [+] cp \<and> length ap = ss \<and>
+ bp = mv_boxes (pstr + Suc (length gs)) 0 n"
+ thus"?thesis"
+ apply(simp, rule_tac abc_append_exc1, simp_all add: starts h)
+ apply(insert mv_boxes_ex2[of n "pstr + Suc (length gs)" 0 "[]"
+ "rs # 0\<^bsup>pstr - n + length gs\<^esup>" "lm"
+ "0\<^bsup>a_md - Suc (pstr + length gs + n)\<^esup> @ suf_lm"], simp)
+ apply(subgoal_tac "pstr > n \<and>
+ a_md > pstr + length gs + n \<and> length lm = n" , simp add: exponent_add_iff h)
+ using h pdef
+ apply(simp)
+ apply(frule_tac a = a and
+ aa = aa and ba = ba in ci_cn_md_def, simp, simp)
+ apply(subgoal_tac "length lm = rs_pos",
+ simp add: ci_cn_para_eq, erule_tac para_pattern, simp)
+ done
+ qed
+qed
+
+lemma ci_cn_length:
+ "\<lbrakk>rec_ci (Cn n f gs) = (aprog, rs_pos, a_md);
+ rec_calc_rel (Cn n f gs) lm rs;
+ rec_ci f = (a, aa, ba)\<rbrakk>
+ \<Longrightarrow> length aprog = (\<Sum>(ap, pos, n)\<leftarrow>map rec_ci gs. length ap) +
+ 8 * length gs + 6 * n + length a + 6"
+apply(simp add: rec_ci.simps, auto simp: cn_merge_gs_len)
+done
+
+
+lemma cn_case:
+ assumes ind:
+ "\<And>x aprog a_md rs_pos rs suf_lm lm.
+ \<lbrakk>x \<in> set (f # gs);
+ rec_ci x = (aprog, rs_pos, a_md);
+ rec_calc_rel x lm rs\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ and h: "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Cn n f gs) lm rs"
+
+ shows "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp
+ = (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+apply(insert h, case_tac "rec_ci f", rule_tac calc_cn_reverse, simp)
+proof -
+ fix a b c ys
+ let ?pstr = "Max (set (Suc n # c # (map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs)))))"
+ let ?gs_len = "listsum (map (\<lambda> (ap, pos, n). length ap)
+ (map rec_ci (gs)))"
+ assume g: "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "rec_calc_rel (Cn n f gs) lm rs"
+ "\<forall>k<length gs. rec_calc_rel (gs ! k) lm (ys ! k)"
+ "length ys = length gs"
+ "rec_calc_rel f ys rs"
+ "n = length lm"
+ "rec_ci f = (a, b, c)"
+ hence k1:
+ "\<exists> stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (?gs_len + 3 * length gs, lm @ 0\<^bsup>?pstr - n\<^esup> @ ys @
+ 0\<^bsup>a_md - ?pstr - length ys\<^esup> @ suf_lm)"
+ apply(rule_tac a = a and aa = b and ba = c in cn_calc_gs)
+ apply(rule_tac ind, auto)
+ done
+ thm rec_ci.simps
+ from g have k2:
+ "\<exists> stp. abc_steps_l (?gs_len + 3 * length gs, lm @
+ 0\<^bsup>?pstr - n\<^esup> @ ys @ 0\<^bsup>a_md - ?pstr - length ys\<^esup> @ suf_lm) aprog stp =
+ (?gs_len + 3 * length gs + 3 * n, 0\<^bsup>?pstr\<^esup> @ ys @ 0 # lm @
+ 0\<^bsup>a_md - Suc (?pstr + length ys + n )\<^esup> @ suf_lm)"
+ thm save_paras
+ apply(erule_tac ba = c in save_paras, auto intro: ci_cn_para_eq)
+ done
+ from g have k3:
+ "\<exists> stp. abc_steps_l (?gs_len + 3 * length gs + 3 * n,
+ 0\<^bsup>?pstr\<^esup> @ ys @ 0 # lm @ 0\<^bsup>a_md - Suc (?pstr + length ys + n)\<^esup> @ suf_lm) aprog stp =
+ (?gs_len + 6 * length gs + 3 * n,
+ ys @ 0\<^bsup>?pstr\<^esup> @ 0 # lm @ 0\<^bsup>a_md - Suc (?pstr + length ys + n)\<^esup> @ suf_lm)"
+ apply(erule_tac ba = c in reset_new_paras,
+ auto intro: ci_cn_para_eq)
+ using para_pattern[of f a b c ys rs]
+ apply(simp)
+ done
+ from g have k4:
+ "\<exists>stp. abc_steps_l (?gs_len + 6 * length gs + 3 * n,
+ ys @ 0\<^bsup>?pstr\<^esup> @ 0 # lm @ 0\<^bsup>a_md - Suc (?pstr + length ys + n)\<^esup> @ suf_lm) aprog stp =
+ (?gs_len + 6 * length gs + 3 * n + length a,
+ ys @ rs # 0\<^bsup>?pstr \<^esup> @ lm @ 0\<^bsup>a_md - Suc (?pstr + length ys + n)\<^esup> @ suf_lm)"
+ apply(rule_tac ba = c in calc_cn_f, rule_tac ind, auto)
+ done
+thm rec_ci.simps
+ from g h have k5:
+ "\<exists> stp. abc_steps_l (?gs_len + 6 * length gs + 3 * n + length a,
+ ys @ rs # 0\<^bsup>?pstr \<^esup>@ lm @ 0\<^bsup>a_md - Suc (?pstr + length ys + n)\<^esup> @ suf_lm)
+ aprog stp =
+ (?gs_len + 6 * length gs + 3 * n + length a + 3,
+ ys @ 0\<^bsup>?pstr - length ys\<^esup> @ rs # 0\<^bsup>length ys\<^esup> @ lm @
+ 0\<^bsup>a_md - Suc (?pstr + length ys + n)\<^esup> @ suf_lm)"
+ apply(rule_tac save_rs, auto simp: h)
+ done
+ thm rec_ci.simps
+ thm empty_boxes.simps
+ from g have k6:
+ "\<exists> stp. abc_steps_l (?gs_len + 6 * length gs + 3 * n +
+ length a + 3, ys @ 0\<^bsup>?pstr - length ys\<^esup> @ rs # 0\<^bsup>length ys\<^esup> @ lm @
+ 0\<^bsup>a_md - Suc (?pstr + length ys + n)\<^esup> @ suf_lm)
+ aprog stp =
+ (?gs_len + 8 * length gs + 3 *n + length a + 3,
+ 0\<^bsup>?pstr \<^esup> @ rs # 0\<^bsup>length ys\<^esup> @ lm @
+ 0\<^bsup>a_md -Suc (?pstr + length ys + n)\<^esup> @ suf_lm)"
+ apply(drule_tac suf_lm = suf_lm in empty_paras, auto)
+ apply(rule_tac x = stp in exI, simp)
+ done
+ from g have k7:
+ "\<exists> stp. abc_steps_l (?gs_len + 8 * length gs + 3 *n +
+ length a + 3, 0\<^bsup>?pstr \<^esup> @ rs # 0\<^bsup>length ys\<^esup> @ lm @
+ 0\<^bsup>a_md -Suc (?pstr + length ys + n)\<^esup> @ suf_lm) aprog stp =
+ (?gs_len + 8 * length gs + 3 * n + length a + 6,
+ 0\<^bsup>n\<^esup> @ rs # 0\<^bsup>?pstr - n\<^esup> @ 0\<^bsup>length ys\<^esup> @ lm @
+ 0\<^bsup>a_md -Suc (?pstr + length ys + n) \<^esup> @ suf_lm)"
+ apply(drule_tac suf_lm = suf_lm in restore_rs, auto)
+ apply(rule_tac x = stp in exI, simp)
+ done
+ from g have k8: "\<exists> stp. abc_steps_l (?gs_len + 8 * length gs +
+ 3 * n + length a + 6,
+ 0\<^bsup>n\<^esup> @ rs # 0\<^bsup>?pstr - n\<^esup> @ 0\<^bsup>length ys\<^esup> @ lm @
+ 0\<^bsup>a_md -Suc (?pstr + length ys + n) \<^esup> @ suf_lm) aprog stp =
+ (?gs_len + 8 * length gs + 6 * n + length a + 6,
+ lm @ rs # 0\<^bsup>a_md - Suc n \<^esup>@ suf_lm)"
+ apply(drule_tac suf_lm = suf_lm in restore_paras, auto)
+ apply(simp add: exponent_add_iff)
+ apply(rule_tac x = stp in exI, simp)
+ done
+ from g have j1:
+ "length aprog = ?gs_len + 8 * length gs + 6 * n + length a + 6"
+ by(drule_tac a = a and aa = b and ba = c in ci_cn_length,
+ simp, simp, simp)
+ from g have j2: "rs_pos = n"
+ by(simp add: ci_cn_para_eq)
+ from k1 and k2 and k3 and k4 and k5 and k6 and k7 and k8
+ and j1 and j2 show
+ "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp =
+ (length aprog, lm @ [rs] @ 0\<^bsup>a_md - rs_pos - 1\<^esup> @ suf_lm)"
+ apply(auto)
+ apply(rule_tac x = "stp + stpa + stpb + stpc +
+ stpd + stpe + stpf + stpg" in exI, simp add: abc_steps_add)
+ done
+qed
+
+text {*
+ Correctness of the complier (terminate case), which says if the execution of
+ a recursive function @{text "recf"} terminates and gives result, then
+ the Abacus program compiled from @{text "recf"} termintes and gives the same result.
+ Additionally, to facilitate induction proof, we append @{text "anything"} to the
+ end of Abacus memory.
+*}
+
+lemma aba_rec_equality:
+ "\<lbrakk>rec_ci recf = (ap, arity, fp);
+ rec_calc_rel recf args r\<rbrakk>
+ \<Longrightarrow> (\<exists> stp. (abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything) ap stp) =
+ (length ap, args@[r]@0\<^bsup>fp - arity - 1\<^esup> @ anything))"
+apply(induct arbitrary: ap fp arity r anything args
+ rule: rec_ci.induct)
+prefer 5
+proof(case_tac "rec_ci g", case_tac "rec_ci f", simp)
+ fix n f g ap fp arity r anything args a b c aa ba ca
+ assume f_ind:
+ "\<And>ap fp arity r anything args.
+ \<lbrakk>aa = ap \<and> ba = arity \<and> ca = fp; rec_calc_rel f args r\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything) ap stp =
+ (length ap, args @ r # 0\<^bsup>fp - Suc arity\<^esup> @ anything)"
+ and g_ind:
+ "\<And>x xa y xb ya ap fp arity r anything args.
+ \<lbrakk>x = (aa, ba, ca); xa = aa \<and> y = (ba, ca); xb = ba \<and> ya = ca;
+ a = ap \<and> b = arity \<and> c = fp; rec_calc_rel g args r\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything) ap stp =
+ (length ap, args @ r # 0\<^bsup>fp - Suc arity\<^esup> @ anything)"
+ and h: "rec_ci (Pr n f g) = (ap, arity, fp)"
+ "rec_calc_rel (Pr n f g) args r"
+ "rec_ci g = (a, b, c)"
+ "rec_ci f = (aa, ba, ca)"
+ from h have nf_ind:
+ "\<And> args r anything. rec_calc_rel f args r \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, args @ 0\<^bsup>ca - ba\<^esup> @ anything) aa stp =
+ (length aa, args @ r # 0\<^bsup>ca - Suc ba\<^esup> @ anything)"
+ and ng_ind:
+ "\<And> args r anything. rec_calc_rel g args r \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, args @ 0\<^bsup>c - b\<^esup> @ anything) a stp =
+ (length a, args @ r # 0\<^bsup>c - Suc b \<^esup> @ anything)"
+ apply(insert f_ind[of aa ba ca], simp)
+ apply(insert g_ind[of "(aa, ba, ca)" aa "(ba, ca)" ba ca a b c],
+ simp)
+ done
+ from nf_ind and ng_ind and h show
+ "\<exists>stp. abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything) ap stp =
+ (length ap, args @ r # 0\<^bsup>fp - Suc arity\<^esup> @ anything)"
+ apply(auto intro: nf_ind ng_ind pr_case)
+ done
+next
+ fix ap fp arity r anything args
+ assume h:
+ "rec_ci z = (ap, arity, fp)" "rec_calc_rel z args r"
+ thus "\<exists>stp. abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything) ap stp =
+ (length ap, args @ [r] @ 0\<^bsup>fp - arity - 1\<^esup> @ anything)"
+ by (rule_tac z_case)
+next
+ fix ap fp arity r anything args
+ assume h:
+ "rec_ci s = (ap, arity, fp)"
+ "rec_calc_rel s args r"
+ thus
+ "\<exists>stp. abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything) ap stp =
+ (length ap, args @ [r] @ 0\<^bsup>fp - arity - 1\<^esup> @ anything)"
+ by(erule_tac s_case, simp)
+next
+ fix m n ap fp arity r anything args
+ assume h: "rec_ci (id m n) = (ap, arity, fp)"
+ "rec_calc_rel (id m n) args r"
+ thus "\<exists>stp. abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything) ap stp
+ = (length ap, args @ [r] @ 0\<^bsup>fp - arity - 1\<^esup> @ anything)"
+ by(erule_tac id_case)
+next
+ fix n f gs ap fp arity r anything args
+ assume ind: "\<And>x ap fp arity r anything args.
+ \<lbrakk>x \<in> set (f # gs);
+ rec_ci x = (ap, arity, fp);
+ rec_calc_rel x args r\<rbrakk>
+ \<Longrightarrow> \<exists>stp. abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything) ap stp =
+ (length ap, args @ [r] @ 0\<^bsup>fp - arity - 1\<^esup> @ anything)"
+ and h: "rec_ci (Cn n f gs) = (ap, arity, fp)"
+ "rec_calc_rel (Cn n f gs) args r"
+ from h show
+ "\<exists>stp. abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything)
+ ap stp = (length ap, args @ [r] @ 0\<^bsup>fp - arity - 1\<^esup> @ anything)"
+ apply(rule_tac cn_case, rule_tac ind, auto)
+ done
+next
+ fix n f ap fp arity r anything args
+ assume ind:
+ "\<And>ap fp arity r anything args.
+ \<lbrakk>rec_ci f = (ap, arity, fp); rec_calc_rel f args r\<rbrakk> \<Longrightarrow>
+ \<exists>stp. abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything) ap stp =
+ (length ap, args @ [r] @ 0\<^bsup>fp - arity - 1\<^esup> @ anything)"
+ and h: "rec_ci (Mn n f) = (ap, arity, fp)"
+ "rec_calc_rel (Mn n f) args r"
+ from h show
+ "\<exists>stp. abc_steps_l (0, args @ 0\<^bsup>fp - arity\<^esup> @ anything) ap stp =
+ (length ap, args @ [r] @ 0\<^bsup>fp - arity - 1\<^esup> @ anything)"
+ apply(rule_tac mn_case, rule_tac ind, auto)
+ done
+qed
+
+
+thm abc_append_state_in_exc
+lemma abc_append_uhalt1:
+ "\<lbrakk>\<forall> stp. (\<lambda> (ss, e). ss < length bp) (abc_steps_l (0, lm) bp stp);
+ p = ap [+] bp [+] cp\<rbrakk>
+ \<Longrightarrow> \<forall> stp. (\<lambda> (ss, e). ss < length p)
+ (abc_steps_l (length ap, lm) p stp)"
+apply(auto)
+apply(erule_tac x = stp in allE, auto)
+apply(frule_tac ap = ap and cp = cp in abc_append_state_in_exc, auto)
+done
+
+
+lemma abc_append_unhalt2:
+ "\<lbrakk>abc_steps_l (0, am) ap stp = (length ap, lm); bp \<noteq> [];
+ \<forall> stp. (\<lambda> (ss, e). ss < length bp) (abc_steps_l (0, lm) bp stp);
+ p = ap [+] bp [+] cp\<rbrakk>
+ \<Longrightarrow> \<forall> stp. (\<lambda> (ss, e). ss < length p) (abc_steps_l (0, am) p stp)"
+proof -
+ assume h:
+ "abc_steps_l (0, am) ap stp = (length ap, lm)"
+ "bp \<noteq> []"
+ "\<forall> stp. (\<lambda> (ss, e). ss < length bp) (abc_steps_l (0, lm) bp stp)"
+ "p = ap [+] bp [+] cp"
+ have "\<exists> stp. (abc_steps_l (0, am) p stp) = (length ap, lm)"
+ using h
+ thm abc_add_exc1
+ apply(simp add: abc_append.simps)
+ apply(rule_tac abc_add_exc1, auto)
+ done
+ from this obtain stpa where g1:
+ "(abc_steps_l (0, am) p stpa) = (length ap, lm)" ..
+ moreover have g2: "\<forall> stp. (\<lambda> (ss, e). ss < length p)
+ (abc_steps_l (length ap, lm) p stp)"
+ using h
+ apply(erule_tac abc_append_uhalt1, simp)
+ done
+ moreover from g1 and g2 have
+ "\<forall> stp. (\<lambda> (ss, e). ss < length p)
+ (abc_steps_l (0, am) p (stpa + stp))"
+ apply(simp add: abc_steps_add)
+ done
+ thus "\<forall> stp. (\<lambda> (ss, e). ss < length p)
+ (abc_steps_l (0, am) p stp)"
+ apply(rule_tac allI, auto)
+ apply(case_tac "stp \<ge> stpa")
+ apply(erule_tac x = "stp - stpa" in allE, simp)
+ proof -
+ fix stp a b
+ assume g3: "abc_steps_l (0, am) p stp = (a, b)"
+ "\<not> stpa \<le> stp"
+ thus "a < length p"
+ using g1 h
+ apply(case_tac "a < length p", simp, simp)
+ apply(subgoal_tac "\<exists> d. stpa = stp + d")
+ using abc_state_keep[of p a b "stpa - stp"]
+ apply(erule_tac exE, simp add: abc_steps_add)
+ apply(rule_tac x = "stpa - stp" in exI, simp)
+ done
+ qed
+qed
+
+text {*
+ Correctness of the complier (non-terminating case for Mn). There are many cases when a
+ recursive function does not terminate. For the purpose of Uiversal Turing Machine, we only
+ need to prove the case for @{text "Mn"} and @{text "Cn"}.
+ This lemma is for @{text "Mn"}. For @{text "Mn n f"}, this lemma describes what
+ happens when @{text "f"} always terminates but always does not return zero, so that
+ @{text "Mn"} has to loop forever.
+ *}
+
+lemma Mn_unhalt:
+ assumes mn_rf: "rf = Mn n f"
+ and compiled_mnrf: "rec_ci rf = (aprog, rs_pos, a_md)"
+ and compiled_f: "rec_ci f = (aprog', rs_pos', a_md')"
+ and args: "length lm = n"
+ and unhalt_condition: "\<forall> y. (\<exists> rs. rec_calc_rel f (lm @ [y]) rs \<and> rs \<noteq> 0)"
+ shows "\<forall> stp. case abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm)
+ aprog stp of (ss, e) \<Rightarrow> ss < length aprog"
+ using mn_rf compiled_mnrf compiled_f args unhalt_condition
+proof(rule_tac allI)
+ fix stp
+ assume h: "rf = Mn n f"
+ "rec_ci rf = (aprog, rs_pos, a_md)"
+ "rec_ci f = (aprog', rs_pos', a_md')"
+ "\<forall>y. \<exists>rs. rec_calc_rel f (lm @ [y]) rs \<and> rs \<noteq> 0" "length lm = n"
+ thm mn_ind_step
+ have "\<exists>stpa \<ge> stp. abc_steps_l (0, lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm) aprog stpa
+ = (0, lm @ stp # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ proof(induct stp, auto)
+ show "\<exists>stpa. abc_steps_l (0, lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stpa = (0, lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ apply(rule_tac x = 0 in exI, simp add: abc_steps_l.simps)
+ done
+ next
+ fix stp stpa
+ assume g1: "stp \<le> stpa"
+ and g2: "abc_steps_l (0, lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stpa
+ = (0, lm @ stp # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ have "\<exists>rs. rec_calc_rel f (lm @ [stp]) rs \<and> rs \<noteq> 0"
+ using h
+ apply(erule_tac x = stp in allE, simp)
+ done
+ from this obtain rs where g3:
+ "rec_calc_rel f (lm @ [stp]) rs \<and> rs \<noteq> 0" ..
+ hence "\<exists> stpb. abc_steps_l (0, lm @ stp # 0\<^bsup>a_md - Suc rs_pos\<^esup> @
+ suf_lm) aprog stpb
+ = (0, lm @ Suc stp # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ using h
+ apply(rule_tac mn_ind_step)
+ apply(rule_tac aba_rec_equality, simp, simp)
+ proof -
+ show "rec_ci f = ((aprog', rs_pos', a_md'))" using h by simp
+ next
+ show "rec_ci (Mn n f) = (aprog, rs_pos, a_md)" using h by simp
+ next
+ show "rec_calc_rel f (lm @ [stp]) rs" using g3 by simp
+ next
+ show "0 < rs" using g3 by simp
+ next
+ show "Suc rs_pos < a_md"
+ using g3 h
+ apply(auto)
+ apply(frule_tac f = f in para_pattern, simp, simp)
+ apply(simp add: rec_ci.simps, auto)
+ apply(subgoal_tac "Suc (length lm) < a_md'")
+ apply(arith)
+ apply(simp add: ci_ad_ge_paras)
+ done
+ next
+ show "rs_pos' = Suc rs_pos"
+ using g3 h
+ apply(auto)
+ apply(frule_tac f = f in para_pattern, simp, simp)
+ apply(simp add: rec_ci.simps)
+ done
+ qed
+ thus "\<exists>stpa\<ge>Suc stp. abc_steps_l (0, lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @
+ suf_lm) aprog stpa
+ = (0, lm @ Suc stp # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)"
+ using g2
+ apply(erule_tac exE)
+ apply(case_tac "stpb = 0", simp add: abc_steps_l.simps)
+ apply(rule_tac x = "stpa + stpb" in exI, simp add:
+ abc_steps_add)
+ using g1
+ apply(arith)
+ done
+ qed
+ from this obtain stpa where
+ "stp \<le> stpa \<and> abc_steps_l (0, lm @ 0 # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)
+ aprog stpa = (0, lm @ stp # 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm)" ..
+ thus "case abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog stp
+ of (ss, e) \<Rightarrow> ss < length aprog"
+ apply(case_tac "abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm) aprog
+ stp", simp, case_tac "a \<ge> length aprog",
+ simp, simp)
+ apply(subgoal_tac "\<exists> d. stpa = stp + d", erule_tac exE)
+ apply(subgoal_tac "lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suf_lm = lm @ 0 #
+ 0\<^bsup>a_md - Suc rs_pos\<^esup> @ suf_lm", simp add: abc_steps_add)
+ apply(frule_tac as = a and lm = b and stp = d in abc_state_keep,
+ simp)
+ using h
+ apply(simp add: rec_ci.simps, simp,
+ simp only: exp_ind_def[THEN sym])
+ apply(case_tac rs_pos, simp, simp)
+ apply(rule_tac x = "stpa - stp" in exI, simp, simp)
+ done
+qed
+
+
+lemma abc_append_cons_eq[intro!]:
+ "\<lbrakk>ap = bp; cp = dp\<rbrakk> \<Longrightarrow> ap [+] cp = bp [+] dp"
+by simp
+
+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 [+]
+ empty gb (p + i) [+]
+ cn_merge_gs (map rec_ci (drop (Suc i) gs)) (p + Suc i)"
+apply(induct i arbitrary: gs p, case_tac gs, simp, simp)
+apply(case_tac gs, simp, case_tac "rec_ci a",
+ simp add: abc_append_commute[THEN sym])
+done
+
+text {*
+ Correctness of the complier (non-terminating case for Mn). There are many cases when a
+ recursive function does not terminate. For the purpose of Uiversal Turing Machine, we only
+ need to prove the case for @{text "Mn"} and @{text "Cn"}.
+ This lemma is for @{text "Cn"}. For @{text "Cn f g1 g2 \<dots>gi, gi+1, \<dots> gn"}, this lemma describes what
+ happens when every one of @{text "g1, g2, \<dots> gi"} terminates, but
+ @{text "gi+1"} does not terminate, so that whole function @{text "Cn f g1 g2 \<dots>gi, gi+1, \<dots> gn"}
+ does not terminate.
+ *}
+
+lemma cn_gi_uhalt:
+ assumes cn_recf: "rf = Cn n f gs"
+ and compiled_cn_recf: "rec_ci rf = (aprog, rs_pos, a_md)"
+ and args_length: "length lm = n"
+ and exist_unhalt_recf: "i < length gs" "gi = gs ! i"
+ and complied_unhalt_recf: "rec_ci gi = (ga, gb, gc)" "gb = n"
+ and all_halt_before_gi: "\<forall> j < i. (\<exists> rs. rec_calc_rel (gs!j) lm rs)"
+ and unhalt_condition: "\<And> slm. \<forall> stp. case abc_steps_l (0, lm @ 0\<^bsup>gc - gb\<^esup> @ slm)
+ ga stp of (se, e) \<Rightarrow> se < length ga"
+ shows " \<forall> stp. case abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suflm) aprog
+ stp of (ss, e) \<Rightarrow> ss < length aprog"
+ using cn_recf compiled_cn_recf args_length exist_unhalt_recf complied_unhalt_recf
+ all_halt_before_gi unhalt_condition
+proof(case_tac "rec_ci f", simp)
+ fix a b c
+ assume h1: "rf = Cn n f gs"
+ "rec_ci (Cn n f gs) = (aprog, rs_pos, a_md)"
+ "length lm = n"
+ "gi = gs ! i"
+ "rec_ci (gs!i) = (ga, n, gc)"
+ "gb = n" "rec_ci f = (a, b, c)"
+ and h2: "\<forall>j<i. \<exists>rs. rec_calc_rel (gs ! j) lm rs"
+ "i < length gs"
+ and ind:
+ "\<And> slm. \<forall> stp. case abc_steps_l (0, lm @ 0\<^bsup>gc - n\<^esup> @ slm) ga stp of (se, e) \<Rightarrow> se < length ga"
+ have h3: "rs_pos = n"
+ using h1
+ by(rule_tac ci_cn_para_eq, simp)
+ let ?ggs = "take i gs"
+ have "\<exists> ys. (length ys = i \<and>
+ (\<forall> k < i. rec_calc_rel (?ggs ! k) lm (ys ! k)))"
+ using h2
+ apply(induct i, simp, simp)
+ apply(erule_tac exE)
+ apply(erule_tac x = ia in allE, simp)
+ apply(erule_tac exE)
+ apply(rule_tac x = "ys @ [x]" in exI, simp add: nth_append, auto)
+ apply(subgoal_tac "k = length ys", simp, simp)
+ done
+ from this obtain ys where g1:
+ "(length ys = i \<and> (\<forall> k < i. rec_calc_rel (?ggs ! k)
+ lm (ys ! k)))" ..
+ let ?pstr = "Max (set (Suc n # c # map (\<lambda>(aprog, p, n). n)
+ (map rec_ci (f # gs))))"
+ have "\<exists>stp. abc_steps_l (0, lm @ 0\<^bsup>a_md - n\<^esup> @ suflm)
+ (cn_merge_gs (map rec_ci ?ggs) ?pstr) stp =
+ (listsum (map ((\<lambda>(ap, pos, n). length ap) \<circ> rec_ci) ?ggs) +
+ 3 * length ?ggs, lm @ 0\<^bsup>?pstr - n\<^esup> @ ys @ 0\<^bsup>a_md -(?pstr + length ?ggs)\<^esup> @
+ suflm) "
+ apply(rule_tac cn_merge_gs_ex)
+ apply(rule_tac aba_rec_equality, simp, simp)
+ using h1
+ apply(simp add: rec_ci.simps, auto)
+ using g1
+ apply(simp)
+ using h2 g1
+ apply(simp)
+ apply(rule_tac min_max.le_supI2)
+ apply(rule_tac Max_ge, simp, simp, rule_tac disjI2)
+ apply(subgoal_tac "aa \<in> set gs", simp)
+ using h2
+ apply(rule_tac A = "set (take i gs)" in subsetD,
+ simp add: set_take_subset, simp)
+ done
+ thm cn_merge_gs.simps
+ from this obtain stpa where g2:
+ "abc_steps_l (0, lm @ 0\<^bsup>a_md - n\<^esup> @ suflm)
+ (cn_merge_gs (map rec_ci ?ggs) ?pstr) stpa =
+ (listsum (map ((\<lambda>(ap, pos, n). length ap) \<circ> rec_ci) ?ggs) +
+ 3 * length ?ggs, lm @ 0\<^bsup>?pstr - n\<^esup> @ ys @ 0\<^bsup>a_md -(?pstr + length ?ggs)\<^esup> @
+ suflm)" ..
+ moreover have
+ "\<exists> cp. aprog = (cn_merge_gs
+ (map rec_ci ?ggs) ?pstr) [+] ga [+] cp"
+ using h1
+ apply(simp add: rec_ci.simps)
+ apply(rule_tac x = "empty n (?pstr + i) [+]
+ (cn_merge_gs (map rec_ci (drop (Suc i) gs)) (?pstr + Suc i))
+ [+]mv_boxes 0 (Suc (max (Suc n) (Max (insert c
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) +
+ length gs)) n [+] mv_boxes (max (Suc n) (Max (insert c
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) 0 (length gs) [+]
+ a [+] recursive.empty b (max (Suc n)
+ (Max (insert c (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) [+]
+ empty_boxes (length gs) [+] recursive.empty (max (Suc n)
+ (Max (insert c (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs)))) n [+]
+ mv_boxes (Suc (max (Suc n) (Max (insert c
+ (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))) + length gs)) 0 n" in exI)
+ apply(simp add: abc_append_commute [THEN sym])
+ apply(auto)
+ using cn_merge_gs_split[of i gs ga "length lm" gc
+ "(max (Suc (length lm))
+ (Max (insert c (((\<lambda>(aprog, p, n). n) \<circ> rec_ci) ` set gs))))"]
+ h2
+ apply(simp)
+ done
+ from this obtain cp where g3:
+ "aprog = (cn_merge_gs (map rec_ci ?ggs) ?pstr) [+] ga [+] cp" ..
+ show "\<forall> stp. case abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suflm)
+ aprog stp of (ss, e) \<Rightarrow> ss < length aprog"
+ proof(rule_tac abc_append_unhalt2)
+ show "abc_steps_l (0, lm @ 0\<^bsup>a_md - rs_pos\<^esup> @ suflm) (
+ cn_merge_gs (map rec_ci ?ggs) ?pstr) stpa =
+ (length ((cn_merge_gs (map rec_ci ?ggs) ?pstr)),
+ lm @ 0\<^bsup>?pstr - n\<^esup> @ ys @ 0\<^bsup>a_md -(?pstr + length ?ggs)\<^esup> @ suflm)"
+ using h3 g2
+ apply(simp add: cn_merge_gs_length)
+ done
+ next
+ show "ga \<noteq> []"
+ using h1
+ apply(simp add: rec_ci_not_null)
+ done
+ next
+ show "\<forall>stp. case abc_steps_l (0, lm @ 0\<^bsup>?pstr - n\<^esup> @ ys
+ @ 0\<^bsup>a_md - (?pstr + length (take i gs))\<^esup> @ suflm) ga stp of
+ (ss, e) \<Rightarrow> ss < length ga"
+ using ind[of "0\<^bsup>?pstr -gc\<^esup> @ ys @ 0\<^bsup>a_md - (?pstr + length (take i gs))\<^esup>
+ @ suflm"]
+ apply(subgoal_tac "lm @ 0\<^bsup>?pstr - n\<^esup> @ ys
+ @ 0\<^bsup>a_md - (?pstr + length (take i gs))\<^esup> @ suflm
+ = lm @ 0\<^bsup>gc - n \<^esup>@
+ 0\<^bsup>?pstr -gc\<^esup> @ ys @ 0\<^bsup>a_md - (?pstr + length (take i gs))\<^esup> @ suflm", simp)
+ apply(simp add: exponent_def replicate_add[THEN sym])
+ apply(subgoal_tac "gc > n \<and> ?pstr \<ge> gc")
+ apply(erule_tac conjE)
+ apply(simp add: h1)
+ using h1
+ apply(auto)
+ apply(rule_tac min_max.le_supI2)
+ apply(rule_tac Max_ge, simp, simp)
+ apply(rule_tac disjI2)
+ using h2
+ thm rev_image_eqI
+ apply(rule_tac x = "gs!i" in rev_image_eqI, simp, simp)
+ done
+ next
+ show "aprog = cn_merge_gs (map rec_ci (take i gs))
+ ?pstr [+] ga [+] cp"
+ using g3 by simp
+ qed
+qed
+
+
+lemma abc_rec_halt_eq':
+ "\<lbrakk>rec_ci re = (ap, ary, fp);
+ rec_calc_rel re args r\<rbrakk>
+ \<Longrightarrow> (\<exists> stp. (abc_steps_l (0, args @ 0\<^bsup>fp - ary\<^esup>) ap stp) =
+ (length ap, args@[r]@0\<^bsup>fp - ary - 1\<^esup>))"
+using aba_rec_equality[of re ap ary fp args r "[]"]
+by simp
+
+thm abc_step_l.simps
+definition dummy_abc :: "nat \<Rightarrow> abc_inst list"
+where
+"dummy_abc k = [Inc k, Dec k 0, Goto 3]"
+
+lemma abc_rec_halt_eq'':
+ "\<lbrakk>rec_ci re = (aprog, rs_pos, a_md);
+ rec_calc_rel re lm rs\<rbrakk>
+ \<Longrightarrow> (\<exists> stp lm' m. (abc_steps_l (0, lm) aprog stp) =
+ (length aprog, lm') \<and> abc_list_crsp lm' (lm @ rs # 0\<^bsup>m\<^esup>))"
+apply(frule_tac abc_rec_halt_eq', auto)
+apply(drule_tac abc_list_crsp_steps)
+apply(rule_tac rec_ci_not_null, simp)
+apply(erule_tac exE, rule_tac x = stp in exI,
+ auto simp: abc_list_crsp_def)
+done
+
+lemma [simp]: "length (dummy_abc (length lm)) = 3"
+apply(simp add: dummy_abc_def)
+done
+
+lemma [simp]: "dummy_abc (length lm) \<noteq> []"
+apply(simp add: dummy_abc_def)
+done
+
+lemma dummy_abc_steps_ex:
+ "\<exists>bstp. abc_steps_l (0, lm') (dummy_abc (length lm)) bstp =
+ ((Suc (Suc (Suc 0))), abc_lm_s lm' (length lm) (abc_lm_v lm' (length lm)))"
+apply(rule_tac x = "Suc (Suc (Suc 0))" in exI)
+apply(auto simp: abc_steps_l.simps abc_step_l.simps
+ dummy_abc_def abc_fetch.simps)
+apply(auto simp: abc_lm_s.simps abc_lm_v.simps nth_append)
+apply(simp add: butlast_append)
+done
+
+lemma [elim]:
+ "lm @ rs # 0\<^bsup>m\<^esup> = lm' @ 0\<^bsup>n\<^esup> \<Longrightarrow>
+ \<exists>m. abc_lm_s lm' (length lm) (abc_lm_v lm' (length lm)) =
+ lm @ rs # 0\<^bsup>m\<^esup>"
+proof(cases "length lm' > length lm")
+ case True
+ assume h: "lm @ rs # 0\<^bsup>m\<^esup> = lm' @ 0\<^bsup>n\<^esup>" "length lm < length lm'"
+ hence "m \<ge> n"
+ apply(drule_tac list_length)
+ apply(simp)
+ done
+ hence "\<exists> d. m = d + n"
+ apply(rule_tac x = "m - n" in exI, simp)
+ done
+ from this obtain d where "m = d + n" ..
+ from h and this show "?thesis"
+ apply(auto simp: abc_lm_s.simps abc_lm_v.simps
+ exponent_def replicate_add)
+ done
+next
+ case False
+ assume h:"lm @ rs # 0\<^bsup>m\<^esup> = lm' @ 0\<^bsup>n\<^esup>"
+ and g: "\<not> length lm < length lm'"
+ have "take (Suc (length lm)) (lm @ rs # 0\<^bsup>m\<^esup>) =
+ take (Suc (length lm)) (lm' @ 0\<^bsup>n\<^esup>)"
+ using h by simp
+ moreover have "n \<ge> (Suc (length lm) - length lm')"
+ using h g
+ apply(drule_tac list_length)
+ apply(simp)
+ done
+ ultimately show
+ "\<exists>m. abc_lm_s lm' (length lm) (abc_lm_v lm' (length lm)) =
+ lm @ rs # 0\<^bsup>m\<^esup>"
+ using g h
+ apply(simp add: abc_lm_s.simps abc_lm_v.simps
+ exponent_def min_def)
+ apply(rule_tac x = 0 in exI,
+ simp add:replicate_append_same replicate_Suc[THEN sym]
+ del:replicate_Suc)
+ done
+qed
+
+lemma [elim]:
+ "abc_list_crsp lm' (lm @ rs # 0\<^bsup>m\<^esup>)
+ \<Longrightarrow> \<exists>m. abc_lm_s lm' (length lm) (abc_lm_v lm' (length lm))
+ = lm @ rs # 0\<^bsup>m\<^esup>"
+apply(auto simp: abc_list_crsp_def)
+apply(simp add: abc_lm_v.simps abc_lm_s.simps)
+apply(rule_tac x = "m + n" in exI,
+ simp add: exponent_def replicate_add)
+done
+
+
+lemma abc_append_dummy_complie:
+ "\<lbrakk>rec_ci recf = (ap, ary, fp);
+ rec_calc_rel recf args r;
+ length args = k\<rbrakk>
+ \<Longrightarrow> (\<exists> stp m. (abc_steps_l (0, args) (ap [+] dummy_abc k) stp) =
+ (length ap + 3, args @ r # 0\<^bsup>m\<^esup>))"
+apply(drule_tac abc_rec_halt_eq'', auto simp: numeral_3_eq_3)
+proof -
+ fix stp lm' m
+ assume h: "rec_calc_rel recf args r"
+ "abc_steps_l (0, args) ap stp = (length ap, lm')"
+ "abc_list_crsp lm' (args @ r # 0\<^bsup>m\<^esup>)"
+ thm abc_append_exc2
+ thm abc_lm_s.simps
+ have "\<exists>stp. abc_steps_l (0, args) (ap [+]
+ (dummy_abc (length args))) stp = (length ap + 3,
+ abc_lm_s lm' (length args) (abc_lm_v lm' (length args)))"
+ using h
+ apply(rule_tac bm = lm' in abc_append_exc2,
+ auto intro: dummy_abc_steps_ex simp: numeral_3_eq_3)
+ done
+ thus "\<exists>stp m. abc_steps_l (0, args) (ap [+]
+ dummy_abc (length args)) stp = (Suc (Suc (Suc (length ap))), args @ r # 0\<^bsup>m\<^esup>)"
+ using h
+ apply(erule_tac exE)
+ apply(rule_tac x = stpa in exI, auto)
+ done
+qed
+
+lemma [simp]: "length (dummy_abc k) = 3"
+apply(simp add: dummy_abc_def)
+done
+
+lemma [simp]: "length args = k \<Longrightarrow> abc_lm_v (args @ r # 0\<^bsup>m\<^esup>) k = r "
+apply(simp add: abc_lm_v.simps nth_append)
+done
+
+lemma t_compiled_by_rec:
+ "\<lbrakk>rec_ci recf = (ap, ary, fp);
+ rec_calc_rel recf args r;
+ length args = k;
+ ly = layout_of (ap [+] dummy_abc k);
+ mop_ss = start_of ly (length (ap [+] dummy_abc k));
+ tp = tm_of (ap [+] dummy_abc k)\<rbrakk>
+ \<Longrightarrow> \<exists> stp m l. steps (Suc 0, Bk # Bk # ires, <args> @ Bk\<^bsup>rn\<^esup>) (tp @ (tMp k (mop_ss - 1))) stp
+ = (0, Bk\<^bsup>m\<^esup> @ Bk # Bk # ires, Oc\<^bsup>Suc r\<^esup> @ Bk\<^bsup>l\<^esup>)"
+ using abc_append_dummy_complie[of recf ap ary fp args r k]
+apply(simp)
+apply(erule_tac exE)+
+apply(frule_tac tprog = tp and as = "length ap + 3" and n = k
+ and ires = ires and rn = rn in abacus_turing_eq_halt, simp_all, simp)
+apply(erule_tac exE)+
+apply(simp)
+apply(rule_tac x = stpa in exI, rule_tac x = ma in exI, rule_tac x = l in exI, simp)
+done
+
+thm tms_of.simps
+
+lemma [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"
+apply(induct xs, simp, simp)
+apply(case_tac a, simp)
+done
+
+(*
+lemma [simp]: "t_correct (tMp n 0)"
+apply(simp add: t_correct.simps tMp.simps shift_length mp_up_def iseven_def, auto)
+apply(rule_tac x = "2*n + 6" in exI, simp)
+apply(induct n, auto simp: mop_bef.simps)
+apply(simp add: tshift.simps)
+done
+*)
+
+lemma tshift_append: "tshift (xs @ ys) n = tshift xs n @ tshift ys n"
+apply(simp add: tshift.simps)
+done
+
+lemma [simp]: "length (tMp n ss) = 4 * n + 12"
+apply(auto simp: tMp.simps tshift_append shift_length mp_up_def)
+done
+
+lemma length_tm_even[intro]: "\<exists>x. length (tm_of ap) = 2*x"
+apply(subgoal_tac "t_ncorrect (tm_of ap)")
+apply(simp add: t_ncorrect.simps, auto)
+done
+
+lemma [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 [elim]: "\<lbrakk>k < length ap; ap ! k = Inc n;
+ (a, b) \<in> set (abacus.tshift (abacus.tshift 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(case_tac "Suc k = length ap", simp)
+apply(rule_tac start_of_le, simp)
+apply(auto simp: tinc_b_def tshift.simps start_of.simps
+ layout_of.simps length_of.simps startof_not0)
+done
+
+lemma findnth_le[elim]: "(a, b) \<in> set (abacus.tshift (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, simp add: findnth.simps tshift.simps)
+apply(simp add: findnth.simps tshift_append, auto)
+apply(auto simp: tshift.simps)
+done
+
+
+lemma [elim]: "\<lbrakk>k < length ap; ap ! k = Inc n; (a, b) \<in>
+ set (abacus.tshift (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(case_tac "Suc k = length ap", simp)
+apply(rule_tac start_of_le, 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 tshift.simps start_of.simps
+ layout_of.simps length_of.simps startof_not0)
+done
+
+lemma start_of_eq: "length ap < as \<Longrightarrow> start_of (layout_of ap) as = start_of (layout_of ap) (length ap)"
+apply(induct as, simp)
+apply(case_tac "length ap < as", simp add: start_of.simps)
+apply(subgoal_tac "as = length ap")
+apply(simp add: start_of.simps)
+apply arith
+done
+
+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_le)
+done
+
+lemma [elim]: "\<lbrakk>k < length ap;
+ ap ! k = Dec n e;
+ (a, b) \<in> set (abacus.tshift (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(simp add: tshift.simps start_of.simps
+ layout_of.simps length_of.simps startof_not0)
+apply(rule_tac start_of_all_le)
+done
+
+thm length_of.simps
+lemma [elim]: "\<lbrakk>k < length ap; ap ! k = Dec n e; (a, b) \<in> set (abacus.tshift (abacus.tshift 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 "2 * n + start_of (layout_of ap) k + 16 = start_of (layout_of ap) (Suc k)
+ \<and> start_of (layout_of ap) (Suc k) \<le> start_of (layout_of ap) (length ap)")
+apply(simp add: startof_not0, rule_tac conjI)
+apply(simp add: start_of.simps layout_of.simps length_of.simps)
+apply(rule_tac start_of_all_le)
+apply(auto simp: tdec_b_def tshift.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(simp)
+apply(case_tac "ap!k", simp_all add: ci.simps tshift_append, auto intro: start_of_all_le)
+done
+lemma concat_in: "i < length (concat xs) \<Longrightarrow> \<exists>k < length xs. concat xs ! i \<in> set (xs ! k)"
+apply(induct xs rule: list_tl_induct, simp, simp)
+apply(case_tac "i < length (concat list)", simp)
+apply(erule_tac exE, rule_tac x = k in exI)
+apply(simp add: nth_append)
+apply(rule_tac x = "length list" in exI, simp)
+apply(simp add: nth_append)
+done
+
+lemma [simp]: "length (tms_of ap) = length ap"
+apply(simp add: tms_of.simps tpairs_of.simps)
+done
+
+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 add: tm_of.simps)
+using concat_in[of i "tms_of ap"]
+by simp
+
+lemma all_le_start_of: "list_all (\<lambda>(acn, s). s \<le> start_of (layout_of ap) (length ap)) (tm_of ap)"
+apply(simp add: 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(case_tac "ap ! k")
+apply(auto simp: layout_of.simps ci.simps
+ length_of.simps shift_length tinc_b_def tdec_b_def)
+done
+
+lemma [intro]: "length (ci ly y i) mod 2 = 0"
+apply(auto simp: ci.simps shift_length tinc_b_def tdec_b_def
+ split: abc_inst.splits)
+done
+
+lemma [intro]: "listsum (map (length \<circ> (\<lambda>(x, y). ci ly x y)) zs) mod 2 = 0"
+apply(induct zs rule: list_tl_induct, simp)
+apply(case_tac a, simp)
+apply(subgoal_tac "length (ci ly aa b) mod 2 = 0")
+apply(auto)
+done
+
+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, simp, case_tac ap, simp)
+ fix a ys ap aa list
+ assume ind: "\<And>(ap::'a list). length ys \<le> length ap \<Longrightarrow>
+ zip ys ap = zip ys (take (length ys) ap)"
+ and h: "length (a # ys) \<le> length ap" "(ap::'a list) = aa # (list::'a list)"
+ from h show "zip (a # ys) ap = zip (a # ys) (take (length (a # ys)) ap)"
+ using ind[of list]
+ apply(simp)
+ done
+qed
+
+lemma start_of_listsum:
+ "\<lbrakk>k \<le> length ap; length ss = k\<rbrakk> \<Longrightarrow> start_of (layout_of ap) k =
+ Suc (listsum (map (length \<circ> (\<lambda>(x, y). ci ly x y)) (zip ss ap)) div 2)"
+proof(induct k arbitrary: ss, simp add: start_of.simps, simp)
+ fix k ss
+ assume ind: "\<And>ss. length ss = k \<Longrightarrow> start_of (layout_of ap) k =
+ Suc (listsum (map (length \<circ> (\<lambda>(x, y). ci ly x y)) (zip ss ap)) div 2)"
+ and h: "Suc k \<le> length ap" "length (ss::nat list) = Suc k"
+ have "\<exists> ys y. ss = ys @ [y]"
+ using h
+ apply(rule_tac x = "butlast ss" in exI,
+ rule_tac x = "last ss" in exI)
+ apply(case_tac "ss = []", auto)
+ done
+ from this obtain ys y where k1: "ss = (ys::nat list) @ [y]"
+ by blast
+ from h and this have k2:
+ "start_of (layout_of ap) k =
+ Suc (listsum (map (length \<circ> (\<lambda>(x, y). ci ly x y)) (zip ys ap)) div 2)"
+ apply(rule_tac ind, simp)
+ done
+ have k3: "zip ys ap = zip ys (take k ap)"
+ using zip_pre[of ys ap] k1 h
+ apply(simp)
+ done
+ have k4: "(zip [y] (drop (length ys) ap)) = [(y, ap ! length ys)]"
+ using k1 h
+ apply(case_tac "drop (length ys) ap", simp)
+ apply(subgoal_tac "hd (drop (length ys) ap) = ap ! length ys")
+ apply(simp)
+ apply(rule_tac hd_drop_conv_nth, simp)
+ done
+ from k1 and h k2 k3 k4 show "start_of (layout_of ap) (Suc k) =
+ Suc (listsum (map (length \<circ> (\<lambda>(x, y). ci ly x y)) (zip ss ap)) div 2)"
+ apply(simp add: zip_append1 start_of.simps)
+ apply(subgoal_tac
+ "listsum (map (length \<circ> (\<lambda>(x, y). ci ly x y)) (zip ys (take k ap))) mod 2 = 0 \<and>
+ length (ci ly y (ap!k)) mod 2 = 0")
+ apply(auto)
+ apply(rule_tac length_ci, simp, simp)
+ done
+qed
+
+lemma length_start_of_tm: "start_of (layout_of ap) (length ap) = Suc (length (tm_of ap) div 2)"
+apply(simp add: tm_of.simps length_concat tms_of.simps tpairs_of.simps)
+apply(rule_tac start_of_listsum, simp, simp)
+done
+
+lemma tm_even: "length (tm_of ap) mod 2 = 0"
+apply(subgoal_tac "t_ncorrect (tm_of ap)", auto)
+apply(simp add: t_ncorrect.simps)
+done
+
+lemma [elim]: "list_all (\<lambda>(acn, s). s \<le> Suc q) xs
+ \<Longrightarrow> list_all (\<lambda>(acn, s). s \<le> q + (2 * n + 6)) xs"
+apply(simp add: list_all_length)
+apply(auto)
+done
+
+lemma [simp]: "length mp_up = 12"
+apply(simp add: mp_up_def)
+done
+
+lemma [elim]: "\<lbrakk>na < 4 * n; tshift (mop_bef n) q ! na = (a, b)\<rbrakk> \<Longrightarrow> b \<le> q + (2 * n + 6)"
+apply(induct n, simp, simp add: mop_bef.simps nth_append tshift_append shift_length)
+apply(case_tac "na < 4*n", simp, simp)
+apply(subgoal_tac "na = 4*n \<or> na = 1 + 4*n \<or> na = 2 + 4*n \<or> na = 3 + 4*n",
+ auto simp: shift_length)
+apply(simp_all add: tshift.simps)
+done
+
+lemma mp_up_all_le: "list_all (\<lambda>(acn, s). s \<le> q + (2 * n + 6))
+ [(R, Suc (Suc (2 * n + q))), (R, Suc (2 * n + q)),
+ (L, 5 + 2 * n + q), (W0, Suc (Suc (Suc (2 * n + q)))), (R, 4 + 2 * n + q),
+ (W0, Suc (Suc (Suc (2 * n + q)))), (R, Suc (Suc (2 * n + q))),
+ (W0, Suc (Suc (Suc (2 * n + q)))), (L, 5 + 2 * n + q),
+ (L, 6 + 2 * n + q), (R, 0), (L, 6 + 2 * n + q)]"
+apply(auto)
+done
+
+
+lemma [intro]: "list_all (\<lambda>(acn, s). s \<le> q + (2 * n + 6)) (tMp n q)"
+apply(auto simp: list_all_length tMp.simps tshift_append nth_append shift_length)
+apply(auto simp: tshift.simps mp_up_def)
+apply(subgoal_tac "na - 4*n \<ge> 0 \<and> na - 4 *n < 12", auto split: nat.splits)
+apply(insert mp_up_all_le[of q n])
+apply(simp add: list_all_length)
+apply(erule_tac x = "na - 4 * n" in allE, simp add: numeral_3_eq_3)
+done
+
+lemma t_compiled_correct:
+ "\<lbrakk>tp = tm_of ap; ly = layout_of ap; mop_ss = start_of ly (length ap)\<rbrakk> \<Longrightarrow>
+ t_correct (tp @ tMp n (mop_ss - Suc 0))"
+ using tm_even[of ap] length_start_of_tm[of ap] all_le_start_of[of ap]
+apply(auto simp: t_correct.simps iseven_def)
+apply(rule_tac x = "q + 2*n + 6" in exI, simp)
+done
+
+end
+
+
+
+
+
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/utm/turing_basic.thy Sat Sep 29 12:38:12 2012 +0000
@@ -0,0 +1,747 @@
+theory turing_basic
+imports Main
+begin
+
+section {* Basic definitions of Turing machine *}
+
+(* Title: Turing machine's definition and its charater
+ Author: Xu Jian <xujian817@hotmail.com>
+ Maintainer: Xu Jian
+*)
+
+text {*
+\label{description of turing machine}
+*}
+
+section {* Basic definitions of Turing machine *}
+
+(* Title: Turing machine's definition and its charater
+ Author: Xu Jian <xujian817@hotmail.com>
+ Maintainer: Xu Jian
+*)
+
+text {*
+ Actions of Turing machine (Abbreviated TM in the following* ).
+*}
+
+datatype taction =
+ -- {* Write zero *}
+ W0 |
+ -- {* Write one *}
+ W1 |
+ -- {* Move left *}
+ L |
+ -- {* Move right *}
+ R |
+ -- {* Do nothing *}
+ Nop
+
+text {*
+ Tape contents in every block.
+*}
+
+datatype block =
+ -- {* Blank *}
+ Bk |
+ -- {* Occupied *}
+ Oc
+
+text {*
+ Tape is represented as a pair of lists $(L_{left}, L_{right})$,
+ where $L_left$, named {\em left list}, is used to represent
+ the tape to the left of RW-head and
+ $L_{right}$, named {\em right list}, is used to represent the tape
+ under and to the right of RW-head.
+*}
+
+type_synonym tape = "block list \<times> block list"
+
+text {* The state of turing machine.*}
+type_synonym tstate = nat
+
+text {*
+ Turing machine instruction is represented as a
+ pair @{text "(action, next_state)"},
+ where @{text "action"} is the action to take at the current state
+ and @{text "next_state"} is the next state the machine is getting into
+ after the action.
+*}
+type_synonym tinst = "taction \<times> tstate"
+
+text {*
+ Program of Turing machine is represented as a list of Turing instructions
+ and the execution of the program starts from the head of the list.
+ *}
+type_synonym tprog = "tinst list"
+
+
+text {*
+ Turing machine configuration, which consists of the current state
+ and the tape.
+*}
+type_synonym t_conf = "tstate \<times> tape"
+
+fun nth_of :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option"
+ where
+ "nth_of xs n = (if n < length xs then Some (xs!n)
+ else None)"
+
+text {*
+ The function used to fetech instruction out of Turing program.
+ *}
+
+fun fetch :: "tprog \<Rightarrow> tstate \<Rightarrow> block \<Rightarrow> tinst"
+ where
+ "fetch p s b = (if s = 0 then (Nop, 0) else
+ case b of
+ Bk \<Rightarrow> case nth_of p (2 * (s - 1)) of
+ Some i \<Rightarrow> i
+ | None \<Rightarrow> (Nop, 0)
+ | Oc \<Rightarrow> case nth_of p (2 * (s - 1) +1) of
+ Some i \<Rightarrow> i
+ | None \<Rightarrow> (Nop, 0))"
+
+
+fun new_tape :: "taction \<Rightarrow> tape \<Rightarrow> tape"
+where
+ "new_tape action (leftn, rightn) = (case action of
+ W0 \<Rightarrow> (leftn, Bk#(tl rightn)) |
+ W1 \<Rightarrow> (leftn, Oc#(tl rightn)) |
+ L \<Rightarrow> (if leftn = [] then (tl leftn, Bk#rightn)
+ else (tl leftn, (hd leftn) # rightn)) |
+ R \<Rightarrow> if rightn = [] then (Bk#leftn,tl rightn)
+ else ((hd rightn)#leftn, tl rightn) |
+ Nop \<Rightarrow> (leftn, rightn)
+ )"
+
+text {*
+ The one step function used to transfer Turing machine configuration.
+*}
+fun tstep :: "t_conf \<Rightarrow> tprog \<Rightarrow> t_conf"
+ where
+ "tstep c p = (let (s, l, r) = c in
+ let (ac, ns) = (fetch p s (case r of [] \<Rightarrow> Bk |
+ x # xs \<Rightarrow> x)) in
+ (ns, new_tape ac (l, r)))"
+
+text {*
+ The many-step function.
+*}
+fun steps :: "t_conf \<Rightarrow> tprog \<Rightarrow> nat \<Rightarrow> t_conf"
+ where
+ "steps c p 0 = c" |
+ "steps c p (Suc n) = steps (tstep c p) p n"
+
+lemma tstep_red: "steps c p (Suc n) = tstep (steps c p n) p"
+proof(induct n arbitrary: c)
+ fix c
+ show "steps c p (Suc 0) = tstep (steps c p 0) p" by(simp add: steps.simps)
+next
+ fix n c
+ assume ind: "\<And> c. steps c p (Suc n) = tstep (steps c p n) p"
+ have "steps (tstep c p) p (Suc n) = tstep (steps (tstep c p) p n) p"
+ by(rule ind)
+ thus "steps c p (Suc (Suc n)) = tstep (steps c p (Suc n)) p" by(simp add: steps.simps)
+qed
+
+declare Let_def[simp] option.split[split]
+
+definition
+ "iseven n \<equiv> \<exists> x. n = 2 * x"
+
+
+text {*
+ The following @{text "t_correct"} function is used to specify the wellformedness of Turing
+ machine.
+*}
+fun t_correct :: "tprog \<Rightarrow> bool"
+ where
+ "t_correct p = (length p \<ge> 2 \<and> iseven (length p) \<and>
+ list_all (\<lambda> (acn, s). s \<le> length p div 2) p)"
+
+declare t_correct.simps[simp del]
+
+lemma allimp: "\<lbrakk>\<forall>x. P x \<longrightarrow> Q x; \<forall>x. P x\<rbrakk> \<Longrightarrow> \<forall>x. Q x"
+by(auto elim: allE)
+
+lemma halt_lemma: "\<lbrakk>wf LE; \<forall> n. (\<not> P (f n) \<longrightarrow> (f (Suc n), (f n)) \<in> LE)\<rbrakk> \<Longrightarrow> \<exists> n. P (f n)"
+apply(rule exCI, drule allimp, auto)
+apply(drule_tac f = f in wf_inv_image, simp add: inv_image_def)
+apply(erule wf_induct, auto)
+done
+
+lemma steps_add: "steps c t (x + y) = steps (steps c t x) t y"
+by(induct x arbitrary: c, auto simp: steps.simps tstep_red)
+
+lemma listall_set: "list_all p t \<Longrightarrow> \<forall> a \<in> set t. p a"
+by(induct t, auto)
+
+lemma fetch_ex: "\<exists>b a. fetch T aa ab = (b, a)"
+by(simp add: fetch.simps)
+definition exponent :: "'a \<Rightarrow> nat \<Rightarrow> 'a list" ("_\<^bsup>_\<^esup>" [0, 0]100)
+ where "exponent x n = replicate n x"
+
+text {*
+ @{text "tinres l1 l2"} means left list @{text "l1"} is congruent with
+ @{text "l2"} with respect to the execution of Turing machine.
+ Appending Blank to the right of eigther one does not affect the
+ outcome of excution.
+*}
+
+definition tinres :: "block list \<Rightarrow> block list \<Rightarrow> bool"
+ where
+ "tinres bx by = (\<exists> n. bx = by@Bk\<^bsup>n\<^esup> \<or> by = bx @ Bk\<^bsup>n\<^esup>)"
+
+lemma exp_zero: "a\<^bsup>0\<^esup> = []"
+by(simp add: exponent_def)
+lemma exp_ind_def: "a\<^bsup>Suc x \<^esup> = a # a\<^bsup>x\<^esup>"
+by(simp add: exponent_def)
+
+text {*
+ The following lemma shows the meaning of @{text "tinres"} with respect to
+ one step execution.
+ *}
+lemma tinres_step:
+ "\<lbrakk>tinres l l'; tstep (ss, l, r) t = (sa, la, ra); tstep (ss, l', r) t = (sb, lb, rb)\<rbrakk>
+ \<Longrightarrow> tinres la lb \<and> ra = rb \<and> sa = sb"
+apply(auto simp: tstep.simps fetch.simps new_tape.simps
+ split: if_splits taction.splits list.splits
+ block.splits)
+apply(case_tac [!] "t ! (2 * (ss - Suc 0))",
+ auto simp: exponent_def tinres_def split: if_splits taction.splits list.splits
+ block.splits)
+apply(case_tac [!] "t ! (2 * (ss - Suc 0) + Suc 0)",
+ auto simp: exponent_def tinres_def split: if_splits taction.splits list.splits
+ block.splits)
+done
+
+declare tstep.simps[simp del] steps.simps[simp del]
+
+text {*
+ The following lemma shows the meaning of @{text "tinres"} with respect to
+ many step execution.
+ *}
+lemma tinres_steps:
+ "\<lbrakk>tinres l l'; steps (ss, l, r) t stp = (sa, la, ra); steps (ss, l', r) t stp = (sb, lb, rb)\<rbrakk>
+ \<Longrightarrow> tinres la lb \<and> ra = rb \<and> sa = sb"
+apply(induct stp arbitrary: sa la ra sb lb rb, simp add: steps.simps)
+apply(simp add: tstep_red)
+apply(case_tac "(steps (ss, l, r) t stp)")
+apply(case_tac "(steps (ss, l', r) t 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 stp = (sa, la, ra);
+ steps (ss, l', r) t stp = (sb, lb, rb)\<rbrakk> \<Longrightarrow> tinres la lb \<and> ra = rb \<and> sa = sb"
+ and h: " tinres l l'" "tstep (steps (ss, l, r) t stp) t = (sa, la, ra)"
+ "tstep (steps (ss, l', r) t stp) t = (sb, lb, rb)" "steps (ss, l, r) t stp = (a, b, c)"
+ "steps (ss, l', r) t stp = (aa, ba, ca)"
+ have "tinres b ba \<and> c = ca \<and> a = aa"
+ apply(rule_tac ind, simp_all add: h)
+ done
+ thus "tinres la lb \<and> ra = rb \<and> sa = sb"
+ apply(rule_tac l = b and l' = ba and r = c and ss = a
+ and t = t in tinres_step)
+ using h
+ apply(simp, simp, simp)
+ done
+qed
+
+text {*
+ The following function @{text "tshift tp n"} is used to shift Turing programs
+ @{text "tp"} by @{text "n"} when it is going to be combined with others.
+ *}
+
+fun tshift :: "tprog \<Rightarrow> nat \<Rightarrow> tprog"
+ where
+ "tshift tp off = (map (\<lambda> (action, state). (action, (if state = 0 then 0
+ else state + off))) tp)"
+
+text {*
+ When two Turing programs are combined, the end state (state @{text "0"}) of the one
+ at the prefix position needs to be connected to the start state
+ of the one at postfix position. If @{text "tp"} is the Turing program
+ to be at the prefix, @{text "change_termi_state tp"} is the transformed Turing program.
+ *}
+fun change_termi_state :: "tprog \<Rightarrow> tprog"
+ where
+ "change_termi_state t =
+ (map (\<lambda> (acn, ns). if ns = 0 then (acn, Suc ((length t) div 2)) else (acn, ns)) t)"
+
+text {*
+ @{text "t_add tp1 tp2"} is the combined Truing program.
+*}
+
+fun t_add :: "tprog \<Rightarrow> tprog \<Rightarrow> tprog" ("_ |+| _" [0, 0] 100)
+ where
+ "t_add t1 t2 = ((change_termi_state t1) @ (tshift t2 ((length t1) div 2)))"
+
+text {*
+ Tests whether the current configuration is at state @{text "0"}.
+*}
+definition isS0 :: "t_conf \<Rightarrow> bool"
+ where
+ "isS0 c = (let (s, l, r) = c in s = 0)"
+
+declare tstep.simps[simp del] steps.simps[simp del]
+ t_add.simps[simp del] fetch.simps[simp del]
+ new_tape.simps[simp del]
+
+
+text {*
+ Single step execution starting from state @{text "0"} will not make any progress.
+*}
+lemma tstep_0: "tstep (0, tp) p = (0, tp)"
+apply(simp add: tstep.simps fetch.simps new_tape.simps)
+done
+
+
+text {*
+ Many step executions starting from state @{text "0"} will not make any progress.
+*}
+
+lemma steps_0: "steps (0, tp) p stp = (0, tp)"
+apply(induct stp)
+apply(simp add: steps.simps)
+apply(simp add: tstep_red tstep_0)
+done
+
+lemma s_keep_step: "\<lbrakk>a \<le> length A div 2; tstep (a, b, c) A = (s, l, r); t_correct A\<rbrakk>
+ \<Longrightarrow> s \<le> length A div 2"
+apply(simp add: tstep.simps fetch.simps t_correct.simps iseven_def
+ split: if_splits block.splits list.splits)
+apply(case_tac [!] a, auto simp: list_all_length)
+apply(erule_tac x = "2 * nat" in allE, auto)
+apply(erule_tac x = "2 * nat" in allE, auto)
+apply(erule_tac x = "Suc (2 * nat)" in allE, auto)
+done
+
+lemma s_keep: "\<lbrakk>steps (Suc 0, tp) A stp = (s, l, r); t_correct A\<rbrakk> \<Longrightarrow> s \<le> length A div 2"
+proof(induct stp arbitrary: s l r)
+ case 0 thus "?case" by(auto simp: t_correct.simps steps.simps)
+next
+ fix stp s l r
+ assume ind: "\<And>s l r. \<lbrakk>steps (Suc 0, tp) A stp = (s, l, r); t_correct A\<rbrakk> \<Longrightarrow> s \<le> length A div 2"
+ and h1: "steps (Suc 0, tp) A (Suc stp) = (s, l, r)"
+ and h2: "t_correct A"
+ from h1 h2 show "s \<le> length A div 2"
+ proof(simp add: tstep_red, cases "(steps (Suc 0, tp) A stp)", simp)
+ fix a b c
+ assume h3: "tstep (a, b, c) A = (s, l, r)"
+ and h4: "steps (Suc 0, tp) A stp = (a, b, c)"
+ have "a \<le> length A div 2"
+ using h2 h4
+ by(rule_tac l = b and r = c in ind, auto)
+ thus "?thesis"
+ using h3 h2
+ by(simp add: s_keep_step)
+ qed
+qed
+
+lemma t_merge_fetch_pre:
+ "\<lbrakk>fetch A s b = (ac, ns); s \<le> length A div 2; t_correct A; s \<noteq> 0\<rbrakk> \<Longrightarrow>
+ fetch (A |+| B) s b = (ac, if ns = 0 then Suc (length A div 2) else ns)"
+apply(subgoal_tac "2 * (s - Suc 0) < length A \<and> Suc (2 * (s - Suc 0)) < length A")
+apply(auto simp: fetch.simps t_add.simps split: if_splits block.splits)
+apply(simp_all add: nth_append change_termi_state.simps)
+done
+
+lemma [simp]: "\<lbrakk>\<not> a \<le> length A div 2; t_correct A\<rbrakk> \<Longrightarrow> fetch A a b = (Nop, 0)"
+apply(auto simp: fetch.simps del: nth_of.simps split: block.splits)
+apply(case_tac [!] a, auto simp: t_correct.simps iseven_def)
+done
+
+lemma [elim]: "\<lbrakk>t_correct A; \<not> isS0 (tstep (a, b, c) A)\<rbrakk> \<Longrightarrow> a \<le> length A div 2"
+apply(rule_tac classical, auto simp: tstep.simps new_tape.simps isS0_def)
+done
+
+lemma [elim]: "\<lbrakk>t_correct A; \<not> isS0 (tstep (a, b, c) A)\<rbrakk> \<Longrightarrow> 0 < a"
+apply(rule_tac classical, simp add: tstep_0 isS0_def)
+done
+
+
+lemma t_merge_pre_eq_step: "\<lbrakk>tstep (a, b, c) A = cf; t_correct A; \<not> isS0 cf\<rbrakk>
+ \<Longrightarrow> tstep (a, b, c) (A |+| B) = cf"
+apply(subgoal_tac "a \<le> length A div 2 \<and> a \<noteq> 0")
+apply(simp add: tstep.simps)
+apply(case_tac "fetch A a (case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)", simp)
+apply(drule_tac B = B in t_merge_fetch_pre, simp, simp, simp, simp add: isS0_def, auto)
+done
+
+lemma t_merge_pre_eq: "\<lbrakk>steps (Suc 0, tp) A stp = cf; \<not> isS0 cf; t_correct A\<rbrakk>
+ \<Longrightarrow> steps (Suc 0, tp) (A |+| B) stp = cf"
+proof(induct stp arbitrary: cf)
+ case 0 thus "?case" by(simp add: steps.simps)
+next
+ fix stp cf
+ assume ind: "\<And>cf. \<lbrakk>steps (Suc 0, tp) A stp = cf; \<not> isS0 cf; t_correct A\<rbrakk>
+ \<Longrightarrow> steps (Suc 0, tp) (A |+| B) stp = cf"
+ and h1: "steps (Suc 0, tp) A (Suc stp) = cf"
+ and h2: "\<not> isS0 cf"
+ and h3: "t_correct A"
+ from h1 h2 h3 show "steps (Suc 0, tp) (A |+| B) (Suc stp) = cf"
+ proof(simp add: tstep_red, cases "steps (Suc 0, tp) (A) stp", simp)
+ fix a b c
+ assume h4: "tstep (a, b, c) A = cf"
+ and h5: "steps (Suc 0, tp) A stp = (a, b, c)"
+ have "steps (Suc 0, tp) (A |+| B) stp = (a, b, c)"
+ proof(cases a)
+ case 0 thus "?thesis"
+ using h4 h2
+ apply(simp add: tstep_0, cases cf, simp add: isS0_def)
+ done
+ next
+ case (Suc n) thus "?thesis"
+ using h5 h3
+ apply(rule_tac ind, auto simp: isS0_def)
+ done
+ qed
+ thus "tstep (steps (Suc 0, tp) (A |+| B) stp) (A |+| B) = cf"
+ using h4 h5 h3 h2
+ apply(simp)
+ apply(rule t_merge_pre_eq_step, auto)
+ done
+ qed
+qed
+
+declare nth.simps[simp del] tshift.simps[simp del] change_termi_state.simps[simp del]
+
+lemma [simp]: "length (change_termi_state A) = length A"
+by(simp add: change_termi_state.simps)
+
+lemma first_halt_point: "steps (Suc 0, tp) A stp = (0, tp')
+ \<Longrightarrow> \<exists>stp. \<not> isS0 (steps (Suc 0, tp) A stp) \<and> steps (Suc 0, tp) A (Suc stp) = (0, tp')"
+proof(induct stp)
+ case 0 thus "?case" by(simp add: steps.simps)
+next
+ case (Suc n)
+ fix stp
+ assume ind: "steps (Suc 0, tp) A stp = (0, tp') \<Longrightarrow>
+ \<exists>stp. \<not> isS0 (steps (Suc 0, tp) A stp) \<and> steps (Suc 0, tp) A (Suc stp) = (0, tp')"
+ and h: "steps (Suc 0, tp) A (Suc stp) = (0, tp')"
+ from h show "\<exists>stp. \<not> isS0 (steps (Suc 0, tp) A stp) \<and> steps (Suc 0, tp) A (Suc stp) = (0, tp')"
+ proof(simp add: tstep_red, cases "steps (Suc 0, tp) A stp", simp, case_tac a)
+ fix a b c
+ assume g1: "a = (0::nat)"
+ and g2: "tstep (a, b, c) A = (0, tp')"
+ and g3: "steps (Suc 0, tp) A stp = (a, b, c)"
+ have "steps (Suc 0, tp) A stp = (0, tp')"
+ using g2 g1 g3
+ by(simp add: tstep_0)
+ hence "\<exists> stp. \<not> isS0 (steps (Suc 0, tp) A stp) \<and> steps (Suc 0, tp) A (Suc stp) = (0, tp')"
+ by(rule ind)
+ thus "\<exists>stp. \<not> isS0 (steps (Suc 0, tp) A stp) \<and> tstep (steps (Suc 0, tp) A stp) A = (0, tp')"
+ apply(simp add: tstep_red)
+ done
+ next
+ fix a b c nat
+ assume g1: "steps (Suc 0, tp) A stp = (a, b, c)"
+ and g2: "steps (Suc 0, tp) A (Suc stp) = (0, tp')" "a= Suc nat"
+ thus "\<exists>stp. \<not> isS0 (steps (Suc 0, tp) A stp) \<and> tstep (steps (Suc 0, tp) A stp) A = (0, tp')"
+ apply(rule_tac x = stp in exI)
+ apply(simp add: isS0_def tstep_red)
+ done
+ qed
+qed
+
+lemma t_merge_pre_halt_same':
+ "\<lbrakk>\<not> isS0 (steps (Suc 0, tp) A stp) ; steps (Suc 0, tp) A (Suc stp) = (0, tp'); t_correct A\<rbrakk>
+ \<Longrightarrow> steps (Suc 0, tp) (A |+| B) (Suc stp) = (Suc (length A div 2), tp')"
+proof(simp add: tstep_red, cases "steps (Suc 0, tp) A stp", simp)
+ fix a b c
+ assume h1: "\<not> isS0 (a, b, c)"
+ and h2: "tstep (a, b, c) A = (0, tp')"
+ and h3: "t_correct A"
+ and h4: "steps (Suc 0, tp) A stp = (a, b, c)"
+ have "steps (Suc 0, tp) (A |+| B) stp = (a, b, c)"
+ using h1 h4 h3
+ apply(rule_tac t_merge_pre_eq, auto)
+ done
+ moreover have "tstep (a, b, c) (A |+| B) = (Suc (length A div 2), tp')"
+ using h2 h3 h1 h4
+ apply(simp add: tstep.simps)
+ apply(case_tac " fetch A a (case c of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)", simp)
+ apply(drule_tac B = B in t_merge_fetch_pre, auto simp: isS0_def intro: s_keep)
+ done
+ ultimately show "tstep (steps (Suc 0, tp) (A |+| B) stp) (A |+| B) = (Suc (length A div 2), tp')"
+ by(simp)
+qed
+
+text {*
+ When Turing machine @{text "A"} and @{text "B"} are combined and the execution
+ of @{text "A"} can termination within @{text "stp"} steps,
+ the combined machine @{text "A |+| B"} will eventually get into the starting
+ state of machine @{text "B"}.
+*}
+lemma t_merge_pre_halt_same: "
+ \<lbrakk>steps (Suc 0, tp) A stp = (0, tp'); t_correct A; t_correct B\<rbrakk>
+ \<Longrightarrow> \<exists> stp. steps (Suc 0, tp) (A |+| B) stp = (Suc (length A div 2), tp')"
+proof -
+ assume a_wf: "t_correct A"
+ and b_wf: "t_correct B"
+ and a_ht: "steps (Suc 0, tp) A stp = (0, tp')"
+ have halt_point: "\<exists> stp. \<not> isS0 (steps (Suc 0, tp) A stp) \<and> steps (Suc 0, tp) A (Suc stp) = (0, tp')"
+ using a_ht
+ by(erule_tac first_halt_point)
+ then obtain stp' where "\<not> isS0 (steps (Suc 0, tp) A stp') \<and> steps (Suc 0, tp) A (Suc stp') = (0, tp')"..
+ hence "steps (Suc 0, tp) (A |+| B) (Suc stp') = (Suc (length A div 2), tp')"
+ using a_wf
+ apply(rule_tac t_merge_pre_halt_same', auto)
+ done
+ thus "?thesis" ..
+qed
+
+lemma fetch_0: "fetch p 0 b = (Nop, 0)"
+by(simp add: fetch.simps)
+
+lemma [simp]: "length (tshift B x) = length B"
+by(simp add: tshift.simps)
+
+lemma [simp]: "t_correct A \<Longrightarrow> 2 * (length A div 2) = length A"
+apply(simp add: t_correct.simps iseven_def, auto)
+done
+
+lemma t_merge_fetch_snd:
+ "\<lbrakk>fetch B a b = (ac, ns); t_correct A; t_correct B; a > 0 \<rbrakk>
+ \<Longrightarrow> fetch (A |+| B) (a + length A div 2) b
+ = (ac, if ns = 0 then 0 else ns + length A div 2)"
+apply(auto simp: fetch.simps t_add.simps split: if_splits block.splits)
+apply(case_tac [!] a, simp_all)
+apply(simp_all add: nth_append change_termi_state.simps tshift.simps)
+done
+
+lemma t_merge_snd_eq_step:
+ "\<lbrakk>tstep (s, l, r) B = (s', l', r'); t_correct A; t_correct B; s > 0\<rbrakk>
+ \<Longrightarrow> tstep (s + length A div 2, l, r) (A |+| B) =
+ (if s' = 0 then 0 else s' + length A div 2, l' ,r') "
+apply(simp add: tstep.simps)
+apply(cases "fetch B s (case r of [] \<Rightarrow> Bk | x # xs \<Rightarrow> x)")
+apply(auto simp: t_merge_fetch_snd)
+apply(frule_tac [!] t_merge_fetch_snd, auto)
+done
+
+text {*
+ Relates the executions of TM @{text "B"}, one is when @{text "B"} is executed alone,
+ the other is the execution when @{text "B"} is in the combined TM.
+*}
+lemma t_merge_snd_eq_steps:
+ "\<lbrakk>t_correct A; t_correct B; steps (s, l, r) B stp = (s', l', r'); s > 0\<rbrakk>
+ \<Longrightarrow> steps (s + length A div 2, l, r) (A |+| B) stp =
+ (if s' = 0 then 0 else s' + length A div 2, l', r')"
+proof(induct stp arbitrary: s' l' r')
+ case 0 thus "?case"
+ by(simp add: steps.simps)
+next
+ fix stp s' l' r'
+ assume ind: "\<And>s' l' r'. \<lbrakk>t_correct A; t_correct B; steps (s, l, r) B stp = (s', l', r'); 0 < s\<rbrakk>
+ \<Longrightarrow> steps (s + length A div 2, l, r) (A |+| B) stp =
+ (if s' = 0 then 0 else s' + length A div 2, l', r')"
+ and h1: "steps (s, l, r) B (Suc stp) = (s', l', r')"
+ and h2: "t_correct A"
+ and h3: "t_correct B"
+ and h4: "0 < s"
+ from h1 show "steps (s + length A div 2, l, r) (A |+| B) (Suc stp)
+ = (if s' = 0 then 0 else s' + length A div 2, l', r')"
+ proof(simp only: tstep_red, cases "steps (s, l, r) B stp")
+ fix a b c
+ assume h5: "steps (s, l, r) B stp = (a, b, c)" "tstep (steps (s, l, r) B stp) B = (s', l', r')"
+ hence h6: "(steps (s + length A div 2, l, r) (A |+| B) stp) =
+ ((if a = 0 then 0 else a + length A div 2, b, c))"
+ using h2 h3 h4
+ by(rule_tac ind, auto)
+ thus "tstep (steps (s + length A div 2, l, r) (A |+| B) stp) (A |+| B) =
+ (if s' = 0 then 0 else s'+ length A div 2, l', r')"
+ using h5
+ proof(auto)
+ assume "tstep (0, b, c) B = (0, l', r')" thus "tstep (0, b, c) (A |+| B) = (0, l', r')"
+ by(simp add: tstep_0)
+ next
+ assume "tstep (0, b, c) B = (s', l', r')" "0 < s'"
+ thus "tstep (0, b, c) (A |+| B) = (s' + length A div 2, l', r')"
+ by(simp add: tstep_0)
+ next
+ assume "tstep (a, b, c) B = (0, l', r')" "0 < a"
+ thus "tstep (a + length A div 2, b, c) (A |+| B) = (0, l', r')"
+ using h2 h3
+ by(drule_tac t_merge_snd_eq_step, auto)
+ next
+ assume "tstep (a, b, c) B = (s', l', r')" "0 < a" "0 < s'"
+ thus "tstep (a + length A div 2, b, c) (A |+| B) = (s' + length A div 2, l', r')"
+ using h2 h3
+ by(drule_tac t_merge_snd_eq_step, auto)
+ qed
+ qed
+qed
+
+lemma t_merge_snd_halt_eq:
+ "\<lbrakk>steps (Suc 0, tp) B stp = (0, tp'); t_correct A; t_correct B\<rbrakk>
+ \<Longrightarrow> \<exists>stp. steps (Suc (length A div 2), tp) (A |+| B) stp = (0, tp')"
+apply(case_tac tp, cases tp', simp)
+apply(drule_tac s = "Suc 0" in t_merge_snd_eq_steps, auto)
+done
+
+lemma t_inj: "\<lbrakk>steps (Suc 0, tp) A stpa = (0, tp1); steps (Suc 0, tp) A stpb = (0, tp2)\<rbrakk>
+ \<Longrightarrow> tp1 = tp2"
+proof -
+ assume h1: "steps (Suc 0, tp) A stpa = (0, tp1)"
+ and h2: "steps (Suc 0, tp) A stpb = (0, tp2)"
+ thus "?thesis"
+ proof(cases "stpa < stpb")
+ case True thus "?thesis"
+ using h1 h2
+ apply(drule_tac less_imp_Suc_add, auto)
+ apply(simp del: add_Suc_right add_Suc add: add_Suc_right[THEN sym] steps_add steps_0)
+ done
+ next
+ case False thus "?thesis"
+ using h1 h2
+ apply(drule_tac leI)
+ apply(case_tac "stpb = stpa", auto)
+ apply(subgoal_tac "stpb < stpa")
+ apply(drule_tac less_imp_Suc_add, auto)
+ apply(simp del: add_Suc_right add_Suc add: add_Suc_right[THEN sym] steps_add steps_0)
+ done
+ qed
+qed
+
+type_synonym t_assert = "tape \<Rightarrow> bool"
+
+definition t_imply :: "t_assert \<Rightarrow> t_assert \<Rightarrow> bool" ("_ \<turnstile>-> _" [0, 0] 100)
+ where
+ "t_imply a1 a2 = (\<forall> tp. a1 tp \<longrightarrow> a2 tp)"
+
+
+locale turing_merge =
+ fixes A :: "tprog" and B :: "tprog" and P1 :: "t_assert"
+ and P2 :: "t_assert"
+ and P3 :: "t_assert"
+ and P4 :: "t_assert"
+ and Q1:: "t_assert"
+ and Q2 :: "t_assert"
+ assumes
+ A_wf : "t_correct A"
+ and B_wf : "t_correct B"
+ and A_halt : "P1 tp \<Longrightarrow> \<exists> stp. let (s, tp') = steps (Suc 0, tp) A stp in s = 0 \<and> Q1 tp'"
+ and B_halt : "P2 tp \<Longrightarrow> \<exists> stp. let (s, tp') = steps (Suc 0, tp) B stp in s = 0 \<and> Q2 tp'"
+ and A_uhalt : "P3 tp \<Longrightarrow> \<not> (\<exists> stp. isS0 (steps (Suc 0, tp) A stp))"
+ and B_uhalt: "P4 tp \<Longrightarrow> \<not> (\<exists> stp. isS0 (steps (Suc 0, tp) B stp))"
+begin
+
+
+text {*
+ The following lemma tries to derive the Hoare logic rule for sequentially combined TMs.
+ It deals with the situtation when both @{text "A"} and @{text "B"} are terminated.
+*}
+
+lemma t_merge_halt:
+ assumes aimpb: "Q1 \<turnstile>-> P2"
+ shows "P1 \<turnstile>-> \<lambda> tp. (\<exists> stp tp'. steps (Suc 0, tp) (A |+| B) stp = (0, tp') \<and> Q2 tp')"
+proof(simp add: t_imply_def, auto)
+ fix a b
+ assume h: "P1 (a, b)"
+ hence "\<exists> stp. let (s, tp') = steps (Suc 0, a, b) A stp in s = 0 \<and> Q1 tp'"
+ using A_halt by simp
+ from this obtain stp1 where "let (s, tp') = steps (Suc 0, a, b) A stp1 in s = 0 \<and> Q1 tp'" ..
+ thus "\<exists>stp aa ba. steps (Suc 0, a, b) (A |+| B) stp = (0, aa, ba) \<and> Q2 (aa, ba)"
+ proof(case_tac "steps (Suc 0, a, b) A stp1", simp, erule_tac conjE)
+ fix aa ba c
+ assume g1: "Q1 (ba, c)"
+ and g2: "steps (Suc 0, a, b) A stp1 = (0, ba, c)"
+ hence "P2 (ba, c)"
+ using aimpb apply(simp add: t_imply_def)
+ done
+ hence "\<exists> stp. let (s, tp') = steps (Suc 0, ba, c) B stp in s = 0 \<and> Q2 tp'"
+ using B_halt by simp
+ from this obtain stp2 where "let (s, tp') = steps (Suc 0, ba, c) B stp2 in s = 0 \<and> Q2 tp'" ..
+ thus "?thesis"
+ proof(case_tac "steps (Suc 0, ba, c) B stp2", simp, erule_tac conjE)
+ fix aa bb ca
+ assume g3: " Q2 (bb, ca)" "steps (Suc 0, ba, c) B stp2 = (0, bb, ca)"
+ have "\<exists> stp. steps (Suc 0, a, b) (A |+| B) stp = (Suc (length A div 2), ba , c)"
+ using g2 A_wf B_wf
+ by(rule_tac t_merge_pre_halt_same, auto)
+ moreover have "\<exists> stp. steps (Suc (length A div 2), ba, c) (A |+| B) stp = (0, bb, ca)"
+ using g3 A_wf B_wf
+ apply(rule_tac t_merge_snd_halt_eq, auto)
+ done
+ ultimately show "\<exists>stp aa ba. steps (Suc 0, a, b) (A |+| B) stp = (0, aa, ba) \<and> Q2 (aa, ba)"
+ apply(erule_tac exE, erule_tac exE)
+ apply(rule_tac x = "stp + stpa" in exI, simp add: steps_add)
+ using g3 by simp
+ qed
+ qed
+qed
+
+lemma t_merge_uhalt_tmp:
+ assumes B_uh: "\<forall>stp. \<not> isS0 (steps (Suc 0, b, c) B stp)"
+ and merge_ah: "steps (Suc 0, tp) (A |+| B) stpa = (Suc (length A div 2), b, c)"
+ shows "\<forall> stp. \<not> isS0 (steps (Suc 0, tp) (A |+| B) stp)"
+ using B_uh merge_ah
+apply(rule_tac allI)
+apply(case_tac "stp > stpa")
+apply(erule_tac x = "stp - stpa" in allE)
+apply(case_tac "(steps (Suc 0, b, c) B (stp - stpa))", simp)
+proof -
+ fix stp a ba ca
+ assume h1: "\<not> isS0 (a, ba, ca)" "stpa < stp"
+ and h2: "steps (Suc 0, b, c) B (stp - stpa) = (a, ba, ca)"
+ have "steps (Suc 0 + length A div 2, b, c) (A |+| B) (stp - stpa) =
+ (if a = 0 then 0 else a + length A div 2, ba, ca)"
+ using A_wf B_wf h2
+ by(rule_tac t_merge_snd_eq_steps, auto)
+ moreover have "a > 0" using h1 by(simp add: isS0_def)
+ moreover have "\<exists> stpb. stp = stpa + stpb"
+ using h1 by(rule_tac x = "stp - stpa" in exI, simp)
+ ultimately show "\<not> isS0 (steps (Suc 0, tp) (A |+| B) stp)"
+ using merge_ah
+ by(auto simp: steps_add isS0_def)
+next
+ fix stp
+ assume h: "steps (Suc 0, tp) (A |+| B) stpa = (Suc (length A div 2), b, c)" "\<not> stpa < stp"
+ hence "\<exists> stpb. stpa = stp + stpb" apply(rule_tac x = "stpa - stp" in exI, auto) done
+ thus "\<not> isS0 (steps (Suc 0, tp) (A |+| B) stp)"
+ using h
+ apply(auto)
+ apply(cases "steps (Suc 0, tp) (A |+| B) stp", simp add: steps_add isS0_def steps_0)
+ done
+qed
+
+text {*
+ The following lemma deals with the situation when TM @{text "B"} can not terminate.
+ *}
+
+lemma t_merge_uhalt:
+ assumes aimpb: "Q1 \<turnstile>-> P4"
+ shows "P1 \<turnstile>-> \<lambda> tp. \<not> (\<exists> stp. isS0 (steps (Suc 0, tp) (A |+| B) stp))"
+proof(simp only: t_imply_def, rule_tac allI, rule_tac impI)
+ fix tp
+ assume init_asst: "P1 tp"
+ show "\<not> (\<exists>stp. isS0 (steps (Suc 0, tp) (A |+| B) stp))"
+ proof -
+ have "\<exists> stp. let (s, tp') = steps (Suc 0, tp) A stp in s = 0 \<and> Q1 tp'"
+ using A_halt[of tp] init_asst
+ by(simp)
+ from this obtain stpx where "let (s, tp') = steps (Suc 0, tp) A stpx in s = 0 \<and> Q1 tp'" ..
+ thus "?thesis"
+ proof(cases "steps (Suc 0, tp) A stpx", simp, erule_tac conjE)
+ fix a b c
+ assume "Q1 (b, c)"
+ and h3: "steps (Suc 0, tp) A stpx = (0, b, c)"
+ hence h2: "P4 (b, c)" using aimpb
+ by(simp add: t_imply_def)
+ have "\<exists> stp. steps (Suc 0, tp) (A |+| B) stp = (Suc (length A div 2), b, c)"
+ using h3 A_wf B_wf
+ apply(rule_tac stp = stpx in t_merge_pre_halt_same, auto)
+ done
+ from this obtain stpa where h4:"steps (Suc 0, tp) (A |+| B) stpa = (Suc (length A div 2), b, c)" ..
+ have " \<not> (\<exists> stp. isS0 (steps (Suc 0, b, c) B stp))"
+ using B_uhalt [of "(b, c)"] h2 apply simp
+ done
+ from this and h4 show "\<forall>stp. \<not> isS0 (steps (Suc 0, tp) (A |+| B) stp)"
+ by(rule_tac t_merge_uhalt_tmp, auto)
+ qed
+ qed
+qed
+end
+
+end
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/utm/uncomputable.thy Sat Sep 29 12:38:12 2012 +0000
@@ -0,0 +1,1693 @@
+(* Title: Turing machine's definition and its charater
+ Author: XuJian <xujian817@hotmail.com>
+ Maintainer: Xujian
+*)
+
+header {* Undeciablity of the {\em Halting problem} *}
+
+theory uncomputable
+imports Main turing_basic
+begin
+
+text {*
+ The {\em Copying} TM, which duplicates its input.
+*}
+definition tcopy :: "tprog"
+where
+"tcopy \<equiv> [(W0, 0), (R, 2), (R, 3), (R, 2),
+ (W1, 3), (L, 4), (L, 4), (L, 5), (R, 11), (R, 6),
+ (R, 7), (W0, 6), (R, 7), (R, 8), (W1, 9), (R, 8),
+ (L, 10), (L, 9), (L, 10), (L, 5), (R, 12), (R, 12),
+ (W1, 13), (L, 14), (R, 12), (R, 12), (L, 15), (W0, 14),
+ (R, 0), (L, 15)]"
+
+text {*
+ @{text "wipeLastBs tp"} removes all blanks at the end of tape @{text "tp"}.
+*}
+fun wipeLastBs :: "block list \<Rightarrow> block list"
+ where
+ "wipeLastBs bl = rev (dropWhile (\<lambda>a. a = Bk) (rev bl))"
+
+fun isBk :: "block \<Rightarrow> bool"
+ where
+ "isBk b = (b = Bk)"
+
+text {*
+ The following functions are used to expression invariants of {\em Copying} TM.
+*}
+fun tcopy_F0 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F0 x tp = (let (ln, rn) = tp in
+ list_all isBk ln & rn = replicate x Oc
+ @ [Bk] @ replicate x Oc)"
+
+fun tcopy_F1 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F1 x (ln, rn) = (ln = [] & rn = replicate x Oc)"
+
+fun tcopy_F2 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F2 0 tp = False" |
+ "tcopy_F2 (Suc x) (ln, rn) = (length ln > 0 &
+ ln @ rn = replicate (Suc x) Oc)"
+
+fun tcopy_F3 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F3 0 tp = False" |
+ "tcopy_F3 (Suc x) (ln, rn) =
+ (ln = Bk # replicate (Suc x) Oc & length rn <= 1)"
+
+fun tcopy_F4 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F4 0 tp = False" |
+ "tcopy_F4 (Suc x) (ln, rn) =
+ ((ln = replicate x Oc & rn = [Oc, Bk, Oc])
+ | (ln = replicate (Suc x) Oc & rn = [Bk, Oc])) "
+
+fun tcopy_F5 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F5 0 tp = False" |
+ "tcopy_F5 (Suc x) (ln, rn) =
+ (if rn = [] then False
+ else if hd rn = Bk then (ln = [] &
+ rn = Bk # (Oc # replicate (Suc x) Bk
+ @ replicate (Suc x) Oc))
+ else if hd rn = Oc then
+ (\<exists>n. ln = replicate (x - n) Oc
+ & rn = Oc # (Oc # replicate n Bk @ replicate n Oc)
+ & n > 0 & n <= x)
+ else False)"
+
+
+fun tcopy_F6 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F6 0 tp = False" |
+ "tcopy_F6 (Suc x) (ln, rn) =
+ (\<exists>n. ln = replicate (Suc x -n) Oc
+ & tl rn = replicate n Bk @ replicate n Oc
+ & n > 0 & n <= x)"
+
+fun tcopy_F7 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F7 0 tp = False" |
+ "tcopy_F7 (Suc x) (ln, rn) =
+ (let lrn = (rev ln) @ rn in
+ (\<exists>n. lrn = replicate ((Suc x) - n) Oc @
+ replicate (Suc n) Bk @ replicate n Oc
+ & n > 0 & n <= x &
+ length rn >= n & length rn <= 2 * n ))"
+
+fun tcopy_F8 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F8 0 tp = False" |
+ "tcopy_F8 (Suc x) (ln, rn) =
+ (let lrn = (rev ln) @ rn in
+ (\<exists>n. lrn = replicate ((Suc x) - n) Oc @
+ replicate (Suc n) Bk @ replicate n Oc
+ & n > 0 & n <= x & length rn < n)) "
+
+fun tcopy_F9 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F9 0 tp = False" |
+ "tcopy_F9 (Suc x) (ln, rn) =
+ (let lrn = (rev ln) @ rn in
+ (\<exists>n. lrn = replicate (Suc (Suc x) - n) Oc
+ @ replicate n Bk @ replicate n Oc
+ & n > Suc 0 & n <= Suc x & length rn > 0
+ & length rn <= Suc n))"
+
+fun tcopy_F10 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F10 0 tp = False" |
+ "tcopy_F10 (Suc x) (ln, rn) =
+ (let lrn = (rev ln) @ rn in
+ (\<exists>n. lrn = replicate (Suc (Suc x) - n) Oc
+ @ replicate n Bk @ replicate n Oc & n > Suc 0
+ & n <= Suc x & length rn > Suc n &
+ length rn <= 2*n + 1 ))"
+
+fun tcopy_F11 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F11 0 tp = False" |
+ "tcopy_F11 (Suc x) (ln, rn) =
+ (ln = [Bk] & rn = Oc # replicate (Suc x) Bk
+ @ replicate (Suc x) Oc)"
+
+fun tcopy_F12 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F12 0 tp = False" |
+ "tcopy_F12 (Suc x) (ln, rn) =
+ (let lrn = ((rev ln) @ rn) in
+ (\<exists>n. n > 0 & n <= Suc (Suc x)
+ & lrn = Bk # replicate n Oc @ replicate (Suc (Suc x) - n) Bk
+ @ replicate (Suc x) Oc
+ & length ln = Suc n))"
+
+fun tcopy_F13 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F13 0 tp = False" |
+ "tcopy_F13 (Suc x) (ln, rn) =
+ (let lrn = ((rev ln) @ rn) in
+ (\<exists>n. n > Suc 0 & n <= Suc (Suc x)
+ & lrn = Bk # replicate n Oc @ replicate (Suc (Suc x) - n) Bk
+ @ replicate (Suc x) Oc
+ & length ln = n))"
+
+fun tcopy_F14 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F14 0 tp = False" |
+ "tcopy_F14 (Suc x) (ln, rn) =
+ (ln = replicate (Suc x) Oc @ [Bk] &
+ tl rn = replicate (Suc x) Oc)"
+
+fun tcopy_F15 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
+ where
+ "tcopy_F15 0 tp = False" |
+ "tcopy_F15 (Suc x) (ln, rn) =
+ (let lrn = ((rev ln) @ rn) in
+ lrn = Bk # replicate (Suc x) Oc @ [Bk] @
+ replicate (Suc x) Oc & length ln <= (Suc x))"
+
+text {*
+ The following @{text "inv_tcopy"} is the invariant of the {\em Copying} TM.
+*}
+fun inv_tcopy :: "nat \<Rightarrow> t_conf \<Rightarrow> bool"
+ where
+ "inv_tcopy x c = (let (state, tp) = c in
+ if state = 0 then tcopy_F0 x tp
+ else if state = 1 then tcopy_F1 x tp
+ else if state = 2 then tcopy_F2 x tp
+ else if state = 3 then tcopy_F3 x tp
+ else if state = 4 then tcopy_F4 x tp
+ else if state = 5 then tcopy_F5 x tp
+ else if state = 6 then tcopy_F6 x tp
+ else if state = 7 then tcopy_F7 x tp
+ else if state = 8 then tcopy_F8 x tp
+ else if state = 9 then tcopy_F9 x tp
+ else if state = 10 then tcopy_F10 x tp
+ else if state = 11 then tcopy_F11 x tp
+ else if state = 12 then tcopy_F12 x tp
+ else if state = 13 then tcopy_F13 x tp
+ else if state = 14 then tcopy_F14 x tp
+ else if state = 15 then tcopy_F15 x tp
+ else False)"
+declare tcopy_F0.simps [simp del]
+ tcopy_F1.simps [simp del]
+ tcopy_F2.simps [simp del]
+ tcopy_F3.simps [simp del]
+ tcopy_F4.simps [simp del]
+ tcopy_F5.simps [simp del]
+ tcopy_F6.simps [simp del]
+ tcopy_F7.simps [simp del]
+ tcopy_F8.simps [simp del]
+ tcopy_F9.simps [simp del]
+ tcopy_F10.simps [simp del]
+ tcopy_F11.simps [simp del]
+ tcopy_F12.simps [simp del]
+ tcopy_F13.simps [simp del]
+ tcopy_F14.simps [simp del]
+ tcopy_F15.simps [simp del]
+
+lemma list_replicate_Bk[dest]: "list_all isBk list \<Longrightarrow>
+ list = replicate (length list) Bk"
+apply(induct list)
+apply(simp+)
+done
+
+lemma [simp]: "dropWhile (\<lambda> a. a = b) (replicate x b @ ys) =
+ dropWhile (\<lambda> a. a = b) ys"
+apply(induct x)
+apply(simp)
+apply(simp)
+done
+
+lemma [elim]: "\<lbrakk>tstep (0, a, b) tcopy = (s, l, r); s \<noteq> 0\<rbrakk> \<Longrightarrow> RR"
+apply(simp add: tstep.simps tcopy_def fetch.simps)
+done
+
+lemma [elim]: "\<lbrakk>tstep (Suc 0, a, b) tcopy = (s, l, r); s \<noteq> 0; s \<noteq> 2\<rbrakk>
+ \<Longrightarrow> RR"
+apply(simp add: tstep.simps tcopy_def fetch.simps)
+apply(simp split: block.splits list.splits)
+done
+
+lemma [elim]: "\<lbrakk>tstep (2, a, b) tcopy = (s, l, r); s \<noteq> 2; s \<noteq> 3\<rbrakk>
+ \<Longrightarrow> RR"
+apply(simp add: tstep.simps tcopy_def fetch.simps)
+apply(simp split: block.splits list.splits)
+done
+
+lemma [elim]: "\<lbrakk>tstep (3, a, b) tcopy = (s, l, r); s \<noteq> 3; s \<noteq> 4\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (4, a, b) tcopy = (s, l, r); s \<noteq> 4; s \<noteq> 5\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (5, a, b) tcopy = (s, l, r); s \<noteq> 6; s \<noteq> 11\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (6, a, b) tcopy = (s, l, r); s \<noteq> 6; s \<noteq> 7\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (7, a, b) tcopy = (s, l, r); s \<noteq> 7; s \<noteq> 8\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (8, a, b) tcopy = (s, l, r); s \<noteq> 8; s \<noteq> 9\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (9, a, b) tcopy = (s, l, r); s \<noteq> 9; s \<noteq> 10\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (10, a, b) tcopy = (s, l, r); s \<noteq> 10; s \<noteq> 5\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (11, a, b) tcopy = (s, l, r); s \<noteq> 12\<rbrakk> \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (12, a, b) tcopy = (s, l, r); s \<noteq> 13; s \<noteq> 14\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (13, a, b) tcopy = (s, l, r); s \<noteq> 12\<rbrakk> \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (14, a, b) tcopy = (s, l, r); s \<noteq> 14; s \<noteq> 15\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma [elim]: "\<lbrakk>tstep (15, a, b) tcopy = (s, l, r); s \<noteq> 0; s \<noteq> 15\<rbrakk>
+ \<Longrightarrow> RR"
+by(simp add: tstep.simps tcopy_def fetch.simps
+ split: block.splits list.splits)
+
+lemma min_Suc4: "min (Suc (Suc x)) x = x"
+by auto
+
+lemma takeWhile2replicate:
+ "\<exists>n. takeWhile (\<lambda>a. a = b) list = replicate n b"
+apply(induct list)
+apply(rule_tac x = 0 in exI, simp)
+apply(auto)
+apply(rule_tac x = "Suc n" in exI, simp)
+done
+
+lemma rev_replicate_same: "rev (replicate x b) = replicate x b"
+by(simp)
+
+lemma rev_equal: "a = b \<Longrightarrow> rev a = rev b"
+by simp
+
+lemma rev_equal_rev: "rev a = rev b \<Longrightarrow> a = b"
+by simp
+
+lemma rep_suc_rev[simp]:"replicate n b @ [b] = replicate (Suc n) b"
+apply(rule rev_equal_rev)
+apply(simp only: rev_append rev_replicate_same)
+apply(auto)
+done
+
+lemma replicate_Cons_simp: "b # replicate n b @ xs =
+ replicate n b @ b # xs"
+apply(simp)
+done
+
+
+lemma [elim]: "\<lbrakk>tstep (14, b, c) tcopy = (15, ab, ba);
+ tcopy_F14 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F15 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp: tstep.simps tcopy_def
+ tcopy_F14.simps tcopy_F15.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+done
+
+lemma dropWhile_drophd: "\<not> p a \<Longrightarrow>
+ (dropWhile p xs @ (a # as)) = (dropWhile p (xs @ [a]) @ as)"
+apply(induct xs)
+apply(auto)
+done
+
+lemma dropWhile_append3: "\<lbrakk>\<not> p a;
+ listall ((dropWhile p xs) @ [a]) isBk\<rbrakk> \<Longrightarrow>
+ listall (dropWhile p (xs @ [a])) isBk"
+apply(drule_tac p = p and xs = xs and a = a in dropWhile_drophd, simp)
+done
+
+lemma takeWhile_append3: "\<lbrakk>\<not>p a; (takeWhile p xs) = b\<rbrakk>
+ \<Longrightarrow> takeWhile p (xs @ (a # as)) = b"
+apply(drule_tac P = p and xs = xs and x = a and l = as in
+ takeWhile_tail)
+apply(simp)
+done
+
+lemma listall_append: "list_all p (xs @ ys) =
+ (list_all p xs \<and> list_all p ys)"
+apply(induct xs)
+apply(simp+)
+done
+
+lemma [elim]: "\<lbrakk>tstep (15, b, c) tcopy = (15, ab, ba);
+ tcopy_F15 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F15 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp: tstep.simps tcopy_F15.simps
+ tcopy_def fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(case_tac b, simp+)
+done
+
+lemma [elim]: "\<lbrakk>tstep (14, b, c) tcopy = (14, ab, ba);
+ tcopy_F14 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F14 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp: tcopy_F14.simps tcopy_def tstep.simps
+ tcopy_F14.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+done
+
+lemma [intro]: "list_all isBk (replicate x Bk)"
+apply(induct x, simp+)
+done
+
+lemma [elim]: "list_all isBk (dropWhile (\<lambda>a. a = Oc) b) \<Longrightarrow>
+ list_all isBk (dropWhile (\<lambda>a. a = Oc) (tl b))"
+apply(case_tac b, auto split: if_splits)
+apply(drule list_replicate_Bk)
+apply(case_tac "length list", auto)
+done
+
+lemma [elim]: "list_all (\<lambda> a. a = Oc) list \<Longrightarrow>
+ list = replicate (length list) Oc"
+apply(induct list)
+apply(simp+)
+done
+
+lemma append_length: "\<lbrakk>as @ bs = cs @ ds; length bs = length ds\<rbrakk>
+ \<Longrightarrow> as = cs & bs = ds"
+apply(auto)
+done
+
+lemma Suc_elim: "Suc (Suc m) - n = Suc na \<Longrightarrow> Suc m - n = na"
+apply(simp)
+done
+
+lemma [elim]: "\<lbrakk>0 < n; n \<le> Suc (Suc na);
+ rev b @ Oc # list =
+ Bk # replicate n Oc @ replicate (Suc (Suc na) - n) Bk @
+ Oc # replicate na Oc;
+ length b = Suc n; b \<noteq> []\<rbrakk>
+ \<Longrightarrow> list_all isBk (dropWhile (\<lambda>a. a = Oc) (tl b))"
+apply(case_tac "rev b", auto)
+done
+
+lemma b_cons_same: "b#bs = replicate x a @ as \<Longrightarrow> a \<noteq> b \<longrightarrow> x = 0"
+apply(case_tac x, simp+)
+done
+
+lemma tcopy_tmp[elim]:
+ "\<lbrakk>0 < n; n \<le> Suc (Suc na);
+ rev b @ Oc # list =
+ Bk # replicate n Oc @ replicate (Suc (Suc na) - n) Bk
+ @ Oc # replicate na Oc; length b = Suc n; b \<noteq> []\<rbrakk>
+ \<Longrightarrow> list = replicate na Oc"
+apply(case_tac "rev b", simp+)
+apply(auto)
+apply(frule b_cons_same, auto)
+done
+
+lemma [elim]: "\<lbrakk>tstep (12, b, c) tcopy = (14, ab, ba);
+ tcopy_F12 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F14 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F12.simps tcopy_F14.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(frule tcopy_tmp, simp+)
+apply(case_tac n, simp+)
+apply(case_tac nata, simp+)
+done
+
+lemma replicate_app_Cons: "replicate a b @ b # replicate c b
+ = replicate (Suc (a + c)) b"
+apply(simp)
+apply(simp add: replicate_app_Cons_same)
+apply(simp only: replicate_add[THEN sym])
+done
+
+lemma replicate_same_exE_pref: "\<exists>x. bs @ (b # cs) = replicate x y
+ \<Longrightarrow> (\<exists>n. bs = replicate n y)"
+apply(induct bs)
+apply(rule_tac x = 0 in exI, simp)
+apply(drule impI)
+apply(erule impE)
+apply(erule exE, simp+)
+apply(case_tac x, auto)
+apply(case_tac x, auto)
+apply(rule_tac x = "Suc n" in exI, simp+)
+done
+
+lemma replicate_same_exE_inf: "\<exists>x. bs @ (b # cs) = replicate x y \<Longrightarrow> b = y"
+apply(induct bs, auto)
+apply(case_tac x, auto)
+apply(drule impI)
+apply(erule impE)
+apply(case_tac x, simp+)
+done
+
+lemma replicate_same_exE_suf:
+ "\<exists>x. bs @ (b # cs) = replicate x y \<Longrightarrow> \<exists>n. cs = replicate n y"
+apply(induct bs, auto)
+apply(case_tac x, simp+)
+apply(drule impI, erule impE)
+apply(case_tac x, simp+)
+done
+
+lemma replicate_same_exE: "\<exists>x. bs @ (b # cs) = replicate x y
+ \<Longrightarrow> (\<exists>n. bs = replicate n y) & (b = y) & (\<exists>m. cs = replicate m y)"
+apply(rule conjI)
+apply(drule replicate_same_exE_pref, simp)
+apply(rule conjI)
+apply(drule replicate_same_exE_inf, simp)
+apply(drule replicate_same_exE_suf, simp)
+done
+
+lemma replicate_same: "bs @ (b # cs) = replicate x y
+ \<Longrightarrow> (\<exists>n. bs = replicate n y) & (b = y) & (\<exists>m. cs = replicate m y)"
+apply(rule_tac replicate_same_exE)
+apply(rule_tac x = x in exI)
+apply(assumption)
+done
+
+lemma [elim]: "\<lbrakk> 0 < n; n \<le> Suc (Suc na);
+ (rev ab @ Bk # list) = Bk # replicate n Oc
+ @ replicate (Suc (Suc na) - n) Bk @ Oc # replicate na Oc; ab \<noteq> []\<rbrakk>
+ \<Longrightarrow> n \<le> Suc na"
+apply(rule contrapos_pp, simp+)
+apply(case_tac "rev ab", simp+)
+apply(auto)
+apply(simp only: replicate_app_Cons)
+apply(drule replicate_same)
+apply(auto)
+done
+
+
+lemma [elim]: "\<lbrakk>0 < n; n \<le> Suc (Suc na);
+ rev ab @ Bk # list = Bk # replicate n Oc @
+ replicate (Suc (Suc na) - n) Bk @ Oc # replicate na Oc;
+ length ab = Suc n; ab \<noteq> []\<rbrakk>
+ \<Longrightarrow> rev ab @ Oc # list = Bk # Oc # replicate n Oc @
+ replicate (Suc na - n) Bk @ Oc # replicate na Oc"
+apply(case_tac "rev ab", simp+)
+apply(auto)
+apply(simp only: replicate_Cons_simp)
+apply(simp)
+apply(case_tac "Suc (Suc na) - n", simp+)
+done
+
+lemma [elim]: "\<lbrakk>tstep (12, b, c) tcopy = (13, ab, ba);
+ tcopy_F12 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F13 x (ab, ba)"
+apply(case_tac x)
+apply(simp_all add:tcopy_F12.simps tcopy_F13.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps)
+apply(simp split: if_splits list.splits block.splits)
+apply(auto)
+done
+
+
+lemma [elim]: "\<lbrakk>tstep (11, b, c) tcopy = (12, ab, ba);
+ tcopy_F11 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F12 x (ab, ba)"
+apply(case_tac x)
+apply(simp_all add:tcopy_F12.simps tcopy_F11.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps)
+apply(auto)
+done
+
+lemma equal_length: "a = b \<Longrightarrow> length a = length b"
+by(simp)
+
+lemma [elim]: "\<lbrakk>tstep (13, b, c) tcopy = (12, ab, ba);
+ tcopy_F13 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F12 x (ab, ba)"
+apply(case_tac x)
+apply(simp_all add:tcopy_F12.simps tcopy_F13.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps)
+apply(simp split: if_splits list.splits block.splits)
+apply(auto)
+apply(drule equal_length, simp)
+done
+
+lemma [elim]: "\<lbrakk>tstep (5, b, c) tcopy = (11, ab, ba);
+ tcopy_F5 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F11 x (ab, ba)"
+apply(case_tac x)
+apply(simp_all add:tcopy_F11.simps tcopy_F5.simps tcopy_def
+ tstep.simps fetch.simps new_tape.simps)
+apply(simp split: if_splits list.splits block.splits)
+done
+
+lemma less_equal: "\<lbrakk>length xs <= b; \<not> Suc (length xs) <= b\<rbrakk> \<Longrightarrow>
+ length xs = b"
+apply(simp)
+done
+
+lemma length_cons_same: "\<lbrakk>xs @ b # ys = as @ bs;
+ length ys = length bs\<rbrakk> \<Longrightarrow> xs @ [b] = as & ys = bs"
+apply(drule rev_equal)
+apply(simp)
+apply(auto)
+apply(drule rev_equal, simp)
+done
+
+lemma replicate_set_equal: "\<lbrakk> xs @ [a] = replicate n b; a \<noteq> b\<rbrakk> \<Longrightarrow> RR"
+apply(drule rev_equal, simp)
+apply(case_tac n, simp+)
+done
+
+lemma [elim]: "\<lbrakk>tstep (10, b, c) tcopy = (10, ab, ba);
+ tcopy_F10 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F10 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F10.simps tcopy_def tstep.simps fetch.simps
+ new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(rule_tac x = n in exI, auto)
+apply(case_tac b, simp+)
+apply(rule contrapos_pp, simp+)
+apply(frule less_equal, simp+)
+apply(drule length_cons_same, auto)
+apply(drule replicate_set_equal, simp+)
+done
+
+lemma less_equal2: "\<not> (n::nat) \<le> m \<Longrightarrow> \<exists>x. n = x + m & x > 0"
+apply(rule_tac x = "n - m" in exI)
+apply(auto)
+done
+
+lemma replicate_tail_length[dest]:
+ "\<lbrakk>rev b @ Bk # list = xs @ replicate n Bk @ replicate n Oc\<rbrakk>
+ \<Longrightarrow> length list >= n"
+apply(rule contrapos_pp, simp+)
+apply(drule less_equal2, auto)
+apply(drule rev_equal)
+apply(simp add: replicate_add)
+apply(auto)
+apply(case_tac x, simp+)
+done
+
+
+lemma [elim]: "\<lbrakk>tstep (9, b, c) tcopy = (10, ab, ba);
+ tcopy_F9 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F10 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F10.simps tcopy_F9.simps tcopy_def
+ tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(rule_tac x = n in exI, auto)
+apply(case_tac b, simp+)
+done
+
+lemma [elim]: "\<lbrakk>tstep (9, b, c) tcopy = (9, ab, ba);
+ tcopy_F9 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F9 x (ab, ba)"
+apply(case_tac x)
+apply(simp_all add: tcopy_F9.simps tcopy_def
+ tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(rule_tac x = n in exI, auto)
+apply(case_tac b, simp+)
+apply(rule contrapos_pp, simp+)
+apply(drule less_equal, simp+)
+apply(drule rev_equal, auto)
+apply(case_tac "length list", simp+)
+done
+
+lemma app_cons_app_simp: "xs @ a # bs @ ys = (xs @ [a]) @ bs @ ys"
+apply(simp)
+done
+
+lemma [elim]: "\<lbrakk>tstep (8, b, c) tcopy = (9, ab, ba);
+ tcopy_F8 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F9 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F8.simps tcopy_F9.simps tcopy_def
+ tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(rule_tac x = "Suc n" in exI, auto)
+apply(rule_tac x = "n" in exI, auto)
+apply(simp only: app_cons_app_simp)
+apply(frule replicate_tail_length, simp)
+done
+
+lemma [elim]: "\<lbrakk>tstep (8, b, c) tcopy = (8, ab, ba);
+ tcopy_F8 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F8 x (ab, ba)"
+apply(case_tac x)
+apply(simp_all add:tcopy_F8.simps tcopy_def tstep.simps
+ fetch.simps new_tape.simps)
+apply(simp split: if_splits list.splits block.splits)
+apply(rule_tac x = "n" in exI, auto)
+done
+
+lemma ex_less_more: "\<lbrakk>(x::nat) >= m ; x <= n\<rbrakk> \<Longrightarrow>
+ \<exists>y. x = m + y & y <= n - m"
+by(rule_tac x = "x -m" in exI, auto)
+
+lemma replicate_split: "x <= n \<Longrightarrow>
+ (\<exists>y. replicate n b = replicate (y + x) b)"
+apply(rule_tac x = "n - x" in exI)
+apply(simp)
+done
+
+lemma app_app_app_app_simp: "as @ bs @ cs @ ds =
+ (as @ bs) @ (cs @ ds)"
+by simp
+
+lemma lengthtailsame_append_elim:
+ "\<lbrakk>as @ bs = cs @ ds; length bs = length ds\<rbrakk> \<Longrightarrow> bs = ds"
+apply(simp)
+done
+
+lemma rep_suc: "replicate (Suc n) x = replicate n x @ [x]"
+by(induct n, auto)
+
+lemma length_append_diff_cons:
+ "\<lbrakk>b @ x # ba = xs @ replicate m y @ replicate n x; x \<noteq> y;
+ Suc (length ba) \<le> m + n\<rbrakk>
+ \<Longrightarrow> length ba < n"
+apply(induct n arbitrary: ba, simp)
+apply(drule_tac b = y in replicate_split,
+ simp add: replicate_add, erule exE, simp del: replicate.simps)
+proof -
+ fix ba ya
+ assume h1:
+ "b @ x # ba = xs @ y # replicate ya y @ replicate (length ba) y"
+ and h2: "x \<noteq> y"
+ thus "False"
+ using append_eq_append_conv[of "b @ [x]"
+ "xs @ y # replicate ya y" "ba" "replicate (length ba) y"]
+ apply(auto)
+ apply(case_tac ya, simp,
+ simp add: rep_suc del: rep_suc_rev replicate.simps)
+ done
+next
+ fix n ba
+ assume ind: "\<And>ba. \<lbrakk>b @ x # ba = xs @ replicate m y @ replicate n x;
+ x \<noteq> y; Suc (length ba) \<le> m + n\<rbrakk>
+ \<Longrightarrow> length ba < n"
+ and h1: "b @ x # ba = xs @ replicate m y @ replicate (Suc n) x"
+ and h2: "x \<noteq> y" and h3: "Suc (length ba) \<le> m + Suc n"
+ show "length ba < Suc n"
+ proof(cases "length ba")
+ case 0 thus "?thesis" by simp
+ next
+ fix nat
+ assume "length ba = Suc nat"
+ hence "\<exists> ys a. ba = ys @ [a]"
+ apply(rule_tac x = "butlast ba" in exI)
+ apply(rule_tac x = "last ba" in exI)
+ using append_butlast_last_id[of ba]
+ apply(case_tac ba, auto)
+ done
+ from this obtain ys where "\<exists> a. ba = ys @ [a]" ..
+ from this obtain a where "ba = ys @ [a]" ..
+ thus "?thesis"
+ using ind[of ys] h1 h2 h3
+ apply(simp del: rep_suc_rev replicate.simps add: rep_suc)
+ done
+ qed
+qed
+
+lemma [elim]:
+ "\<lbrakk>b @ Oc # ba = xs @ Bk # replicate n Bk @ replicate n Oc;
+ Suc (length ba) \<le> 2 * n\<rbrakk>
+ \<Longrightarrow> length ba < n"
+ apply(rule_tac length_append_diff_cons[of b Oc ba xs "Suc n" Bk n])
+ apply(simp, simp, simp)
+ done
+
+lemma [elim]: "\<lbrakk>tstep (7, b, c) tcopy = (8, ab, ba);
+ tcopy_F7 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F8 x (ab, ba)"
+apply(case_tac x)
+apply(simp_all add:tcopy_F8.simps tcopy_F7.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps)
+apply(simp split: if_splits list.splits block.splits)
+apply(rule_tac x = "n" in exI, auto)
+done
+
+lemma [elim]: "\<lbrakk>tstep (7, b, c) tcopy = (7, ab, ba);
+ tcopy_F7 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F7 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F7.simps tcopy_def tstep.simps
+ fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(rule_tac x = "n" in exI, auto)
+apply(simp only: app_cons_app_simp)
+apply(frule replicate_tail_length, simp)
+done
+
+lemma Suc_more: "n <= m \<Longrightarrow> Suc m - n = Suc (m - n)"
+by simp
+
+lemma [elim]: "\<lbrakk>tstep (6, b, c) tcopy = (7, ab, ba);
+ tcopy_F6 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F7 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F7.simps tcopy_F6.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+done
+
+lemma [elim]: "\<lbrakk>tstep (6, b, c) tcopy = (6, ab, ba);
+ tcopy_F6 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F6 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F6.simps tcopy_def tstep.simps
+ new_tape.simps fetch.simps
+ split: if_splits list.splits block.splits)
+done
+
+lemma [elim]: "\<lbrakk>tstep (5, b, c) tcopy = (6, ab, ba);
+ tcopy_F5 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F6 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F5.simps tcopy_F6.simps tcopy_def
+ tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(rule_tac x = n in exI, simp)
+apply(rule_tac x = n in exI, simp)
+apply(drule Suc_more, simp)
+done
+
+lemma ex_less_more2: "\<lbrakk>(n::nat) < x ; x <= 2 * n\<rbrakk> \<Longrightarrow>
+ \<exists>y. (x = n + y & y <= n)"
+apply(rule_tac x = "x - n" in exI)
+apply(auto)
+done
+
+lemma app_app_app_simp: "xs @ ys @ za = (xs @ ys) @ za"
+apply(simp)
+done
+
+lemma [elim]: "rev xs = replicate n b \<Longrightarrow> xs = replicate n b"
+using rev_replicate[of n b]
+thm rev_equal
+by(drule_tac rev_equal, simp)
+
+lemma app_cons_tail_same[dest]:
+ "\<lbrakk>rev b @ Oc # list =
+ replicate (Suc (Suc na) - n) Oc @ replicate n Bk @ replicate n Oc;
+ Suc 0 < n; n \<le> Suc na; n < length list; length list \<le> 2 * n; b \<noteq> []\<rbrakk>
+ \<Longrightarrow> list = replicate n Bk @ replicate n Oc
+ & b = replicate (Suc na - n) Oc"
+using length_append_diff_cons[of "rev b" Oc list
+ "replicate (Suc (Suc na) - n) Oc" n Bk n]
+apply(case_tac "length list = 2*n", simp)
+using append_eq_append_conv[of "rev b @ [Oc]" "replicate
+ (Suc (Suc na) - n) Oc" "list" "replicate n Bk @ replicate n Oc"]
+apply(case_tac n, simp, simp add: Suc_more rep_suc
+ del: rep_suc_rev replicate.simps, auto)
+done
+
+lemma hd_replicate_false1: "\<lbrakk>replicate x Oc \<noteq> [];
+ hd (replicate x Oc) = Bk\<rbrakk> \<Longrightarrow> RR"
+apply(case_tac x, auto)
+done
+
+lemma hd_replicate_false2: "\<lbrakk>replicate x Oc \<noteq> [];
+ hd (replicate x Oc) \<noteq> Oc\<rbrakk> \<Longrightarrow> RR"
+apply(case_tac x, auto)
+done
+
+lemma Suc_more_less: "\<lbrakk>n \<le> Suc m; n >= m\<rbrakk> \<Longrightarrow> n = m | n = Suc m"
+apply(auto)
+done
+
+lemma replicate_not_Nil: "replicate x a \<noteq> [] \<Longrightarrow> x > 0"
+apply(case_tac x, simp+)
+done
+
+lemma [elim]: "\<lbrakk>tstep (10, b, c) tcopy = (5, ab, ba);
+ tcopy_F10 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F5 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F5.simps tcopy_F10.simps tcopy_def
+ tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(frule app_cons_tail_same, simp+)
+apply(rule_tac x = n in exI, auto)
+done
+
+lemma [elim]: "\<lbrakk>tstep (4, b, c) tcopy = (5, ab, ba);
+ tcopy_F4 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F5 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F5.simps tcopy_F4.simps tcopy_def
+ tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+done
+
+lemma [elim]: "\<lbrakk>tstep (3, b, c) tcopy = (4, ab, ba);
+ tcopy_F3 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F4 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F3.simps tcopy_F4.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+done
+
+lemma [elim]: "\<lbrakk>tstep (4, b, c) tcopy = (4, ab, ba);
+ tcopy_F4 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F4 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F3.simps tcopy_F4.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+done
+
+lemma [elim]: "\<lbrakk>tstep (3, b, c) tcopy = (3, ab, ba);
+ tcopy_F3 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F3 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F3.simps tcopy_F4.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+done
+
+lemma replicate_cons_back: "y # replicate x y = replicate (Suc x) y"
+apply(simp)
+done
+
+lemma replicate_cons_same: "bs @ (b # cs) = y # replicate x y \<Longrightarrow>
+ (\<exists>n. bs = replicate n y) & (b = y) & (\<exists>m. cs = replicate m y)"
+apply(simp only: replicate_cons_back)
+apply(drule_tac replicate_same)
+apply(simp)
+done
+
+lemma [elim]: "\<lbrakk>tstep (2, b, c) tcopy = (3, ab, ba);
+ tcopy_F2 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F3 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F3.simps tcopy_F2.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(drule replicate_cons_same, auto)+
+done
+
+lemma [elim]: "\<lbrakk>tstep (2, b, c) tcopy = (2, ab, ba);
+ tcopy_F2 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F2 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp:tcopy_F3.simps tcopy_F2.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits)
+apply(frule replicate_cons_same, auto)
+apply(simp add: replicate_app_Cons_same)
+done
+
+lemma [elim]: "\<lbrakk>tstep (Suc 0, b, c) tcopy = (2, ab, ba);
+ tcopy_F1 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F2 x (ab, ba)"
+apply(case_tac x)
+apply(simp_all add:tcopy_F2.simps tcopy_F1.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps)
+apply(auto)
+done
+
+lemma [elim]: "\<lbrakk>tstep (Suc 0, b, c) tcopy = (0, ab, ba);
+ tcopy_F1 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F0 x (ab, ba)"
+apply(case_tac x)
+apply(simp_all add:tcopy_F0.simps tcopy_F1.simps
+ tcopy_def tstep.simps fetch.simps new_tape.simps)
+done
+
+lemma ex_less: "Suc x <= y \<Longrightarrow> \<exists>z. y = x + z & z > 0"
+apply(rule_tac x = "y - x" in exI, auto)
+done
+
+lemma [elim]: "\<lbrakk>xs @ Bk # ba =
+ Bk # Oc # replicate n Oc @ Bk # Oc # replicate n Oc;
+ length xs \<le> Suc n; xs \<noteq> []\<rbrakk> \<Longrightarrow> RR"
+apply(case_tac xs, auto)
+apply(case_tac list, auto)
+apply(drule ex_less, auto)
+apply(simp add: replicate_add)
+apply(auto)
+apply(case_tac z, simp+)
+done
+
+lemma [elim]: "\<lbrakk>tstep (15, b, c) tcopy = (0, ab, ba);
+ tcopy_F15 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F0 x (ab, ba)"
+apply(case_tac x)
+apply(auto simp: tcopy_F15.simps tcopy_F0.simps
+ tcopy_def tstep.simps new_tape.simps fetch.simps
+ split: if_splits list.splits block.splits)
+done
+
+lemma [elim]: "\<lbrakk>tstep (0, b, c) tcopy = (0, ab, ba);
+ tcopy_F0 x (b, c)\<rbrakk> \<Longrightarrow> tcopy_F0 x (ab, ba)"
+apply(case_tac x)
+apply(simp_all add: tcopy_F0.simps tcopy_def
+ tstep.simps new_tape.simps fetch.simps)
+done
+
+declare tstep.simps[simp del]
+
+text {*
+ Finally establishes the invariant of Copying TM, which is used to dervie
+ the parital correctness of Copying TM.
+*}
+lemma inv_tcopy_step:"inv_tcopy x c \<Longrightarrow> inv_tcopy x (tstep c tcopy)"
+apply(induct c)
+apply(auto split: if_splits block.splits list.splits taction.splits)
+apply(auto simp: tstep.simps tcopy_def fetch.simps new_tape.simps
+ split: if_splits list.splits block.splits taction.splits)
+done
+
+declare inv_tcopy.simps[simp del]
+
+text {*
+ Invariant under mult-step execution.
+ *}
+lemma inv_tcopy_steps:
+ "inv_tcopy x (steps (Suc 0, [], replicate x Oc) tcopy stp) "
+apply(induct stp)
+apply(simp add: tstep.simps tcopy_def steps.simps
+ tcopy_F1.simps inv_tcopy.simps)
+apply(drule_tac inv_tcopy_step, simp add: tstep_red)
+done
+
+
+text {*
+ The followng lemmas gives the parital correctness of Copying TM.
+*}
+theorem inv_tcopy_rs:
+ "steps (Suc 0, [], replicate x Oc) tcopy stp = (0, l, r)
+ \<Longrightarrow> \<exists> n. l = replicate n Bk \<and>
+ r = replicate x Oc @ Bk # replicate x Oc"
+apply(insert inv_tcopy_steps[of x stp])
+apply(auto simp: inv_tcopy.simps tcopy_F0.simps isBk.simps)
+done
+
+
+
+
+(*----------halt problem of tcopy----------------------------------------*)
+
+section {*
+ The following definitions are used to construct the measure function used to show
+ the termnation of Copying TM.
+*}
+
+definition lex_pair :: "((nat \<times> nat) \<times> nat \<times> nat) set"
+ where
+ "lex_pair \<equiv> 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 lex_square ::
+ "((nat \<times> nat \<times> nat \<times> nat) \<times> (nat \<times> nat \<times> nat \<times> nat)) set"
+ where
+"lex_square \<equiv> less_than <*lex*> lex_triple"
+
+lemma wf_lex_triple: "wf lex_triple"
+ by (auto intro:wf_lex_prod simp:lex_triple_def lex_pair_def)
+
+lemma wf_lex_square: "wf lex_square"
+ by (auto intro:wf_lex_prod
+ simp:lex_triple_def lex_square_def lex_pair_def)
+
+text {*
+ A measurement functions used to show the termination of copying machine:
+*}
+fun tcopy_phase :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_phase c = (let (state, tp) = c in
+ if state > 0 & state <= 4 then 5
+ else if state >=5 & state <= 10 then 4
+ else if state = 11 then 3
+ else if state = 12 | state = 13 then 2
+ else if state = 14 | state = 15 then 1
+ else 0)"
+
+fun tcopy_phase4_stage :: "tape \<Rightarrow> nat"
+ where
+ "tcopy_phase4_stage (ln, rn) =
+ (let lrn = (rev ln) @ rn
+ in length (takeWhile (\<lambda>a. a = Oc) lrn))"
+
+fun tcopy_stage :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_stage c = (let (state, ln, rn) = c in
+ if tcopy_phase c = 5 then 0
+ else if tcopy_phase c = 4 then
+ tcopy_phase4_stage (ln, rn)
+ else if tcopy_phase c = 3 then 0
+ else if tcopy_phase c = 2 then length rn
+ else if tcopy_phase c = 1 then 0
+ else 0)"
+
+fun tcopy_phase4_state :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_phase4_state c = (let (state, ln, rn) = c in
+ if state = 6 & hd rn = Oc then 0
+ else if state = 5 then 1
+ else 12 - state)"
+
+fun tcopy_state :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_state c = (let (state, ln, rn) = c in
+ if tcopy_phase c = 5 then 4 - state
+ else if tcopy_phase c = 4 then
+ tcopy_phase4_state c
+ else if tcopy_phase c = 3 then 0
+ else if tcopy_phase c = 2 then 13 - state
+ else if tcopy_phase c = 1 then 15 - state
+ else 0)"
+
+fun tcopy_step2 :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_step2 (s, l, r) = length r"
+
+fun tcopy_step3 :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_step3 (s, l, r) = (if r = [] | r = [Bk] then Suc 0 else 0)"
+
+fun tcopy_step4 :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_step4 (s, l, r) = length l"
+
+fun tcopy_step7 :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_step7 (s, l, r) = length r"
+
+fun tcopy_step8 :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_step8 (s, l, r) = length r"
+
+fun tcopy_step9 :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_step9 (s, l, r) = length l"
+
+fun tcopy_step10 :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_step10 (s, l, r) = length l"
+
+fun tcopy_step14 :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_step14 (s, l, r) = (case hd r of
+ Oc \<Rightarrow> 1 |
+ Bk \<Rightarrow> 0)"
+
+fun tcopy_step15 :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_step15 (s, l, r) = length l"
+
+fun tcopy_step :: "t_conf \<Rightarrow> nat"
+ where
+ "tcopy_step c = (let (state, ln, rn) = c in
+ if state = 0 | state = 1 | state = 11 |
+ state = 5 | state = 6 | state = 12 | state = 13 then 0
+ else if state = 2 then tcopy_step2 c
+ else if state = 3 then tcopy_step3 c
+ else if state = 4 then tcopy_step4 c
+ else if state = 7 then tcopy_step7 c
+ else if state = 8 then tcopy_step8 c
+ else if state = 9 then tcopy_step9 c
+ else if state = 10 then tcopy_step10 c
+ else if state = 14 then tcopy_step14 c
+ else if state = 15 then tcopy_step15 c
+ else 0)"
+
+text {*
+ The measure function used to show the termination of Copying TM.
+*}
+fun tcopy_measure :: "t_conf \<Rightarrow> (nat * nat * nat * nat)"
+ where
+ "tcopy_measure c =
+ (tcopy_phase c, tcopy_stage c, tcopy_state c, tcopy_step c)"
+
+definition tcopy_LE :: "((nat \<times> block list \<times> block list) \<times>
+ (nat \<times> block list \<times> block list)) set"
+ where
+ "tcopy_LE \<equiv> (inv_image lex_square tcopy_measure)"
+
+lemma wf_tcopy_le: "wf tcopy_LE"
+by(auto intro:wf_inv_image wf_lex_square simp:tcopy_LE_def)
+
+
+declare steps.simps[simp del]
+
+declare tcopy_phase.simps[simp del] tcopy_stage.simps[simp del]
+ tcopy_state.simps[simp del] tcopy_step.simps[simp del]
+ inv_tcopy.simps[simp del]
+declare tcopy_F0.simps [simp]
+ tcopy_F1.simps [simp]
+ tcopy_F2.simps [simp]
+ tcopy_F3.simps [simp]
+ tcopy_F4.simps [simp]
+ tcopy_F5.simps [simp]
+ tcopy_F6.simps [simp]
+ tcopy_F7.simps [simp]
+ tcopy_F8.simps [simp]
+ tcopy_F9.simps [simp]
+ tcopy_F10.simps [simp]
+ tcopy_F11.simps [simp]
+ tcopy_F12.simps [simp]
+ tcopy_F13.simps [simp]
+ tcopy_F14.simps [simp]
+ tcopy_F15.simps [simp]
+ fetch.simps[simp]
+ new_tape.simps[simp]
+lemma [elim]: "tcopy_F1 x (b, c) \<Longrightarrow>
+ (tstep (Suc 0, b, c) tcopy, Suc 0, b, c) \<in> tcopy_LE"
+apply(simp add: tcopy_F1.simps tstep.simps tcopy_def tcopy_LE_def
+ lex_square_def lex_triple_def lex_pair_def tcopy_phase.simps
+ tcopy_stage.simps tcopy_state.simps tcopy_step.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+done
+
+lemma [elim]: "tcopy_F2 x (b, c) \<Longrightarrow>
+ (tstep (2, b, c) tcopy, 2, b, c) \<in> tcopy_LE"
+apply(simp add:tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+done
+
+lemma [elim]: "tcopy_F3 x (b, c) \<Longrightarrow>
+ (tstep (3, b, c) tcopy, 3, b, c) \<in> tcopy_LE"
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(case_tac x, simp+)
+done
+
+lemma [elim]: "tcopy_F4 x (b, c) \<Longrightarrow>
+ (tstep (4, b, c) tcopy, 4, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tcopy_F4.simps tstep.simps tcopy_def tcopy_LE_def
+ lex_square_def lex_triple_def lex_pair_def tcopy_phase.simps
+ tcopy_stage.simps tcopy_state.simps tcopy_step.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+done
+
+lemma[simp]: "takeWhile (\<lambda>a. a = b) (replicate x b @ ys) =
+ replicate x b @ (takeWhile (\<lambda>a. a = b) ys)"
+apply(induct x)
+apply(simp+)
+done
+
+lemma [elim]: "tcopy_F5 x (b, c) \<Longrightarrow>
+ (tstep (5, b, c) tcopy, 5, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def
+ lex_square_def lex_triple_def lex_pair_def tcopy_phase.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(simp_all add: tcopy_phase.simps
+ tcopy_stage.simps tcopy_state.simps)
+done
+
+lemma [elim]: "\<lbrakk>replicate n x = []; n > 0\<rbrakk> \<Longrightarrow> RR"
+apply(case_tac n, simp+)
+done
+
+lemma [elim]: "tcopy_F6 x (b, c) \<Longrightarrow>
+ (tstep (6, b, c) tcopy, 6, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def
+ lex_square_def lex_triple_def lex_pair_def
+ tcopy_phase.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(simp_all add: tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+done
+
+lemma [elim]: "tcopy_F7 x (b, c) \<Longrightarrow>
+ (tstep (7, b, c) tcopy, 7, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(simp_all add: tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+done
+
+lemma [elim]: "tcopy_F8 x (b, c) \<Longrightarrow>
+ (tstep (8, b, c) tcopy, 8, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(simp_all add: tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+apply(simp only: app_cons_app_simp, frule replicate_tail_length, simp)
+done
+
+lemma app_app_app_equal: "xs @ ys @ zs = (xs @ ys) @ zs"
+by simp
+
+lemma append_cons_assoc: "as @ b # bs = (as @ [b]) @ bs"
+apply(rule rev_equal_rev)
+apply(simp)
+done
+
+lemma rev_tl_hd_merge: "bs \<noteq> [] \<Longrightarrow>
+ rev (tl bs) @ hd bs # as = rev bs @ as"
+apply(rule rev_equal_rev)
+apply(simp)
+done
+
+lemma [elim]: "tcopy_F9 x (b, c) \<Longrightarrow>
+ (tstep (9, b, c) tcopy, 9, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(simp_all add: tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+apply(drule_tac bs = b and as = "Bk # list" in rev_tl_hd_merge)
+apply(simp)
+apply(drule_tac bs = b and as = "Oc # list" in rev_tl_hd_merge)
+apply(simp)
+done
+
+lemma [elim]: "tcopy_F10 x (b, c) \<Longrightarrow>
+ (tstep (10, b, c) tcopy, 10, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(simp_all add: tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+apply(drule_tac bs = b and as = "Bk # list" in rev_tl_hd_merge)
+apply(simp)
+apply(drule_tac bs = b and as = "Oc # list" in rev_tl_hd_merge)
+apply(simp)
+done
+
+lemma [elim]: "tcopy_F11 x (b, c) \<Longrightarrow>
+ (tstep (11, b, c) tcopy, 11, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def
+ lex_square_def lex_triple_def lex_pair_def
+ tcopy_phase.simps)
+done
+
+lemma [elim]: "tcopy_F12 x (b, c) \<Longrightarrow>
+ (tstep (12, b, c) tcopy, 12, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(simp_all add: tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+done
+
+lemma [elim]: "tcopy_F13 x (b, c) \<Longrightarrow>
+ (tstep (13, b, c) tcopy, 13, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(simp_all add: tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+apply(drule equal_length, simp)+
+done
+
+lemma [elim]: "tcopy_F14 x (b, c) \<Longrightarrow>
+ (tstep (14, b, c) tcopy, 14, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps)
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(simp_all add: tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+done
+
+lemma [elim]: "tcopy_F15 x (b, c) \<Longrightarrow>
+ (tstep (15, b, c) tcopy, 15, b, c) \<in> tcopy_LE"
+apply(case_tac x, simp)
+apply(simp add: tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps )
+apply(simp split: if_splits list.splits block.splits taction.splits)
+apply(auto)
+apply(simp_all add: tcopy_phase.simps tcopy_stage.simps
+ tcopy_state.simps tcopy_step.simps)
+done
+
+lemma tcopy_wf_step:"\<lbrakk>a > 0; inv_tcopy x (a, b, c)\<rbrakk> \<Longrightarrow>
+ (tstep (a, b, c) tcopy, (a, b, c)) \<in> tcopy_LE"
+apply(simp add:inv_tcopy.simps split: if_splits, auto)
+apply(auto simp: tstep.simps tcopy_def tcopy_LE_def lex_square_def
+ lex_triple_def lex_pair_def tcopy_phase.simps
+ tcopy_stage.simps tcopy_state.simps tcopy_step.simps
+ split: if_splits list.splits block.splits taction.splits)
+done
+
+lemma tcopy_wf:
+"\<forall>n. let nc = steps (Suc 0, [], replicate x Oc) tcopy n in
+ let Sucnc = steps (Suc 0, [], replicate x Oc) tcopy (Suc n) in
+ \<not> isS0 nc \<longrightarrow> ((Sucnc, nc) \<in> tcopy_LE)"
+proof(rule allI, case_tac
+ "steps (Suc 0, [], replicate x Oc) tcopy n", auto simp: tstep_red)
+ fix n a b c
+ assume h: "\<not> isS0 (a, b, c)"
+ "steps (Suc 0, [], replicate x Oc) tcopy n = (a, b, c)"
+ hence "inv_tcopy x (a, b, c)"
+ using inv_tcopy_steps[of x n] by(simp)
+ thus "(tstep (a, b, c) tcopy, a, b, c) \<in> tcopy_LE"
+ using h
+ by(rule_tac tcopy_wf_step, auto simp: isS0_def)
+qed
+
+text {*
+ The termination of Copying TM:
+*}
+lemma tcopy_halt:
+ "\<exists>n. isS0 (steps (Suc 0, [], replicate x Oc) tcopy n)"
+apply(insert halt_lemma
+ [of tcopy_LE isS0 "steps (Suc 0, [], replicate x Oc) tcopy"])
+apply(insert tcopy_wf [of x])
+apply(simp only: Let_def)
+apply(insert wf_tcopy_le)
+apply(simp)
+done
+
+text {*
+ The total correntess of Copying TM:
+*}
+theorem tcopy_halt_rs: "\<exists>stp m.
+ steps (Suc 0, [], replicate x Oc) tcopy stp =
+ (0, replicate m Bk, replicate x Oc @ Bk # replicate x Oc)"
+using tcopy_halt[of x]
+proof(erule_tac exE)
+ fix n
+ assume h: "isS0 (steps (Suc 0, [], replicate x Oc) tcopy n)"
+ have "inv_tcopy x (steps (Suc 0, [], replicate x Oc) tcopy n)"
+ using inv_tcopy_steps[of x n] by simp
+ thus "?thesis"
+ using h
+ apply(cases "(steps (Suc 0, [], replicate x Oc) tcopy n)",
+ auto simp: isS0_def inv_tcopy.simps)
+ apply(rule_tac x = n in exI, auto)
+ done
+qed
+
+section {*
+ The {\em Dithering} Turing Machine
+*}
+
+text {*
+ The {\em Dithering} TM, when the input is @{text "1"}, it will loop forever, otherwise, it will
+ terminate.
+*}
+definition dither :: "tprog"
+ where
+ "dither \<equiv> [(W0, 1), (R, 2), (L, 1), (L, 0)] "
+
+lemma dither_halt_rs:
+ "\<exists> stp. steps (Suc 0, Bk\<^bsup>m\<^esup>, [Oc, Oc]) dither stp =
+ (0, Bk\<^bsup>m\<^esup>, [Oc, Oc])"
+apply(rule_tac x = "Suc (Suc (Suc 0))" in exI)
+apply(simp add: dither_def steps.simps
+ tstep.simps fetch.simps new_tape.simps)
+done
+
+lemma dither_unhalt_state:
+ "(steps (Suc 0, Bk\<^bsup>m\<^esup>, [Oc]) dither stp =
+ (Suc 0, Bk\<^bsup>m\<^esup>, [Oc])) \<or>
+ (steps (Suc 0, Bk\<^bsup>m\<^esup>, [Oc]) dither stp = (2, Oc # Bk\<^bsup>m\<^esup>, []))"
+ apply(induct stp, simp add: steps.simps)
+ apply(simp add: tstep_red, auto)
+ apply(auto simp: tstep.simps fetch.simps dither_def new_tape.simps)
+ done
+
+lemma dither_unhalt_rs:
+ "\<not> (\<exists> stp. isS0 (steps (Suc 0, Bk\<^bsup>m\<^esup>, [Oc]) dither stp))"
+proof(auto)
+ fix stp
+ assume h1: "isS0 (steps (Suc 0, Bk\<^bsup>m\<^esup>, [Oc]) dither stp)"
+ have "\<not> isS0 ((steps (Suc 0, Bk\<^bsup>m\<^esup>, [Oc]) dither stp))"
+ using dither_unhalt_state[of m stp]
+ by(auto simp: isS0_def)
+ from h1 and this show False by (auto)
+qed
+
+section {*
+ The final diagnal arguments to show the undecidability of Halting problem.
+*}
+
+text {*
+ @{text "haltP tp x"} means TM @{text "tp"} terminates on input @{text "x"}
+ and the final configuration is standard.
+*}
+definition haltP :: "tprog \<Rightarrow> nat \<Rightarrow> bool"
+ where
+ "haltP t x = (\<exists>n a b c. steps (Suc 0, [], Oc\<^bsup>x\<^esup>) t n = (0, Bk\<^bsup>a\<^esup>, Oc\<^bsup>b\<^esup> @ Bk\<^bsup>c\<^esup>))"
+
+lemma [simp]: "length (A |+| B) = length A + length B"
+by(auto simp: t_add.simps tshift.simps)
+
+lemma [intro]: "\<lbrakk>iseven (x::nat); iseven y\<rbrakk> \<Longrightarrow> iseven (x + y)"
+apply(auto simp: iseven_def)
+apply(rule_tac x = "x + xa" in exI, simp)
+done
+
+lemma t_correct_add[intro]:
+ "\<lbrakk>t_correct A; t_correct B\<rbrakk> \<Longrightarrow> t_correct (A |+| B)"
+apply(auto simp: t_correct.simps tshift.simps t_add.simps
+ change_termi_state.simps list_all_iff)
+apply(erule_tac x = "(a, b)" in ballE, auto)
+apply(case_tac "ba = 0", auto)
+done
+
+lemma [intro]: "t_correct tcopy"
+apply(simp add: t_correct.simps tcopy_def iseven_def)
+apply(rule_tac x = 15 in exI, simp)
+done
+
+lemma [intro]: "t_correct dither"
+apply(simp add: t_correct.simps dither_def iseven_def)
+apply(rule_tac x = 2 in exI, simp)
+done
+
+text {*
+ The following locale specifies that TM @{text "H"} can be used to solve
+ the {\em Halting Problem} and @{text "False"} is going to be derived
+ under this locale. Therefore, the undecidability of {\em Halting Problem}
+ is established.
+*}
+locale uncomputable =
+ -- {* The coding function of TM, interestingly, the detailed definition of this
+ funciton @{text "code"} does not affect the final result. *}
+ fixes code :: "tprog \<Rightarrow> nat"
+ -- {*
+ The TM @{text "H"} is the one which is assummed being able to solve the Halting problem.
+ *}
+ and H :: "tprog"
+ assumes h_wf[intro]: "t_correct H"
+ -- {*
+ The following two assumptions specifies that @{text "H"} does solve the Halting problem.
+ *}
+ and h_case:
+ "\<And> M n. \<lbrakk>(haltP M n)\<rbrakk> \<Longrightarrow>
+ \<exists> na nb. (steps (Suc 0, Bk\<^bsup>x\<^esup>, Oc\<^bsup>code M\<^esup> @ Bk # Oc\<^bsup>n\<^esup>) H na = (0, Bk\<^bsup>nb\<^esup>, [Oc]))"
+ and nh_case:
+ "\<And> M n. \<lbrakk>(\<not> haltP M n)\<rbrakk> \<Longrightarrow>
+ \<exists> na nb. (steps (Suc 0, Bk\<^bsup>x\<^esup>, Oc\<^bsup>code M\<^esup> @ Bk # Oc\<^bsup>n\<^esup>) H na = (0, Bk\<^bsup>nb\<^esup>, [Oc, Oc]))"
+begin
+
+term t_correct
+declare haltP_def[simp del]
+definition tcontra :: "tprog \<Rightarrow> tprog"
+ where
+ "tcontra h \<equiv> ((tcopy |+| h) |+| dither)"
+
+lemma [simp]: "a\<^bsup>0\<^esup> = []"
+ by(simp add: exponent_def)
+lemma haltP_weaking:
+ "haltP (tcontra H) (code (tcontra H)) \<Longrightarrow>
+ \<exists>stp. isS0 (steps (Suc 0, [], Oc\<^bsup>code (tcontra H)\<^esup>)
+ ((tcopy |+| H) |+| dither) stp)"
+ apply(simp add: haltP_def, auto)
+ apply(rule_tac x = n in exI, simp add: isS0_def tcontra_def)
+ done
+
+lemma h_uh: "haltP (tcontra H) (code (tcontra H))
+ \<Longrightarrow> \<not> haltP (tcontra H) (code (tcontra H))"
+proof -
+ let ?cn = "code (tcontra H)"
+ let ?P1 = "\<lambda> tp. let (l, r) = tp in (l = [] \<and>
+ (r::block list) = Oc\<^bsup>(?cn)\<^esup>)"
+ let ?Q1 = "\<lambda> (l, r).(\<exists> nb. l = Bk\<^bsup>nb\<^esup> \<and>
+ r = Oc\<^bsup>(?cn)\<^esup> @ Bk # Oc\<^bsup>(?cn)\<^esup>)"
+ let ?P2 = ?Q1
+ let ?Q2 = "\<lambda> (l, r). (\<exists> nd. l = Bk\<^bsup>nd \<^esup>\<and> r = [Oc])"
+ let ?P3 = "\<lambda> tp. False"
+ assume h: "haltP (tcontra H) (code (tcontra H))"
+ hence h1: "\<And> x. \<exists> na nb. steps (Suc 0, Bk\<^bsup>x\<^esup>, Oc\<^bsup>code (tcontra H)\<^esup> @ Bk #
+ Oc\<^bsup>code (tcontra H)\<^esup>) H na = (0, Bk\<^bsup>nb\<^esup>, [Oc])"
+ by(drule_tac x = x in h_case, simp)
+ have "?P1 \<turnstile>-> \<lambda> tp. (\<exists> stp tp'. steps (Suc 0, tp) (tcopy |+| H) stp = (0, tp') \<and> ?Q2 tp')"
+ proof(rule_tac turing_merge.t_merge_halt[of tcopy H "?P1" "?P2" "?P3"
+ "?P3" "?Q1" "?Q2"], auto simp: turing_merge_def)
+ show "\<exists>stp. case steps (Suc 0, [], Oc\<^bsup>?cn\<^esup>) tcopy stp of (s, tp') \<Rightarrow>
+ s = 0 \<and> (case tp' of (l, r) \<Rightarrow> (\<exists>nb. l = Bk\<^bsup>nb\<^esup>) \<and> r = Oc\<^bsup>?cn\<^esup> @ Bk # Oc\<^bsup>?cn\<^esup>)"
+ using tcopy_halt_rs[of "?cn"]
+ apply(auto)
+ apply(rule_tac x = stp in exI, auto simp: exponent_def)
+ done
+ next
+ fix nb
+ show "\<exists>stp. case steps (Suc 0, Bk\<^bsup>nb\<^esup>, Oc\<^bsup>code (tcontra H)\<^esup> @ Bk # Oc\<^bsup>code (tcontra H)\<^esup>) H stp of
+ (s, tp') \<Rightarrow> s = 0 \<and> (case tp' of (l, r) \<Rightarrow> (\<exists>nd. l = Bk\<^bsup>nd\<^esup>) \<and> r = [Oc])"
+ using h1[of nb]
+ apply(auto)
+ apply(rule_tac x = na in exI, auto)
+ done
+ next
+ show "\<lambda>(l, r). ((\<exists>nb. l = Bk\<^bsup>nb\<^esup>) \<and> r = Oc\<^bsup>code (tcontra H)\<^esup> @ Bk # Oc\<^bsup>code (tcontra H)\<^esup>) \<turnstile>->
+ \<lambda>(l, r). ((\<exists>nb. l = Bk\<^bsup>nb\<^esup>) \<and> r = Oc\<^bsup>code (tcontra H)\<^esup> @ Bk # Oc\<^bsup>code (tcontra H)\<^esup>)"
+ apply(simp add: t_imply_def)
+ done
+ qed
+ hence "\<exists>stp tp'. steps (Suc 0, [], Oc\<^bsup>?cn\<^esup>) (tcopy |+| H) stp = (0, tp') \<and>
+ (case tp' of (l, r) \<Rightarrow> \<exists>nd. l = Bk\<^bsup>nd\<^esup> \<and> r = [Oc])"
+ apply(simp add: t_imply_def)
+ done
+ hence "?P1 \<turnstile>-> \<lambda> tp. \<not> (\<exists> stp. isS0 (steps (Suc 0, tp) ((tcopy |+| H) |+| dither) stp))"
+ proof(rule_tac turing_merge.t_merge_uhalt[of "tcopy |+| H" dither "?P1" "?P3" "?P3"
+ "?Q2" "?Q2" "?Q2"], simp add: turing_merge_def, auto)
+ fix stp nd
+ assume "steps (Suc 0, [], Oc\<^bsup>code (tcontra H)\<^esup>) (tcopy |+| H) stp = (0, Bk\<^bsup>nd\<^esup>, [Oc])"
+ thus "\<exists>stp. case steps (Suc 0, [], Oc\<^bsup>code (tcontra H)\<^esup>) (tcopy |+| H) stp of (s, tp')
+ \<Rightarrow> s = 0 \<and> (case tp' of (l, r) \<Rightarrow> (\<exists>nd. l = Bk\<^bsup>nd\<^esup>) \<and> r = [Oc])"
+ apply(rule_tac x = stp in exI, auto)
+ done
+ next
+ fix stp nd nda stpa
+ assume "isS0 (steps (Suc 0, Bk\<^bsup>nda\<^esup>, [Oc]) dither stpa)"
+ thus "False"
+ using dither_unhalt_rs[of nda]
+ apply auto
+ done
+ next
+ fix stp nd
+ show "\<lambda>(l, r). ((\<exists>nd. l = Bk\<^bsup>nd\<^esup>) \<and> r = [Oc]) \<turnstile>->
+ \<lambda>(l, r). ((\<exists>nd. l = Bk\<^bsup>nd\<^esup>) \<and> r = [Oc])"
+ by (simp add: t_imply_def)
+ qed
+ thus "\<not> haltP (tcontra H) (code (tcontra H))"
+ apply(simp add: t_imply_def haltP_def tcontra_def, auto)
+ apply(erule_tac x = n in allE, simp add: isS0_def)
+ done
+qed
+
+lemma uh_h:
+ assumes uh: "\<not> haltP (tcontra H) (code (tcontra H))"
+ shows "haltP (tcontra H) (code (tcontra H))"
+proof -
+ let ?cn = "code (tcontra H)"
+ have h1: "\<And> x. \<exists> na nb. steps (Suc 0, Bk\<^bsup>x\<^esup>, Oc\<^bsup>?cn\<^esup> @ Bk # Oc\<^bsup>?cn\<^esup>)
+ H na = (0, Bk\<^bsup>nb\<^esup>, [Oc, Oc])"
+ using uh
+ by(drule_tac x = x in nh_case, simp)
+ let ?P1 = "\<lambda> tp. let (l, r) = tp in (l = [] \<and>
+ (r::block list) = Oc\<^bsup>(?cn)\<^esup>)"
+ let ?Q1 = "\<lambda> (l, r).(\<exists> na. l = Bk\<^bsup>na\<^esup> \<and> r = [Oc, Oc])"
+ let ?P2 = ?Q1
+ let ?Q2 = ?Q1
+ let ?P3 = "\<lambda> tp. False"
+ have "?P1 \<turnstile>-> \<lambda> tp. (\<exists> stp tp'. steps (Suc 0, tp) ((tcopy |+| H ) |+| dither)
+ stp = (0, tp') \<and> ?Q2 tp')"
+ proof(rule_tac turing_merge.t_merge_halt[of "tcopy |+| H" dither ?P1 ?P2 ?P3 ?P3
+ ?Q1 ?Q2], auto simp: turing_merge_def)
+ show "\<exists>stp. case steps (Suc 0, [], Oc\<^bsup>code (tcontra H)\<^esup>) (tcopy |+| H) stp of (s, tp') \<Rightarrow>
+
+ s = 0 \<and> (case tp' of (l, r) \<Rightarrow> (\<exists>na. l = Bk\<^bsup>na\<^esup>) \<and> r = [Oc, Oc])"
+ proof -
+ let ?Q1 = "\<lambda> (l, r).(\<exists> nb. l = Bk\<^bsup>nb\<^esup> \<and> r = Oc\<^bsup>(?cn)\<^esup> @ Bk # Oc\<^bsup>(?cn)\<^esup>)"
+ let ?P2 = "?Q1"
+ let ?Q2 = "\<lambda> (l, r).(\<exists> na. l = Bk\<^bsup>na\<^esup> \<and> r = [Oc, Oc])"
+ have "?P1 \<turnstile>-> \<lambda> tp. (\<exists> stp tp'. steps (Suc 0, tp) (tcopy |+| H )
+ stp = (0, tp') \<and> ?Q2 tp')"
+ proof(rule_tac turing_merge.t_merge_halt[of tcopy H ?P1 ?P2 ?P3 ?P3
+ ?Q1 ?Q2], auto simp: turing_merge_def)
+ show "\<exists>stp. case steps (Suc 0, [], Oc\<^bsup>code (tcontra H)\<^esup>) tcopy stp of (s, tp') \<Rightarrow> s = 0
+ \<and> (case tp' of (l, r) \<Rightarrow> (\<exists>nb. l = Bk\<^bsup>nb\<^esup>) \<and> r = Oc\<^bsup>code (tcontra H)\<^esup> @ Bk # Oc\<^bsup>code (tcontra H)\<^esup>)"
+ using tcopy_halt_rs[of "?cn"]
+ apply(auto)
+ apply(rule_tac x = stp in exI, simp add: exponent_def)
+ done
+ next
+ fix nb
+ show "\<exists>stp. case steps (Suc 0, Bk\<^bsup>nb\<^esup>, Oc\<^bsup>code (tcontra H)\<^esup> @ Bk # Oc\<^bsup>code (tcontra H)\<^esup>) H stp of
+ (s, tp') \<Rightarrow> s = 0 \<and> (case tp' of (l, r) \<Rightarrow> (\<exists>na. l = Bk\<^bsup>na\<^esup>) \<and> r = [Oc, Oc])"
+ using h1[of nb]
+ apply(auto)
+ apply(rule_tac x = na in exI, auto)
+ done
+ next
+ show "\<lambda>(l, r). ((\<exists>nb. l = Bk\<^bsup>nb\<^esup>) \<and> r = Oc\<^bsup>code (tcontra H)\<^esup> @ Bk # Oc\<^bsup>code (tcontra H)\<^esup>) \<turnstile>->
+ \<lambda>(l, r). ((\<exists>nb. l = Bk\<^bsup>nb\<^esup>) \<and> r = Oc\<^bsup>code (tcontra H)\<^esup> @ Bk # Oc\<^bsup>code (tcontra H)\<^esup>)"
+ by(simp add: t_imply_def)
+ qed
+ hence "(\<exists> stp tp'. steps (Suc 0, [], Oc\<^bsup>?cn\<^esup>) (tcopy |+| H ) stp = (0, tp') \<and> ?Q2 tp')"
+ apply(simp add: t_imply_def)
+ done
+ thus "?thesis"
+ apply(auto)
+ apply(rule_tac x = stp in exI, auto)
+ done
+ qed
+ next
+ fix na
+ show "\<exists>stp. case steps (Suc 0, Bk\<^bsup>na\<^esup>, [Oc, Oc]) dither stp of (s, tp')
+ \<Rightarrow> s = 0 \<and> (case tp' of (l, r) \<Rightarrow> (\<exists>na. l = Bk\<^bsup>na\<^esup>) \<and> r = [Oc, Oc])"
+ using dither_halt_rs[of na]
+ apply(auto)
+ apply(rule_tac x = stp in exI, auto)
+ done
+ next
+ show "\<lambda>(l, r). ((\<exists>na. l = Bk\<^bsup>na\<^esup>) \<and> r = [Oc, Oc]) \<turnstile>->
+ (\<lambda>(l, r). (\<exists>na. l = Bk\<^bsup>na\<^esup>) \<and> r = [Oc, Oc])"
+ by (simp add: t_imply_def)
+ qed
+ hence "\<exists> stp tp'. steps (Suc 0, [], Oc\<^bsup>?cn\<^esup>) ((tcopy |+| H ) |+| dither)
+ stp = (0, tp') \<and> ?Q2 tp'"
+ apply(simp add: t_imply_def)
+ done
+ thus "haltP (tcontra H) (code (tcontra H))"
+ apply(auto simp: haltP_def tcontra_def)
+ apply(rule_tac x = stp in exI,
+ rule_tac x = na in exI,
+ rule_tac x = "Suc (Suc 0)" in exI,
+ rule_tac x = "0" in exI, simp add: exp_ind_def)
+ done
+qed
+
+text {*
+ @{text "False"} is finally derived.
+*}
+
+lemma "False"
+using uh_h h_uh
+by auto
+end
+
+end
+