(* Title: thys/CopyTM.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten

   Further contributions by Franz Regensburger (FABR) 02/2022:
   * Re-ordering of sections
   * Added comments

   Editorial note FABR:
   this file was part of the theory file Uncomputable.thy
   in the original AFP entry.

 *)

subsection \<open>A Turing machine that just duplicates its input if the input is a single numeral\<close>

text \<open>The machine tm\_copy is almost identical to the machine tm\_weak\_copy that we
presented in theory WeakCopyTM. They only differ in the first instruction of
component tm\_copy\_end (compare tm\_copy\_end\_orig and tm\_copy\_end\_new in theory WeakCopyTM).

As for machine tm\_dither, we keep the entire theory CopyTM for backwards compatibility with
the original AFP entry.\<close>

theory CopyTM
  imports
    Turing_Hoare
    Turing_HaltingConditions
begin

(* Cleanup the global simpset for proofs of several theorems about tm_dither *)

declare adjust.simps[simp del]

definition
  tm_copy_begin :: "instr list"
  where
    "tm_copy_begin \<equiv> [(WB, 0), (R, 2), (R, 3), (R, 2),
                 (WO, 3), (L, 4), (L, 4), (L, 0)]"

definition
  tm_copy_loop :: "instr list"
  where
    "tm_copy_loop \<equiv> [(R, 0), (R, 2),  (R, 3), (WB, 2),
                 (R, 3), (R, 4), (WO, 5), (R, 4),
                 (L, 6), (L, 5), (L, 6), (L, 1)]"

definition
  tm_copy_end :: "instr list"
  where
    "tm_copy_end \<equiv> [(L, 0), (R, 2), (WO, 3), (L, 4),
                (R, 2), (R, 2), (L, 5), (WB, 4),
                (R, 0), (L, 5)]"

definition
  tm_copy :: "instr list"
  where
    "tm_copy \<equiv> (tm_copy_begin |+| tm_copy_loop) |+| tm_copy_end"

(* tm_copy_begin *)

fun
  inv_begin0 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_begin1 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_begin2 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_begin3 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_begin4 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
  where
    "inv_begin0 n (l, r) = ((n > 1 \<and> (l, r) = (Oc \<up> (n - 2), [Oc, Oc, Bk, Oc])) \<or>
                          (n = 1 \<and> (l, r) = ([], [Bk, Oc, Bk, Oc])))"
  | "inv_begin1 n (l, r) = ((l, r) = ([], Oc \<up> n))"
  | "inv_begin2 n (l, r) = (\<exists> i j. i > 0 \<and> i + j = n \<and> (l, r) = (Oc \<up> i, Oc \<up> j))"
  | "inv_begin3 n (l, r) = (n > 0 \<and> (l, tl r) = (Bk # Oc \<up> n, []))"
  | "inv_begin4 n (l, r) = (n > 0 \<and> (l, r) = (Oc \<up> n, [Bk, Oc]) \<or> (l, r) = (Oc \<up> (n - 1), [Oc, Bk, Oc]))"

fun inv_begin :: "nat \<Rightarrow> config \<Rightarrow> bool"
  where
    "inv_begin n (s, tap) =
        (if s = 0 then inv_begin0 n tap else
         if s = 1 then inv_begin1 n tap else
         if s = 2 then inv_begin2 n tap else
         if s = 3 then inv_begin3 n tap else
         if s = 4 then inv_begin4 n tap
         else False)"

lemma inv_begin_step_E: "\<lbrakk>0 < i; 0 < j\<rbrakk> \<Longrightarrow>
  \<exists>ia>0. ia + j - Suc 0 = i + j \<and> Oc # Oc \<up> i = Oc \<up> ia"
  by (rule_tac x = "Suc i" in exI, simp)

lemma inv_begin_step:
  assumes "inv_begin n cf"
    and "n > 0"
  shows "inv_begin n (step0 cf tm_copy_begin)"
  using assms
  unfolding tm_copy_begin_def
  apply(cases cf)
  apply(auto simp: numeral_eqs_upto_12 split: if_splits elim:inv_begin_step_E)
  apply(cases "hd (snd (snd cf))";cases "(snd (snd cf))",auto)
  done

lemma inv_begin_steps:
  assumes "inv_begin n cf"
    and "n > 0"
  shows "inv_begin n (steps0 cf tm_copy_begin stp)"
  apply(induct stp)
   apply(simp add: assms)
  apply(auto simp del: steps.simps)
  apply(rule_tac inv_begin_step)
   apply(simp_all add: assms)
  done

lemma begin_partial_correctness:
  assumes "is_final (steps0 (1, [], Oc \<up> n) tm_copy_begin stp)"
  shows "0 < n \<Longrightarrow> \<lbrace>inv_begin1 n\<rbrace> tm_copy_begin \<lbrace>inv_begin0 n\<rbrace>"
proof(rule_tac Hoare_haltI)
  fix l r
  assume h: "0 < n" "inv_begin1 n (l, r)"
  have "inv_begin n (steps0 (1, [], Oc \<up> n) tm_copy_begin stp)"
    using h by (rule_tac inv_begin_steps) (simp_all)
  then show
    "\<exists>stp. is_final (steps0 (1, l, r) tm_copy_begin stp) \<and>
    inv_begin0 n holds_for steps (1, l, r) (tm_copy_begin, 0) stp"
    using h assms
    apply(rule_tac x = stp in exI)
    apply(case_tac "(steps0 (1, [], Oc \<up> n) tm_copy_begin stp)", simp)
    done
qed

fun measure_begin_state :: "config \<Rightarrow> nat"
  where
    "measure_begin_state (s, l, r) = (if s = 0 then 0 else 5 - s)"

fun measure_begin_step :: "config \<Rightarrow> nat"
  where
    "measure_begin_step (s, l, r) =
        (if s = 2 then length r else
         if s = 3 then (if r = [] \<or> r = [Bk] then 1 else 0) else
         if s = 4 then length l
         else 0)"

definition
  "measure_begin = measures [measure_begin_state, measure_begin_step]"

lemma wf_measure_begin:
  shows "wf measure_begin"
  unfolding measure_begin_def
  by auto

lemma measure_begin_induct [case_names Step]:
  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_begin\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
  using wf_measure_begin
  by (metis wf_iff_no_infinite_down_chain)

lemma begin_halts:
  assumes h: "x > 0"
  shows "\<exists> stp. is_final (steps0 (1, [], Oc \<up> x) tm_copy_begin stp)"
proof (induct rule: measure_begin_induct)
  case (Step n)
  have "\<not> is_final (steps0 (1, [], Oc \<up> x) tm_copy_begin n)" by fact
  moreover
  have "inv_begin x (steps0 (1, [], Oc \<up> x) tm_copy_begin n)"
    by (rule_tac inv_begin_steps) (simp_all add:  h)
  moreover
  obtain s l r where eq: "(steps0 (1, [], Oc \<up> x) tm_copy_begin n) = (s, l, r)"
    by (metis measure_begin_state.cases)
  ultimately
  have "(step0 (s, l, r) tm_copy_begin, s, l, r) \<in> measure_begin"
    apply(auto simp: measure_begin_def tm_copy_begin_def numeral_eqs_upto_12 split: if_splits)
    apply(subgoal_tac "r = [Oc]")
     apply(auto)
    by (metis cell.exhaust list.exhaust list.sel(3))
  then
  show "(steps0 (1, [], Oc \<up> x) tm_copy_begin (Suc n), steps0 (1, [], Oc \<up> x) tm_copy_begin n) \<in> measure_begin"
    using eq by (simp only: step_red)
qed

lemma begin_correct:
  shows "0 < n \<Longrightarrow> \<lbrace>inv_begin1 n\<rbrace> tm_copy_begin \<lbrace>inv_begin0 n\<rbrace>"
  using begin_partial_correctness begin_halts by blast

(* Delete some theorems from the simpset *)

declare seq_tm.simps [simp del]
declare shift.simps[simp del]
declare composable_tm.simps[simp del]
declare step.simps[simp del]
declare steps.simps[simp del]

(* tm_copy_loop *)

fun
  inv_loop1_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop1_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop5_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop5_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop6_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop6_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool"
  where
    "inv_loop1_loop n (l, r) = (\<exists> i j. i + j + 1 = n \<and> (l, r) = (Oc\<up>i, Oc#Oc#Bk\<up>j @ Oc\<up>j) \<and> j > 0)"
  | "inv_loop1_exit n (l, r) = (0 < n \<and> (l, r) = ([], Bk#Oc#Bk\<up>n @ Oc\<up>n))"
  | "inv_loop5_loop x (l, r) =
     (\<exists> i j k t. i + j = Suc x \<and> i > 0 \<and> j > 0 \<and> k + t = j \<and> t > 0 \<and> (l, r) = (Oc\<up>k@Bk\<up>j@Oc\<up>i, Oc\<up>t))"
  | "inv_loop5_exit x (l, r) =
     (\<exists> i j. i + j = Suc x \<and> i > 0 \<and> j > 0 \<and> (l, r) = (Bk\<up>(j - 1)@Oc\<up>i, Bk # Oc\<up>j))"
  | "inv_loop6_loop x (l, r) =
     (\<exists> i j k t. i + j = Suc x \<and> i > 0 \<and> k + t + 1 = j \<and> (l, r) = (Bk\<up>k @ Oc\<up>i, Bk\<up>(Suc t) @ Oc\<up>j))"
  | "inv_loop6_exit x (l, r) =
     (\<exists> i j. i + j = x \<and> j > 0 \<and> (l, r) = (Oc\<up>i, Oc#Bk\<up>j @ Oc\<up>j))"

fun
  inv_loop0 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop1 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop2 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop3 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop4 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop5 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_loop6 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
  where
    "inv_loop0 n (l, r) =  (0 < n \<and> (l, r) = ([Bk], Oc # Bk\<up>n @ Oc\<up>n))"
  | "inv_loop1 n (l, r) = (inv_loop1_loop n (l, r) \<or> inv_loop1_exit n (l, r))"
  | "inv_loop2 n (l, r) = (\<exists> i j any. i + j = n \<and> n > 0 \<and> i > 0 \<and> j > 0 \<and> (l, r) = (Oc\<up>i, any#Bk\<up>j@Oc\<up>j))"
  | "inv_loop3 n (l, r) =
     (\<exists> i j k t. i + j = n \<and> i > 0 \<and> j > 0 \<and>  k + t = Suc j \<and> (l, r) = (Bk\<up>k@Oc\<up>i, Bk\<up>t@Oc\<up>j))"
  | "inv_loop4 n (l, r) =
     (\<exists> i j k t. i + j = n \<and> i > 0 \<and> j > 0 \<and>  k + t = j \<and> (l, r) = (Oc\<up>k @ Bk\<up>(Suc j)@Oc\<up>i, Oc\<up>t))"
  | "inv_loop5 n (l, r) = (inv_loop5_loop n (l, r) \<or> inv_loop5_exit n (l, r))"
  | "inv_loop6 n (l, r) = (inv_loop6_loop n (l, r) \<or> inv_loop6_exit n (l, r))"

fun inv_loop :: "nat \<Rightarrow> config \<Rightarrow> bool"
  where
    "inv_loop x (s, l, r) =
         (if s = 0 then inv_loop0 x (l, r)
          else if s = 1 then inv_loop1 x (l, r)
          else if s = 2 then inv_loop2 x (l, r)
          else if s = 3 then inv_loop3 x (l, r)
          else if s = 4 then inv_loop4 x (l, r)
          else if s = 5 then inv_loop5 x (l, r)
          else if s = 6 then inv_loop6 x (l, r)
          else False)"

declare inv_loop.simps[simp del] inv_loop1.simps[simp del]
  inv_loop2.simps[simp del] inv_loop3.simps[simp del]
  inv_loop4.simps[simp del] inv_loop5.simps[simp del]
  inv_loop6.simps[simp del]

lemma inv_loop3_Bk_empty_via_2[elim]: "\<lbrakk>0 < x; inv_loop2 x (b, [])\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, [])"
  by (auto simp: inv_loop2.simps inv_loop3.simps)

lemma inv_loop3_Bk_empty[elim]: "\<lbrakk>0 < x; inv_loop3 x (b, [])\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, [])"
  by (auto simp: inv_loop3.simps)

lemma inv_loop5_Oc_empty_via_4[elim]: "\<lbrakk>0 < x; inv_loop4 x (b, [])\<rbrakk> \<Longrightarrow> inv_loop5 x (b, [Oc])"
  by(auto simp: inv_loop4.simps inv_loop5.simps;force)

lemma inv_loop1_Bk[elim]: "\<lbrakk>0 < x; inv_loop1 x (b, Bk # list)\<rbrakk> \<Longrightarrow> list = Oc # Bk \<up> x @ Oc \<up> x"
  by (auto simp: inv_loop1.simps)

lemma inv_loop3_Bk_via_2[elim]: "\<lbrakk>0 < x; inv_loop2 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, list)"
  by(auto simp: inv_loop2.simps inv_loop3.simps;force)

lemma inv_loop3_Bk_move[elim]: "\<lbrakk>0 < x; inv_loop3 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_loop3 x (Bk # b, list)"
  apply(auto simp: inv_loop3.simps)
   apply (rename_tac i j k t)
   apply(rule_tac [!] x = i in exI,
      rule_tac [!] x = j in exI, simp_all)
   apply(case_tac [!] t, auto)
  done

lemma inv_loop5_Oc_via_4_Bk[elim]: "\<lbrakk>0 < x; inv_loop4 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_loop5 x (b, Oc # list)"
  by (auto simp: inv_loop4.simps inv_loop5.simps)

lemma inv_loop6_Bk_via_5[elim]: "\<lbrakk>0 < x; inv_loop5 x ([], Bk # list)\<rbrakk> \<Longrightarrow> inv_loop6 x ([], Bk # Bk # list)"
  by (auto simp: inv_loop6.simps inv_loop5.simps)

lemma inv_loop5_loop_no_Bk[simp]: "inv_loop5_loop x (b, Bk # list) = False"
  by (auto simp: inv_loop5.simps)

lemma inv_loop6_exit_no_Bk[simp]: "inv_loop6_exit x (b, Bk # list) = False"
  by (auto simp: inv_loop6.simps)

declare inv_loop5_loop.simps[simp del]  inv_loop5_exit.simps[simp del]
  inv_loop6_loop.simps[simp del]  inv_loop6_exit.simps[simp del]

lemma inv_loop6_loopBk_via_5[elim]:"\<lbrakk>0 < x; inv_loop5_exit x (b, Bk # list); b \<noteq> []; hd b = Bk\<rbrakk>
          \<Longrightarrow> inv_loop6_loop x (tl b, Bk # Bk # list)"
  apply(simp only: inv_loop5_exit.simps inv_loop6_loop.simps )
  apply(erule_tac exE)+
  apply(rename_tac i j)
  apply(rule_tac x = i in exI,
      rule_tac x = j in exI,
      rule_tac x = "j - Suc (Suc 0)" in exI,
      rule_tac x = "Suc 0" in exI, auto)
   apply(case_tac [!] j, simp_all)
   apply(case_tac [!] "j-1", simp_all)
  done

lemma inv_loop6_loop_no_Oc_Bk[simp]: "inv_loop6_loop x (b, Oc # Bk # list) = False"
  by (auto simp: inv_loop6_loop.simps)

lemma inv_loop6_exit_Oc_Bk_via_5[elim]: "\<lbrakk>x > 0; inv_loop5_exit x (b, Bk # list); b \<noteq> []; hd b = Oc\<rbrakk> \<Longrightarrow>
  inv_loop6_exit x (tl b, Oc # Bk # list)"
  apply(simp only: inv_loop5_exit.simps inv_loop6_exit.simps)
  apply(erule_tac exE)+
  apply(rule_tac x = "x - 1" in exI, rule_tac x = 1 in exI, simp)
  apply(rename_tac i j)
  apply(case_tac j;case_tac "j-1", auto)
  done

lemma inv_loop6_Bk_tail_via_5[elim]: "\<lbrakk>0 < x; inv_loop5 x (b, Bk # list); b \<noteq> []\<rbrakk> \<Longrightarrow> inv_loop6 x (tl b, hd b # Bk # list)"
  apply(simp add: inv_loop5.simps inv_loop6.simps)
  apply(cases "hd b", simp_all, auto)
  done

lemma inv_loop6_loop_Bk_Bk_drop[elim]: "\<lbrakk>0 < x; inv_loop6_loop x (b, Bk # list); b \<noteq> []; hd b = Bk\<rbrakk>
              \<Longrightarrow> inv_loop6_loop x (tl b, Bk # Bk # list)"
  apply(simp only: inv_loop6_loop.simps)
  apply(erule_tac exE)+
  apply(rename_tac i j k t)
  apply(rule_tac x = i in exI, rule_tac x = j in exI,
      rule_tac x = "k - 1" in exI, rule_tac x = "Suc t" in exI, auto)
   apply(case_tac [!] k, auto)
  done

lemma inv_loop6_exit_Oc_Bk_via_loop6[elim]: "\<lbrakk>0 < x; inv_loop6_loop x (b, Bk # list); b \<noteq> []; hd b = Oc\<rbrakk>
        \<Longrightarrow> inv_loop6_exit x (tl b, Oc # Bk # list)"
  apply(simp only: inv_loop6_loop.simps inv_loop6_exit.simps)
  apply(erule_tac exE)+
  apply(rename_tac i j k t)
  apply(rule_tac x = "i - 1" in exI, rule_tac x = j in exI, auto)
   apply(case_tac [!] k, auto)
  done

lemma inv_loop6_Bk_tail[elim]: "\<lbrakk>0 < x; inv_loop6 x (b, Bk # list); b \<noteq> []\<rbrakk> \<Longrightarrow> inv_loop6 x (tl b, hd b # Bk # list)"
  apply(simp add: inv_loop6.simps)
  apply(case_tac "hd b", simp_all, auto)
  done

lemma inv_loop2_Oc_via_1[elim]: "\<lbrakk>0 < x; inv_loop1 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_loop2 x (Oc # b, list)"
  apply(auto simp: inv_loop1.simps inv_loop2.simps,force)
  done

lemma inv_loop2_Bk_via_Oc[elim]: "\<lbrakk>0 < x; inv_loop2 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_loop2 x (b, Bk # list)"
  by (auto simp: inv_loop2.simps)

lemma inv_loop4_Oc_via_3[elim]: "\<lbrakk>0 < x; inv_loop3 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_loop4 x (Oc # b, list)"
  apply(auto simp: inv_loop3.simps inv_loop4.simps)
   apply(rename_tac i j)
   apply(rule_tac [!] x = i in exI, auto)
   apply(rule_tac [!] x = "Suc 0" in exI, rule_tac [!] x = "j - 1" in exI)
   apply(case_tac [!] j, auto)
  done

lemma inv_loop4_Oc_move[elim]:
  assumes "0 < x" "inv_loop4 x (b, Oc # list)"
  shows "inv_loop4 x (Oc # b, list)"
proof -
  from assms[unfolded inv_loop4.simps] obtain i j k t where
    "i + j = x"
    "0 < i" "0 < j" "k + t = j" "(b, Oc # list) = (Oc \<up> k @ Bk \<up> Suc j @ Oc \<up> i, Oc \<up> t)"
    by auto
  thus ?thesis unfolding inv_loop4.simps
    apply(rule_tac [!] x = "i" in exI,rule_tac [!] x = "j" in exI)
    apply(rule_tac [!] x = "Suc k" in exI,rule_tac [!] x = "t - 1" in exI)
    by(cases t,auto)
qed

lemma inv_loop5_exit_no_Oc[simp]: "inv_loop5_exit x (b, Oc # list) = False"
  by (auto simp: inv_loop5_exit.simps)

lemma inv_loop5_exit_Bk_Oc_via_loop[elim]: " \<lbrakk>inv_loop5_loop x (b, Oc # list); b \<noteq> []; hd b = Bk\<rbrakk>
  \<Longrightarrow> inv_loop5_exit x (tl b, Bk # Oc # list)"
  apply(simp only: inv_loop5_loop.simps inv_loop5_exit.simps)
  apply(erule_tac exE)+
  apply(rename_tac i j k t)
  apply(rule_tac x = i in exI)
  apply(case_tac k, auto)
  done

lemma inv_loop5_loop_Oc_Oc_drop[elim]: "\<lbrakk>inv_loop5_loop x (b, Oc # list); b \<noteq> []; hd b = Oc\<rbrakk>
           \<Longrightarrow> inv_loop5_loop x (tl b, Oc # Oc # list)"
  apply(simp only:  inv_loop5_loop.simps)
  apply(erule_tac exE)+
  apply(rename_tac i j k t)
  apply(rule_tac x = i in exI, rule_tac x = j in exI)
  apply(rule_tac x = "k - 1" in exI, rule_tac x = "Suc t" in exI)
  apply(case_tac k, auto)
  done

lemma inv_loop5_Oc_tl[elim]: "\<lbrakk>inv_loop5 x (b, Oc # list); b \<noteq> []\<rbrakk> \<Longrightarrow> inv_loop5 x (tl b, hd b # Oc # list)"
  apply(simp add: inv_loop5.simps)
  apply(cases "hd b", simp_all, auto)
  done

lemma inv_loop1_Bk_Oc_via_6[elim]: "\<lbrakk>0 < x; inv_loop6 x ([], Oc # list)\<rbrakk> \<Longrightarrow> inv_loop1 x ([], Bk # Oc # list)"
  by(auto simp: inv_loop6.simps inv_loop1.simps inv_loop6_loop.simps inv_loop6_exit.simps)

lemma inv_loop1_Oc_via_6[elim]: "\<lbrakk>0 < x; inv_loop6 x (b, Oc # list); b \<noteq> []\<rbrakk>
           \<Longrightarrow> inv_loop1 x (tl b, hd b # Oc # list)"
  by(auto simp: inv_loop6.simps inv_loop1.simps inv_loop6_loop.simps inv_loop6_exit.simps)

lemma inv_loop_nonempty[simp]:
  "inv_loop1 x (b, []) = False"
  "inv_loop2 x ([], b) = False"
  "inv_loop2 x (l', []) = False"
  "inv_loop3 x (b, []) = False"
  "inv_loop4 x ([], b) = False"
  "inv_loop5 x ([], list) = False"
  "inv_loop6 x ([], Bk # xs) = False"
  by (auto simp: inv_loop1.simps inv_loop2.simps inv_loop3.simps inv_loop4.simps
      inv_loop5.simps inv_loop6.simps inv_loop5_exit.simps inv_loop5_loop.simps
      inv_loop6_loop.simps)

lemma inv_loop_nonemptyE[elim]:
  "\<lbrakk>inv_loop5 x (b, [])\<rbrakk> \<Longrightarrow> RR" "inv_loop6 x (b, []) \<Longrightarrow> RR"
  "\<lbrakk>inv_loop1 x (b, Bk # list)\<rbrakk> \<Longrightarrow> b = []"
  by (auto simp: inv_loop4.simps inv_loop5.simps inv_loop5_exit.simps inv_loop5_loop.simps
      inv_loop6.simps inv_loop6_exit.simps inv_loop6_loop.simps inv_loop1.simps)

lemma inv_loop6_Bk_Bk_drop[elim]: "\<lbrakk>inv_loop6 x ([], Bk # list)\<rbrakk> \<Longrightarrow> inv_loop6 x ([], Bk # Bk # list)"
  by (simp)

lemma inv_loop_step:
  "\<lbrakk>inv_loop x cf; x > 0\<rbrakk> \<Longrightarrow> inv_loop x (step cf (tm_copy_loop, 0))"
  apply(cases cf, cases "snd (snd cf)"; cases "hd (snd (snd cf))")
     apply(auto simp: inv_loop.simps step.simps tm_copy_loop_def numeral_eqs_upto_12 split: if_splits)
  done

lemma inv_loop_steps:
  "\<lbrakk>inv_loop x cf; x > 0\<rbrakk> \<Longrightarrow> inv_loop x (steps cf (tm_copy_loop, 0) stp)"
  apply(induct stp, simp add: steps.simps, simp)
  apply(erule_tac inv_loop_step, simp)
  done

fun loop_stage :: "config \<Rightarrow> nat"
  where
    "loop_stage (s, l, r) = (if s = 0 then 0
                           else (Suc (length (takeWhile (\<lambda>a. a = Oc) (rev l @ r)))))"

fun loop_state :: "config \<Rightarrow> nat"
  where
    "loop_state (s, l, r) = (if s = 2 \<and> hd r = Oc then 0
                           else if s = 1 then 1
                           else 10 - s)"

fun loop_step :: "config \<Rightarrow> nat"
  where
    "loop_step (s, l, r) = (if s = 3 then length r
                          else if s = 4 then length r
                          else if s = 5 then length l
                          else if s = 6 then length l
                          else 0)"

definition measure_loop :: "(config \<times> config) set"
  where
    "measure_loop = measures [loop_stage, loop_state, loop_step]"

lemma wf_measure_loop: "wf measure_loop"
  unfolding measure_loop_def
  by (auto)

lemma measure_loop_induct [case_names Step]:
  "\<lbrakk>\<And>n. \<not> P (f n) \<Longrightarrow> (f (Suc n), (f n)) \<in> measure_loop\<rbrakk> \<Longrightarrow> \<exists>n. P (f n)"
  using wf_measure_loop
  by (metis wf_iff_no_infinite_down_chain)

lemma inv_loop4_not_just_Oc[elim]:
  "\<lbrakk>inv_loop4 x (l', []);
  length (takeWhile (\<lambda>a. a = Oc) (rev l' @ [Oc])) \<noteq>
  length (takeWhile (\<lambda>a. a = Oc) (rev l'))\<rbrakk>
  \<Longrightarrow> RR"
  "\<lbrakk>inv_loop4 x (l', Bk # list);
   length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Oc # list)) \<noteq>
    length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Bk # list))\<rbrakk>
    \<Longrightarrow> RR"
   apply(auto simp: inv_loop4.simps)
  apply(rename_tac i j)
  apply(case_tac [!] j, simp_all add: List.takeWhile_tail)
  done

lemma takeWhile_replicate_append:
  "P a \<Longrightarrow> takeWhile P (a\<up>x @ ys) = a\<up>x @ takeWhile P ys"
  by (induct x, auto)

lemma takeWhile_replicate:
  "P a \<Longrightarrow> takeWhile P (a\<up>x) = a\<up>x"
  by (induct x, auto)

lemma inv_loop5_Bk_E[elim]:
  "\<lbrakk>inv_loop5 x (l', Bk # list); l' \<noteq> [];
   length (takeWhile (\<lambda>a. a = Oc) (rev (tl l') @ hd l' # Bk # list)) \<noteq>
   length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Bk # list))\<rbrakk>
   \<Longrightarrow> RR"
  apply(cases "length list";cases "length list - 1"
      ,auto simp: inv_loop5.simps inv_loop5_exit.simps
      takeWhile_replicate_append takeWhile_replicate)
   apply(cases "length list - 2"; force simp add: List.takeWhile_tail)+
  done

lemma inv_loop1_hd_Oc[elim]: "\<lbrakk>inv_loop1 x (l', Oc # list)\<rbrakk> \<Longrightarrow> hd list = Oc"
  by (auto simp: inv_loop1.simps)

lemma inv_loop6_not_just_Bk[dest!]:
  "\<lbrakk>length (takeWhile P (rev (tl l') @ hd l' # list)) \<noteq>
  length (takeWhile P (rev l' @ list))\<rbrakk>
  \<Longrightarrow> l' = []"
  apply(cases l', simp_all)
  done

lemma inv_loop2_OcE[elim]:
  "\<lbrakk>inv_loop2 x (l', Oc # list); l' \<noteq> []\<rbrakk> \<Longrightarrow>
  length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Bk # list)) <
  length (takeWhile (\<lambda>a. a = Oc) (rev l' @ Oc # list))"
  apply(auto simp: inv_loop2.simps takeWhile_tail takeWhile_replicate_append
      takeWhile_replicate)
  done

lemma loop_halts:
  assumes h: "n > 0" "inv_loop n (1, l, r)"
  shows "\<exists> stp. is_final (steps0 (1, l, r) tm_copy_loop stp)"
proof (induct rule: measure_loop_induct)
  case (Step stp)
  have "\<not> is_final (steps0 (1, l, r) tm_copy_loop stp)" by fact
  moreover
  have "inv_loop n (steps0 (1, l, r) tm_copy_loop stp)"
    by (rule_tac inv_loop_steps) (simp_all only: h)
  moreover
  obtain s l' r' where eq: "(steps0 (1, l, r) tm_copy_loop stp) = (s, l', r')"
    by (metis measure_begin_state.cases)
  ultimately
  have "(step0 (s, l', r') tm_copy_loop, s, l', r') \<in> measure_loop"
    using h(1)
    apply(cases r';cases "hd r'")
    apply(auto simp: inv_loop.simps step.simps tm_copy_loop_def numeral_eqs_upto_12 measure_loop_def split: if_splits)
    done
  then
  show "(steps0 (1, l, r) tm_copy_loop (Suc stp), steps0 (1, l, r) tm_copy_loop stp) \<in> measure_loop"
    using eq by (simp only: step_red)
qed

lemma loop_correct:
  assumes "0 < n"
  shows "\<lbrace>inv_loop1 n\<rbrace> tm_copy_loop \<lbrace>inv_loop0 n\<rbrace>"
  using assms
proof(rule_tac Hoare_haltI)
  fix l r
  assume h: "0 < n" "inv_loop1 n (l, r)"
  then obtain stp where k: "is_final (steps0 (1, l, r) tm_copy_loop stp)"
    using loop_halts
    apply(simp add: inv_loop.simps)
    apply(blast)
    done
  moreover
  have "inv_loop n (steps0 (1, l, r) tm_copy_loop stp)"
    using h
    by (rule_tac inv_loop_steps) (simp_all add: inv_loop.simps)
  ultimately show
    "\<exists>stp. is_final (steps0 (1, l, r) tm_copy_loop stp) \<and>
    inv_loop0 n holds_for steps0 (1, l, r) tm_copy_loop stp"
    using h(1)
    apply(rule_tac x = stp in exI)
    apply(case_tac "(steps0 (1, l, r) tm_copy_loop stp)")
    apply(simp add: inv_loop.simps)
    done
qed

(* tm_copy_end *)

fun
  inv_end5_loop :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_end5_exit :: "nat \<Rightarrow> tape \<Rightarrow> bool"
  where
    "inv_end5_loop x (l, r) =
     (\<exists> i j. i + j = x \<and> x > 0 \<and> j > 0 \<and> l = Oc\<up>i @ [Bk] \<and> r = Oc\<up>j @ Bk # Oc\<up>x)"
  | "inv_end5_exit x (l, r) = (x > 0 \<and> l = [] \<and> r = Bk # Oc\<up>x @ Bk # Oc\<up>x)"

fun
  inv_end0 :: "nat \<Rightarrow> tape \<Rightarrow>  bool" and
  inv_end1 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_end2 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_end3 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_end4 :: "nat \<Rightarrow> tape \<Rightarrow> bool" and
  inv_end5 :: "nat \<Rightarrow> tape \<Rightarrow> bool"
  where
    "inv_end0 n (l, r) = (n > 0 \<and> (l, r) = ([Bk], Oc\<up>n @ Bk # Oc\<up>n))"
  | "inv_end1 n (l, r) = (n > 0 \<and> (l, r) = ([Bk], Oc # Bk\<up>n @ Oc\<up>n))"
  | "inv_end2 n (l, r) = (\<exists> i j. i + j = Suc n \<and> n > 0 \<and> l = Oc\<up>i @ [Bk] \<and> r = Bk\<up>j @ Oc\<up>n)"
  | "inv_end3 n (l, r) =
     (\<exists> i j. n > 0 \<and> i + j = n \<and> l = Oc\<up>i @ [Bk] \<and> r = Oc # Bk\<up>j@ Oc\<up>n)"
  | "inv_end4 n (l, r) = (\<exists> any. n > 0 \<and> l = Oc\<up>n @ [Bk] \<and> r = any#Oc\<up>n)"
  | "inv_end5 n (l, r) = (inv_end5_loop n (l, r) \<or> inv_end5_exit n (l, r))"

fun
  inv_end :: "nat \<Rightarrow> config \<Rightarrow> bool"
  where
    "inv_end n (s, l, r) = (if s = 0 then inv_end0 n (l, r)
                          else if s = 1 then inv_end1 n (l, r)
                          else if s = 2 then inv_end2 n (l, r)
                          else if s = 3 then inv_end3 n (l, r)
                          else if s = 4 then inv_end4 n (l, r)
                          else if s = 5 then inv_end5 n (l, r)
                          else False)"

declare inv_end.simps[simp del] inv_end1.simps[simp del]
  inv_end0.simps[simp del] inv_end2.simps[simp del]
  inv_end3.simps[simp del] inv_end4.simps[simp del]
  inv_end5.simps[simp del]

lemma inv_end_nonempty[simp]:
  "inv_end1 x (b, []) = False"
  "inv_end1 x ([], list) = False"
  "inv_end2 x (b, []) = False"
  "inv_end3 x (b, []) = False"
  "inv_end4 x (b, []) = False"
  "inv_end5 x (b, []) = False"
  "inv_end5 x ([], Oc # list) = False"
  by (auto simp: inv_end1.simps inv_end2.simps inv_end3.simps inv_end4.simps inv_end5.simps)

lemma inv_end0_Bk_via_1[elim]: "\<lbrakk>0 < x; inv_end1 x (b, Bk # list); b \<noteq> []\<rbrakk>
  \<Longrightarrow> inv_end0 x (tl b, hd b # Bk # list)"
  by (auto simp: inv_end1.simps inv_end0.simps)

lemma inv_end3_Oc_via_2[elim]: "\<lbrakk>0 < x; inv_end2 x (b, Bk # list)\<rbrakk>
  \<Longrightarrow> inv_end3 x (b, Oc # list)"
  apply(auto simp: inv_end2.simps inv_end3.simps)
  by (metis Cons_replicate_eq One_nat_def Suc_inject Suc_pred add_Suc_right cell.distinct(1)
      empty_replicate list.sel(3) neq0_conv self_append_conv2 tl_append2 tl_replicate)

lemma inv_end2_Bk_via_3[elim]: "\<lbrakk>0 < x; inv_end3 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_end2 x (Bk # b, list)"
  by (auto simp: inv_end2.simps inv_end3.simps)

lemma inv_end5_Bk_via_4[elim]: "\<lbrakk>0 < x; inv_end4 x ([], Bk # list)\<rbrakk> \<Longrightarrow>
  inv_end5 x ([], Bk # Bk # list)"
  by (auto simp: inv_end4.simps inv_end5.simps)

lemma inv_end5_Bk_tail_via_4[elim]: "\<lbrakk>0 < x; inv_end4 x (b, Bk # list); b \<noteq> []\<rbrakk> \<Longrightarrow>
  inv_end5 x (tl b, hd b # Bk # list)"
  apply(auto simp: inv_end4.simps inv_end5.simps)
  apply(rule_tac x = 1 in exI, simp)
  done

lemma inv_end0_Bk_via_5[elim]: "\<lbrakk>0 < x; inv_end5 x (b, Bk # list)\<rbrakk> \<Longrightarrow> inv_end0 x (Bk # b, list)"
  by(auto simp: inv_end5.simps inv_end0.simps gr0_conv_Suc)

lemma inv_end2_Oc_via_1[elim]: "\<lbrakk>0 < x; inv_end1 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_end2 x (Oc # b, list)"
  by (auto simp: inv_end1.simps inv_end2.simps)

lemma inv_end4_Bk_Oc_via_2[elim]: "\<lbrakk>0 < x; inv_end2 x ([], Oc # list)\<rbrakk> \<Longrightarrow>
               inv_end4 x ([], Bk # Oc # list)"
  by (auto simp: inv_end2.simps inv_end4.simps)

lemma inv_end4_Oc_via_2[elim]:  "\<lbrakk>0 < x; inv_end2 x (b, Oc # list); b \<noteq> []\<rbrakk> \<Longrightarrow>
  inv_end4 x (tl b, hd b # Oc # list)"
  by(auto simp: inv_end2.simps inv_end4.simps gr0_conv_Suc)

lemma inv_end2_Oc_via_3[elim]: "\<lbrakk>0 < x; inv_end3 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_end2 x (Oc # b, list)"
  by (auto simp: inv_end2.simps inv_end3.simps)

lemma inv_end4_Bk_via_Oc[elim]: "\<lbrakk>0 < x; inv_end4 x (b, Oc # list)\<rbrakk> \<Longrightarrow> inv_end4 x (b, Bk # list)"
  by (auto simp: inv_end2.simps inv_end4.simps)

lemma inv_end5_Bk_drop_Oc[elim]: "\<lbrakk>0 < x; inv_end5 x ([], Oc # list)\<rbrakk> \<Longrightarrow> inv_end5 x ([], Bk # Oc # list)"
  by (auto simp: inv_end2.simps inv_end5.simps)

declare inv_end5_loop.simps[simp del]
  inv_end5_exit.simps[simp del]

lemma inv_end5_exit_no_Oc[simp]: "inv_end5_exit x (b, Oc # list) = False"
  by (auto simp: inv_end5_exit.simps)

lemma inv_end5_loop_no_Bk_Oc[simp]: "inv_end5_loop x (tl b, Bk # Oc # list) = False"
  by (auto simp: inv_end5_loop.simps)

lemma inv_end5_exit_Bk_Oc_via_loop[elim]:
  "\<lbrakk>0 < x; inv_end5_loop x (b, Oc # list); b \<noteq> []; hd b = Bk\<rbrakk> \<Longrightarrow>
  inv_end5_exit x (tl b, Bk # Oc # list)"
  apply(auto simp: inv_end5_loop.simps inv_end5_exit.simps)
  using hd_replicate apply fastforce
  by (metis cell.distinct(1) hd_append2 hd_replicate list.sel(3) self_append_conv2
      split_head_repeat(2))

lemma inv_end5_loop_Oc_Oc_drop[elim]:
  "\<lbrakk>0 < x; inv_end5_loop x (b, Oc # list); b \<noteq> []; hd b = Oc\<rbrakk> \<Longrightarrow>
  inv_end5_loop x (tl b, Oc # Oc # list)"
  apply(simp only: inv_end5_loop.simps inv_end5_exit.simps)
  apply(erule_tac exE)+
  apply(rename_tac i j)
  apply(rule_tac x = "i - 1" in exI,
      rule_tac x = "Suc j" in exI, auto)
   apply(case_tac [!] i, simp_all)
  done

lemma inv_end5_Oc_tail[elim]: "\<lbrakk>0 < x; inv_end5 x (b, Oc # list); b \<noteq> []\<rbrakk> \<Longrightarrow>
  inv_end5 x (tl b, hd b # Oc # list)"
  apply(simp add: inv_end2.simps inv_end5.simps)
  apply(case_tac "hd b", simp_all, auto)
  done

lemma inv_end_step:
  "\<lbrakk>x > 0; inv_end x cf\<rbrakk> \<Longrightarrow> inv_end x (step cf (tm_copy_end, 0))"
  apply(cases cf, cases "snd (snd cf)"; cases "hd (snd (snd cf))")
     apply(auto simp: inv_end.simps step.simps tm_copy_end_def numeral_eqs_upto_12 split: if_splits)
  done

lemma inv_end_steps:
  "\<lbrakk>x > 0; inv_end x cf\<rbrakk> \<Longrightarrow> inv_end x (steps cf (tm_copy_end, 0) stp)"
  apply(induct stp, simp add:steps.simps, simp)
  apply(erule_tac inv_end_step, simp)
  done

fun end_state :: "config \<Rightarrow> nat"
  where
    "end_state (s, l, r) =
       (if s = 0 then 0
        else if s = 1 then 5
        else if s = 2 \<or> s = 3 then 4
        else if s = 4 then 3
        else if s = 5 then 2
        else 0)"

fun end_stage :: "config \<Rightarrow> nat"
  where
    "end_stage (s, l, r) =
          (if s = 2 \<or> s = 3 then (length r) else 0)"

fun end_step :: "config \<Rightarrow> nat"
  where
    "end_step (s, l, r) =
         (if s = 4 then (if hd r = Oc then 1 else 0)
          else if s = 5 then length l
          else if s = 2 then 1
          else if s = 3 then 0
          else 0)"

definition end_LE :: "(config \<times> config) set"
  where
    "end_LE = measures [end_state, end_stage, end_step]"

lemma wf_end_le: "wf end_LE"
  unfolding end_LE_def by auto

lemma end_halt:
  "\<lbrakk>x > 0; inv_end x (Suc 0, l, r)\<rbrakk> \<Longrightarrow>
      \<exists> stp. is_final (steps (Suc 0, l, r) (tm_copy_end, 0) stp)"
proof(rule halt_lemma[OF wf_end_le])
  assume great: "0 < x"
    and inv_start: "inv_end x (Suc 0, l, r)"
  show "\<forall>n. \<not> is_final (steps (Suc 0, l, r) (tm_copy_end, 0) n) \<longrightarrow>
    (steps (Suc 0, l, r) (tm_copy_end, 0) (Suc n), steps (Suc 0, l, r) (tm_copy_end, 0) n) \<in> end_LE"
  proof(rule_tac allI, rule_tac impI)
    fix n
    assume notfinal: "\<not> is_final (steps (Suc 0, l, r) (tm_copy_end, 0) n)"
    obtain s' l' r' where d: "steps (Suc 0, l, r) (tm_copy_end, 0) n = (s', l', r')"
      apply(case_tac "steps (Suc 0, l, r) (tm_copy_end, 0) n", auto)
      done
    hence "inv_end x (s', l', r') \<and> s' \<noteq> 0"
      using great inv_start notfinal
      apply(drule_tac stp = n in inv_end_steps, auto)
      done
    hence "(step (s', l', r') (tm_copy_end, 0), s', l', r') \<in> end_LE"
      apply(cases r'; cases "hd r'")
         apply(auto simp: inv_end.simps step.simps tm_copy_end_def numeral_eqs_upto_12 end_LE_def split: if_splits)
      done
    thus "(steps (Suc 0, l, r) (tm_copy_end, 0) (Suc n),
      steps (Suc 0, l, r) (tm_copy_end, 0) n) \<in> end_LE"
      using d
      by simp
  qed
qed

lemma end_correct:
  "n > 0 \<Longrightarrow> \<lbrace>inv_end1 n\<rbrace> tm_copy_end \<lbrace>inv_end0 n\<rbrace>"
proof(rule_tac Hoare_haltI)
  fix l r
  assume h: "0 < n"
    "inv_end1 n (l, r)"
  then have "\<exists> stp. is_final (steps0 (1, l, r) tm_copy_end stp)"
    by (simp add: end_halt inv_end.simps)
  then obtain stp where "is_final (steps0 (1, l, r) tm_copy_end stp)" ..
  moreover have "inv_end n (steps0 (1, l, r) tm_copy_end stp)"
    apply(rule_tac inv_end_steps)
    using h by(simp_all add: inv_end.simps)
  ultimately show
    "\<exists>stp. is_final (steps (1, l, r) (tm_copy_end, 0) stp) \<and>
    inv_end0 n holds_for steps (1, l, r) (tm_copy_end, 0) stp"
    using h
    apply(rule_tac x = stp in exI)
    apply(cases "(steps0 (1, l, r) tm_copy_end stp)")
    apply(simp add: inv_end.simps)
    done
qed

(* tm_copy *)

(* The tm_copy machine and all of its parts are composable
 * (in the old terminologies: well-formed)
 *)

lemma [intro]:
  "composable_tm (tm_copy_begin, 0)"
  "composable_tm (tm_copy_loop, 0)"
  "composable_tm (tm_copy_end, 0)"
  by (auto simp: composable_tm.simps tm_copy_end_def tm_copy_loop_def tm_copy_begin_def)

lemma composable_tm0_tm_copy[intro, simp]: "composable_tm0 tm_copy"
  by (auto simp: tm_copy_def)

lemma tm_copy_correct1:
  assumes "0 < x"
  shows "\<lbrace>inv_begin1 x\<rbrace> tm_copy \<lbrace>inv_end0 x\<rbrace>"
proof -
  have "\<lbrace>inv_begin1 x\<rbrace> tm_copy_begin \<lbrace>inv_begin0 x\<rbrace>"
    by (metis assms begin_correct)
  moreover
  have "inv_begin0 x \<mapsto> inv_loop1 x"
    unfolding assert_imp_def
    unfolding inv_begin0.simps inv_loop1.simps
    unfolding inv_loop1_loop.simps inv_loop1_exit.simps
    apply(auto simp add: numeral_eqs_upto_12 Cons_eq_append_conv)
    by (rule_tac x = "Suc 0" in exI, auto)
  ultimately have "\<lbrace>inv_begin1 x\<rbrace> tm_copy_begin \<lbrace>inv_loop1 x\<rbrace>"
    by (rule_tac Hoare_consequence) (auto)
  moreover
  have "\<lbrace>inv_loop1 x\<rbrace> tm_copy_loop \<lbrace>inv_loop0 x\<rbrace>"
    by (metis assms loop_correct)
  ultimately
  have "\<lbrace>inv_begin1 x\<rbrace> (tm_copy_begin |+| tm_copy_loop) \<lbrace>inv_loop0 x\<rbrace>"
    by (rule_tac Hoare_plus_halt) (auto)
  moreover
  have "\<lbrace>inv_end1 x\<rbrace> tm_copy_end \<lbrace>inv_end0 x\<rbrace>"
    by (metis assms end_correct)
  moreover
  have "inv_loop0 x = inv_end1 x"
    by(auto simp: inv_end1.simps inv_loop1.simps assert_imp_def)
  ultimately
  show "\<lbrace>inv_begin1 x\<rbrace> tm_copy \<lbrace>inv_end0 x\<rbrace>"
    unfolding tm_copy_def
    by (rule_tac Hoare_plus_halt) (auto)
qed

abbreviation (input)
  "pre_tm_copy n \<equiv> \<lambda>tap. tap = ([]::cell list, Oc \<up> (Suc n))"
abbreviation (input)
  "post_tm_copy n \<equiv> \<lambda>tap. tap= ([Bk], <(n, n::nat)>)"

lemma tm_copy_correct:
  shows "\<lbrace>pre_tm_copy n\<rbrace> tm_copy \<lbrace>post_tm_copy n\<rbrace>"
proof -
  have "\<lbrace>inv_begin1 (Suc n)\<rbrace> tm_copy \<lbrace>inv_end0 (Suc n)\<rbrace>"
    by (rule tm_copy_correct1) (simp)
  moreover
  have "pre_tm_copy n = inv_begin1 (Suc n)"
    by (auto)
  moreover
  have "inv_end0 (Suc n) = post_tm_copy n"
    unfolding fun_eq_iff
    by (auto simp add: inv_end0.simps tape_of_nat_def tape_of_prod_def)
  ultimately
  show "\<lbrace>pre_tm_copy n\<rbrace> tm_copy \<lbrace>post_tm_copy n\<rbrace>"
    by simp
qed

end


theory Failures_BasicOps

imports
  Failures_Core
begin

text \<open> Some operators \<close>

subsection \<open> Div \<close>

definition DivF :: "'a process" ("div\<^sub>F")
  where "div\<^sub>F = ({},{[]})"

lemma T0_Div[simp]:"T0 div\<^sub>F"
  unfolding T0_def DivF_def traces_def by auto

lemma T1_Div[simp]:"T1 div\<^sub>F"
  unfolding T1_def DivF_def traces_def by auto

lemma T2_Div[simp]:"T2 div\<^sub>F"
  unfolding T2_def DivF_def traces_def by auto

lemma F2_Div[simp]:"F2 div\<^sub>F"
  unfolding F2_def DivF_def traces_def by auto

lemma F3_Div[simp]:"F3 div\<^sub>F"
  unfolding F3_def DivF_def traces_def by auto

lemma F4_Div[simp]:"F4 div\<^sub>F"
  unfolding F4_def DivF_def traces_def by auto

lemma F5_Div[simp]:"F5 div\<^sub>F"
  unfolding F5_def DivF_def traces_def by auto

lemma F6_Div[simp]:"F6 div\<^sub>F"
  unfolding F6_def DivF_def traces_def by auto

lemma Div_top:
  assumes "T1 P"
  shows "P \<sqsubseteq> div\<^sub>F"
  using assms unfolding refines_def DivF_def T1_def traces_def by auto

subsection \<open> Unstable Skip \<close>

definition SkipUF :: "'a process" ("Skip\<^sub>U\<^sub>F")
  where "Skip\<^sub>U\<^sub>F = ({},{[],[tick]})"

subsection \<open> Stop \<close>

definition StopF :: "'a process" ("Stop\<^sub>F")
  where "Stop\<^sub>F = ({(t,X). t = [] \<and> X \<subseteq> UNIV},{[]})"

subsection \<open> Prefix \<close>

definition PrefixF :: "'a \<Rightarrow> 'a process \<Rightarrow> 'a process" (infixr "\<rightarrow>\<^sub>F" 61)
  where "PrefixF e P = ({(s,X). s = [] \<and> evt e \<notin> X} \<union> {(z,X). \<exists>s. z = [evt e]@s \<and> (s,X) \<in> (fst P)},{[]}\<union>{z. \<exists>s. z = [evt e]@s \<and> s \<in> snd P})"

subsection \<open> Internal choice \<close>

definition IntChoice :: "'a process set \<Rightarrow> 'a process" ("\<Sqinter>")
  where "IntChoice P = (\<Union>(fst`P),\<Union>(snd`P))"

definition intChoice :: "'a process \<Rightarrow> 'a process \<Rightarrow> 'a process" (infix "\<sqinter>" 60)
  where "P \<sqinter> Q = (fst P \<union> fst Q, snd P \<union> snd Q)"

lemma intInt_Choices: "P \<sqinter> Q = \<Sqinter>{P,Q}"
  unfolding intChoice_def IntChoice_def by auto

subsection \<open> External choice \<close>

definition ExtChoiceF :: "'a process \<Rightarrow> 'a process \<Rightarrow> 'a process" (infix "\<box>\<^sub>F" 57)
  where "P \<box>\<^sub>F Q = ({(s,X). s = [] \<and> (s,X) \<in> fst P \<inter> fst Q} \<union> {(s,X). (s,X) \<in> fst P \<union> fst Q \<and> s \<noteq> []},snd P \<union> snd Q)"

subsection \<open> Sequential composition \<close>

definition SeqCompF :: "'a process \<Rightarrow> 'a process \<Rightarrow> 'a process" (infix ";\<^sub>F" 57)
  where "P ;\<^sub>F Q = ({(s,X). tick \<notin> set s \<and> (s,X) \<in> fst P} \<union> {(z,X). \<exists>s t. z = s@t \<and> s@[tick] \<in> snd P \<and> (t,X) \<in> fst Q},
                   {z. tick \<notin> set z \<and> z \<in> snd P} \<union> {z. \<exists>s t. z = s@t \<and> s@[tick] \<in> snd P \<and> t \<in> snd Q})"

subsection \<open> Parallel composition \<close>

function merge_traceF :: "'a trace \<Rightarrow> 'a evt set \<Rightarrow> 'a trace \<Rightarrow> 'a trace set" (infix "\<lbrakk>_\<rbrakk>\<^sup>T\<^sub>F" 55) where
"           ([]  \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F []) = {[]}" |

"x \<in> X \<Longrightarrow>  ([] \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F (x#s)) = {}" |
"x \<notin> X \<Longrightarrow>  ([] \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F (x#s)) = {z. \<exists>u. z = x#u \<and> u \<in> [] \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F s}" | (* Case not defined well in the book *)

" ((x#s) \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F []) = [] \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F (x#s)" |

"y \<notin> X \<Longrightarrow> y' \<notin> X  \<Longrightarrow> ((y#s) \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F (y'#t)) = {z. \<exists>u. z = y#u \<and> u \<in> s \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F y'#t}\<union>{z. \<exists>u. z = y'#u \<and> u \<in> y#s \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F t}" |

"x \<in> X \<Longrightarrow> y \<notin> X  \<Longrightarrow> ((x#s) \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F (y#t)) = {z. \<exists>u. z = y#u \<and> u \<in> x#s \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F t} " |
"y \<notin> X \<Longrightarrow> x \<in> X  \<Longrightarrow> ((y#t) \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F (x#s)) = {z. \<exists>u. z = y#u \<and> u \<in> t \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F x#s}" |

"x \<in> X \<Longrightarrow> x' \<in> X \<Longrightarrow> x \<noteq> x' \<Longrightarrow> ((x#s) \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F x'#t) = {}"|
"x \<in> X \<Longrightarrow>  ((x#s) \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F (x#t)) = {z. \<exists>u. z = x#u \<and> u \<in> s \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F t} "

proof (auto, atomize_elim, simp_all)
  fix a b::"'a evt list"
  fix aa::"'a evt set"

  show "a = [] \<and> b = [] \<or>
       (\<exists>x. x \<in> aa \<and> a = [] \<and> (\<exists>s. b = x # s)) \<or>
       (\<exists>x. x \<notin> aa \<and> a = [] \<and> (\<exists>s. b = x # s)) \<or>
       (\<exists>x s. a = x # s) \<and> b = [] \<or>
       (\<exists>y X. y \<notin> X \<and> (\<exists>y'. y' \<notin> X \<and> (\<exists>s. a = y # s) \<and> aa = X \<and> (\<exists>t. b = y' # t))) \<or>
       (\<exists>x X. x \<in> X \<and> (\<exists>y. y \<notin> X \<and> (\<exists>s. a = x # s) \<and> aa = X \<and> (\<exists>t. b = y # t))) \<or>
       (\<exists>y X. y \<notin> X \<and> (\<exists>x. x \<in> X \<and> (\<exists>t. a = y # t) \<and> aa = X \<and> (\<exists>s. b = x # s))) \<or>
       (\<exists>x X. x \<in> X \<and> (\<exists>x'. x' \<in> X \<and> x \<noteq> x' \<and> (\<exists>s. a = x # s) \<and> aa = X \<and> (\<exists>t. b = x' # t))) \<or>
       (\<exists>x. x \<in> aa \<and> (\<exists>s. a = x # s) \<and> (\<exists>t. b = x # t))"
    proof (cases a)
      case a_Nil:Nil
      then show ?thesis
      proof (cases b)
        case c_Nil:Nil
        then show ?thesis using a_Nil by auto
      next
        case (Cons cx list)
        then show ?thesis using a_Nil a_Nil by auto
      qed
    next
      case (Cons ca list)
      then show ?thesis
        by (metis neq_Nil_conv)
    qed
  qed
termination by lexicographic_order

thm merge_traceF.induct (* 9 cases only! *)
thm merge_traceF.cases

lemma merge_traceF_comm:
  "(s \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F t) = (t \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F s)"
proof (induct s X t rule:merge_traceF.induct)
  case (1 X)
  then show ?case using merge_traceF.simps(4) by auto
next
  case (2 x X s)
  then show ?case using merge_traceF.simps(4) by auto
next
  case (3 x X s)
  then show ?case using merge_traceF.simps(4) by blast
next
  case (4 x s X)
  then show ?case using merge_traceF.simps(4) by blast
next
  case (5 y X y' s t)
  then have "((y#s) \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F (y'#t)) = {y # u |u. u \<in> s \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F y'#t} \<union> {y' # u |u. u \<in> y#s \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F t}"
    using merge_traceF.simps(5) by blast

  then show ?case
    apply auto
      apply (smt "5.hyps"(1) "5.hyps"(2) "5.hyps"(3) UnCI append_Cons append_self_conv2 mem_Collect_eq merge_traceF.simps(5))
    apply (simp add: "5.hyps"(1) "5.hyps"(2) "5.hyps"(4))
    using "5.hyps"(1) "5.hyps"(2) "5.hyps"(3) "5.hyps"(4) by auto
next
  case (6 x X y s t)
  then have "x # s \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F y # t = {z. \<exists>u. z = y#u \<and> u \<in> x#s \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F t}"
    by auto
  then show ?case
    apply auto
    by (simp add: "6.hyps"(1) "6.hyps"(2) "6.hyps"(3))+
next
  case (7 y X x t s)
  then show ?case
    apply (cases t)
    using merge_traceF.simps(6) merge_traceF.simps(7) by fastforce+
next
  case (8 x X x' s t)
  then show ?case using merge_traceF.simps(8) by blast
next
  case (9 x X s t)
  then show ?case by auto
qed

text \<open> Note that the following definition of parallel composition differs slightly from the
       book, as 'tick' needs to be synchronised necessarily, when using the trace merge function. \<close>

definition ParCompF :: "'a process \<Rightarrow> ('a set) \<Rightarrow> 'a process \<Rightarrow> 'a process" (infix "\<lbrakk>_\<rbrakk>\<^sub>F" 55)
  where "(P \<lbrakk>X\<rbrakk>\<^sub>F Q) = ({(u,F). \<exists>Y Z. F = Y \<union> Z \<and> Y-(evt`X\<union>{tick}) = Z-(evt`X\<union>{tick})
                        \<and> (\<exists>s t. (s,Y) \<in> fst P \<and> (t,Z) \<in> fst Q \<and> u \<in> s \<lbrakk>evt`X\<union>{tick}\<rbrakk>\<^sup>T\<^sub>F t)}
                      \<union> {(u,F). \<exists>s t A G. A \<subseteq> X \<and> F = G \<union> evt ` A \<and> u \<in> (s \<lbrakk>evt`X\<union>{tick}\<rbrakk>\<^sup>T\<^sub>F t) \<and> (s@[tick]) \<in> snd P \<and> (t,G) \<in> fst Q}
                      \<union> {(u,F). \<exists>s t A G. A \<subseteq> X \<and> F = G \<union> evt ` A \<and> u \<in> (s \<lbrakk>evt`X\<union>{tick}\<rbrakk>\<^sup>T\<^sub>F t) \<and> (t@[tick]) \<in> snd Q \<and> (s,G) \<in> fst P},
                      (\<Union>{z. \<exists>s t. z = (s \<lbrakk>evt`X\<union>{tick}\<rbrakk>\<^sup>T\<^sub>F t) \<and> s \<in> snd P \<and> t \<in> snd Q}))"

lemma merge_traceF_empty:
  "([] \<lbrakk>{e}\<rbrakk>\<^sup>T\<^sub>F xs @ [e]) = {}"
  apply (induct xs, auto)
  by (smt insert_Diff insert_not_empty mem_Collect_eq merge_traceF.simps(2) merge_traceF.simps(3))

lemma merge_traceF_singleton:
  assumes "set xs \<inter> X = {}"
  shows "([] \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F xs) = {xs}"
  using assms by (induct xs, auto)

lemma merge_traceF_Nil_prefix:
  assumes "x \<in> ([] \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F t)"
  shows "prefix x t"
  using assms apply (induct x t rule:list_induct2', auto)
  by (smt empty_iff list.inject mem_Collect_eq merge_traceF.simps(2) merge_traceF.simps(3))+

lemma merge_traceF_singleton_prefix:
  assumes "x \<in> ([y] \<lbrakk>X\<rbrakk>\<^sup>T\<^sub>F t)" "y \<in> X"
  shows "prefix x t"
  using assms apply (induct x t rule:list_induct2', auto)
   apply (smt empty_iff list.inject mem_Collect_eq merge_traceF.simps(6) merge_traceF.simps(8) merge_traceF.simps(9))
  by (smt equals0D list.inject mem_Collect_eq merge_traceF.simps(7) merge_traceF.simps(8) merge_traceF.simps(9) merge_traceF_Nil_prefix merge_traceF_comm)

lemma mergeF_tick_last_tick:
  assumes "Tick_last t" "last t = tick" "t \<noteq> []"
  shows "([tick] \<lbrakk>{tick}\<rbrakk>\<^sup>T\<^sub>F t) = {t}"
  using assms apply (induct t rule:Tick_last.induct, auto)
  by (metis empty_iff evt.distinct(1) insert_iff)+

lemma Tick_last_not_last_tick:
  assumes "Tick_last t" "last t \<noteq> tick"
  shows "tick \<notin> set t"
  using assms apply (induct t rule:Tick_last.induct, auto)
  by (metis empty_iff empty_set)

lemma mergeF_Tick_last_not_last_tick:
  assumes "Tick_last t" "last t \<noteq> tick"
  shows "([] \<lbrakk>{tick}\<rbrakk>\<^sup>T\<^sub>F t) = {t}"
  using assms
  by (simp add: Tick_last_not_last_tick merge_traceF_singleton)

lemma mergeF_tick_no_tick:
  assumes "tick \<notin> set t"
  shows "([tick] \<lbrakk>{tick}\<rbrakk>\<^sup>T\<^sub>F t) = {}"
  using assms apply (induct t, simp_all)
  by auto

lemma SkipUF_traces_parallel_eq:
  assumes "T1 P" "T0 P"
  shows "(\<Union> {s \<lbrakk>{tick}\<rbrakk>\<^sup>T\<^sub>F t |s t. (s = [] \<or> s = [tick]) \<and> t \<in> snd P}) = snd P"
proof (auto)
  fix x t
  assume "x \<in> [] \<lbrakk>{tick}\<rbrakk>\<^sup>T\<^sub>F t" "t \<in> snd P"
  then show "x \<in> snd P"
    using assms merge_traceF_Nil_prefix T1_def traces_def by blast
next
  fix x t
  assume "x \<in> [tick] \<lbrakk>{tick}\<rbrakk>\<^sup>T\<^sub>F t" "t \<in> snd P"
  then show "x \<in> snd P"
    using assms merge_traceF_singleton_prefix T1_def traces_def by blast
next
  fix x
  assume assm1: "x \<in> snd P"
  have "Tick_last x"
    using assm1 assms T0_def traces_def by blast
  then show "\<exists>xa. (\<exists>s t. xa = s \<lbrakk>{tick}\<rbrakk>\<^sup>T\<^sub>F t \<and> (s = [] \<or> s = [tick]) \<and> t \<in> snd P) \<and> x \<in> xa"
  proof (cases x)
    case Nil
    then show ?thesis
      apply (rule_tac x="{[]}" in exI, auto)
      apply (rule_tac x="[]" in exI, auto)
      apply (rule_tac x="[]" in exI, auto)
      using assms T1_def assm1 by blast
  next
    case (Cons a list)
    then show ?thesis
    proof (cases "last (a#list) = tick")
      case True
      then show ?thesis using Cons assm1 True \<open>Tick_last x\<close> mergeF_tick_last_tick by blast
    next
      case False
      then show ?thesis using Cons assm1 False mergeF_Tick_last_not_last_tick
        using \<open>Tick_last x\<close> by blast
    qed
  qed
qed

lemma SkipUF_failures_parallel_eq:
  assumes "T1 P" "T0 P" "T2 P" "F6 P"
  shows "{(u, F). \<exists>t. u \<in> ([] \<lbrakk>{tick}\<rbrakk>\<^sup>T\<^sub>F t) \<and> (t, F) \<in> fst P} = fst P"
proof (auto)
  fix a b t
  assume assm1:"a \<in> [] \<lbrakk>{tick}\<rbrakk>\<^sup>T\<^sub>F t"
    and  assm2:"(t, b) \<in> fst P"

  have "Tick_last t"
    using assm1 assms T0_def traces_def T2_def assm2 by blast

  show "(a, b) \<in> fst P"
  proof (cases "tick \<in> set t")
    case True
    then show ?thesis
      by (metis Tick_last_not_last_tick \<open>Tick_last t\<close> append_butlast_last_id assm1 equals0D merge_traceF_empty set_empty)
  next
    case False
    then show ?thesis
      by (metis \<open>Tick_last t\<close> assm1 assm2 empty_iff insert_iff last_in_set mergeF_Tick_last_not_last_tick merge_traceF.simps(1))
  qed
next
  fix a b
  assume assm1:"(a, b) \<in> fst P"

  have "Tick_last a"
    using assm1 assms T0_def traces_def T2_def assms by blast

  have "tick \<notin> set a"
    by (metis F6_def Tick_last_not_last_tick \<open>Tick_last a\<close> append_butlast_last_id assm1 assms(4) empty_iff set_empty)

  then show "\<exists>t. a \<in> [] \<lbrakk>{tick}\<rbrakk>\<^sup>T\<^sub>F t \<and> (t, b) \<in> fst P"
    using assm1
    by (metis \<open>Tick_last a\<close> insertI1 last_in_set mergeF_Tick_last_not_last_tick merge_traceF.simps(1))
qed

text \<open> Below we show that SkipUF is a unit for interleaving. This is important, as the definition of
       the failures semantics of ParCompF contains two additional sets in a union, that handle
       the termination of SkipUF so as to allow failures of P to be propagated. \<close>

lemma SkipUF_ParCompF_unit:
  assumes "T1 P" "T0 P" "T2 P" "F6 P"
  shows ParCompF_Skip: "(Skip\<^sub>U\<^sub>F \<lbrakk>{}\<rbrakk>\<^sub>F P) = P"
  using assms unfolding ParCompF_def SkipUF_def apply auto
  using SkipUF_traces_parallel_eq SkipUF_failures_parallel_eq
  by (simp add: SkipUF_failures_parallel_eq SkipUF_traces_parallel_eq)

lemma ParCompF_comm: "(P \<lbrakk>X\<rbrakk>\<^sub>F Q) = Q \<lbrakk>X\<rbrakk>\<^sub>F P"
  unfolding ParCompF_def apply safe
     apply (metis Un_commute merge_traceF_comm)
      apply (metis Un_commute merge_traceF_comm)
  using merge_traceF_comm apply fastforce
  apply (metis Un_commute merge_traceF_comm)
using merge_traceF_comm by fastforce+

lemma ParCompF_assoc: "(P \<lbrakk>X\<rbrakk>\<^sub>F (Q \<lbrakk>X\<rbrakk>\<^sub>F R)) = (P \<lbrakk>X\<rbrakk>\<^sub>F Q) \<lbrakk>X\<rbrakk>\<^sub>F R"
  unfolding ParCompF_def apply safe
  oops (* FIXME: Proof probably requires healthiness conditions. *)

lemma ParCompF_dist: "(P \<lbrakk>X\<rbrakk>\<^sub>F (Q \<sqinter> R)) = (P \<lbrakk>X\<rbrakk>\<^sub>F Q) \<sqinter> (P \<lbrakk>X\<rbrakk>\<^sub>F R)"
  unfolding ParCompF_def intChoice_def apply auto
  apply fastforce
  apply fastforce
  by blast

subsection \<open> Interrupt \<close>

text \<open> Notice the predicate tick \<notin> set z, which is missing from the definition in the book. \<close>

definition InterruptF :: "'a process \<Rightarrow> 'a process \<Rightarrow> 'a process" (infix "\<triangle>\<^sub>F" 57)
  where "P \<triangle>\<^sub>F Q = ({(s,X). (s,X) \<in> fst P \<and> ([],X) \<in> fst Q}
                 \<union> {(z,X). \<exists>s t. z = s@t \<and> s \<in> snd P \<and> (t,X) \<in> fst Q \<and> t \<noteq> [] \<and> tick \<notin> set s},
                   snd P \<union> {z. \<exists>s t. z = s@t \<and> s \<in> snd P \<and> t \<in> snd Q})"

subsection \<open> Renaming \<close>

term List.map
term evt.map_evt

definition RenamingF :: "'a process \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b process" ("_\<lbrakk>_\<rbrakk>\<^sub>F" 57)
  where "P\<lbrakk>R\<rbrakk>\<^sub>F = ({(s',X). \<exists>s. map (evt.map_evt R) s = s' \<and> (s,((evt.map_evt R)) -` X) \<in> fst P},
                 {s'. \<exists>s. map (evt.map_evt R) s = s' \<and> s \<in> snd P})"

subsection \<open> Hiding \<close>

text \<open> To allow a fair comparison with tick-tock, I've allowed the event set to also include
       tick. Although clearly this is impossible in FDR, removing termination via hiding. \<close>

definition HideF :: "'a process \<Rightarrow> 'a evt set \<Rightarrow> 'a process" (infix "\<setminus>\<^sub>F" 57)
  where "P \<setminus>\<^sub>F X = ({(t,Y). \<exists>s. (s,Y \<union> X) \<in> fst P  \<and> t = filter (\<lambda>e. e \<notin> X) s},
                    {t. \<exists>z. t = filter (\<lambda>e. e \<notin> X) z \<and> z \<in> snd P})"

end


section \<open>Lift monad\<close>

theory Lift_Monad
imports Monad
begin

subsection \<open>Type definition\<close>

tycondef 'a\<cdot>lifted = Lifted (lazy "'a")

lemma coerce_lifted_abs [simp]: "coerce\<cdot>(lifted_abs\<cdot>x) = lifted_abs\<cdot>(coerce\<cdot>x)"
apply (simp add: lifted_abs_def coerce_def)
apply (simp add: emb_prj_emb prj_emb_prj DEFL_eq_lifted)
done

lemma coerce_Lifted [simp]: "coerce\<cdot>(Lifted\<cdot>x) = Lifted\<cdot>(coerce\<cdot>x)"
unfolding Lifted_def by simp

lemma fmapU_lifted_simps [simp]:
  "fmapU\<cdot>f\<cdot>(\<bottom>::udom\<cdot>lifted) = \<bottom>"
  "fmapU\<cdot>f\<cdot>(Lifted\<cdot>x) = Lifted\<cdot>(f\<cdot>x)"
unfolding fmapU_lifted_def lifted_map_def fix_const
apply simp
apply (simp add: Lifted_def)
done

subsection \<open>Class instance proofs\<close>

instance lifted :: "functor"
  by standard (induct_tac xs rule: lifted.induct, simp_all)

instantiation lifted :: monad
begin

fixrec bindU_lifted :: "udom\<cdot>lifted \<rightarrow> (udom \<rightarrow> udom\<cdot>lifted) \<rightarrow> udom\<cdot>lifted"
  where "bindU_lifted\<cdot>(Lifted\<cdot>x)\<cdot>k = k\<cdot>x"

lemma bindU_lifted_strict [simp]: "bindU\<cdot>\<bottom>\<cdot>k = (\<bottom>::udom\<cdot>lifted)"
by fixrec_simp

definition returnU_lifted_def:
  "returnU = Lifted"

instance proof
  fix x :: "udom"
  fix f :: "udom \<rightarrow> udom"
  fix h k :: "udom \<rightarrow> udom\<cdot>lifted"
  fix xs :: "udom\<cdot>lifted"
  show "fmapU\<cdot>f\<cdot>xs = bindU\<cdot>xs\<cdot>(\<Lambda> x. returnU\<cdot>(f\<cdot>x))"
    by (induct xs rule: lifted.induct, simp_all add: returnU_lifted_def)
  show "bindU\<cdot>(returnU\<cdot>x)\<cdot>k = k\<cdot>x"
    by (simp add: returnU_lifted_def)
  show "bindU\<cdot>(bindU\<cdot>xs\<cdot>h)\<cdot>k = bindU\<cdot>xs\<cdot>(\<Lambda> x. bindU\<cdot>(h\<cdot>x)\<cdot>k)"
    by (induct xs rule: lifted.induct) simp_all
qed

end

subsection \<open>Transfer properties to polymorphic versions\<close>

lemma fmap_lifted_simps [simp]:
  "fmap\<cdot>f\<cdot>(\<bottom>::'a\<cdot>lifted) = \<bottom>"
  "fmap\<cdot>f\<cdot>(Lifted\<cdot>x) = Lifted\<cdot>(f\<cdot>x)"
unfolding fmap_def by simp_all

lemma bind_lifted_simps [simp]:
  "bind\<cdot>(\<bottom>::'a\<cdot>lifted)\<cdot>f = \<bottom>"
  "bind\<cdot>(Lifted\<cdot>x)\<cdot>f = f\<cdot>x"
unfolding bind_def by simp_all

lemma return_lifted_def: "return = Lifted"
unfolding return_def returnU_lifted_def
by (simp add: coerce_cfun cfcomp1 eta_cfun)

lemma join_lifted_simps [simp]:
  "join\<cdot>(\<bottom>::'a\<cdot>lifted\<cdot>lifted) = \<bottom>"
  "join\<cdot>(Lifted\<cdot>xs) = xs"
unfolding join_def by simp_all

end


section "Small-Step Semantics of Commands"

theory Small_Step imports Star Big_Step begin

subsection "The transition relation"

inductive
  small_step :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "(x ::= a, s) \<rightarrow> (SKIP, s(x := aval a s))" |

Seq1:    "(SKIP;;c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |
Seq2:    "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "\<not>bval b s \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow>
            (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

abbreviation
  small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

subsection\<open>Executability\<close>

code_pred small_step .

values "{(c',map t [''x'',''y'',''z'']) |c' t.
   (''x'' ::= V ''z'';; ''y'' ::= V ''x'',
    <''x'' := 3, ''y'' := 7, ''z'' := 5>) \<rightarrow>* (c',t)}"

subsection\<open>Proof infrastructure\<close>

subsubsection\<open>Induction rules\<close>

text\<open>The default induction rule @{thm[source] small_step.induct} only works
for lemmas of the form \<open>a \<rightarrow> b \<Longrightarrow> \<dots>\<close> where \<open>a\<close> and \<open>b\<close> are
not already pairs \<open>(DUMMY,DUMMY)\<close>. We can generate a suitable variant
of @{thm[source] small_step.induct} for pairs by ``splitting'' the arguments
\<open>\<rightarrow>\<close> into pairs:\<close>
lemmas small_step_induct = small_step.induct[split_format(complete)]

subsubsection\<open>Proof automation\<close>

declare small_step.intros[simp,intro]

text\<open>Rule inversion:\<close>

inductive_cases SkipE[elim!]: "(SKIP,s) \<rightarrow> ct"
thm SkipE
inductive_cases AssignE[elim!]: "(x::=a,s) \<rightarrow> ct"
thm AssignE
inductive_cases SeqE[elim]: "(c1;;c2,s) \<rightarrow> ct"
thm SeqE
inductive_cases IfE[elim!]: "(IF b THEN c1 ELSE c2,s) \<rightarrow> ct"
inductive_cases WhileE[elim]: "(WHILE b DO c, s) \<rightarrow> ct"

text\<open>A simple property:\<close>
lemma deterministic:
  "cs \<rightarrow> cs' \<Longrightarrow> cs \<rightarrow> cs'' \<Longrightarrow> cs'' = cs'"
apply(induction arbitrary: cs'' rule: small_step.induct)
apply blast+
done

subsection "Equivalence with big-step semantics"

lemma star_seq2: "(c1,s) \<rightarrow>* (c1',s') \<Longrightarrow> (c1;;c2,s) \<rightarrow>* (c1';;c2,s')"
proof(induction rule: star_induct)
  case refl thus ?case by simp
next
  case step
  thus ?case by (metis Seq2 star.step)
qed

lemma seq_comp:
  "\<lbrakk> (c1,s1) \<rightarrow>* (SKIP,s2); (c2,s2) \<rightarrow>* (SKIP,s3) \<rbrakk>
   \<Longrightarrow> (c1;;c2, s1) \<rightarrow>* (SKIP,s3)"
by(blast intro: star.step star_seq2 star_trans)

text\<open>The following proof corresponds to one on the board where one would
show chains of \<open>\<rightarrow>\<close> and \<open>\<rightarrow>*\<close> steps.\<close>

lemma big_to_small:
  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  fix s show "(SKIP,s) \<rightarrow>* (SKIP,s)" by simp
next
  fix x a s show "(x ::= a,s) \<rightarrow>* (SKIP, s(x := aval a s))" by auto
next
  fix c1 c2 s1 s2 s3
  assume "(c1,s1) \<rightarrow>* (SKIP,s2)" and "(c2,s2) \<rightarrow>* (SKIP,s3)"
  thus "(c1;;c2, s1) \<rightarrow>* (SKIP,s3)" by (rule seq_comp)
next
  fix s::state and b c0 c1 t
  assume "bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c0,s)" by simp
  moreover assume "(c0,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix s::state and b c0 c1 t
  assume "\<not>bval b s"
  hence "(IF b THEN c0 ELSE c1,s) \<rightarrow> (c1,s)" by simp
  moreover assume "(c1,s) \<rightarrow>* (SKIP,t)"
  ultimately
  show "(IF b THEN c0 ELSE c1,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
next
  fix b c and s::state
  assume b: "\<not>bval b s"
  let ?if = "IF b THEN c;; WHILE b DO c ELSE SKIP"
  have "(WHILE b DO c,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if,s) \<rightarrow> (SKIP, s)" by (simp add: b)
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,s)" by(metis star.refl star.step)
next
  fix b c s s' t
  let ?w  = "WHILE b DO c"
  let ?if = "IF b THEN c;; ?w ELSE SKIP"
  assume w: "(?w,s') \<rightarrow>* (SKIP,t)"
  assume c: "(c,s) \<rightarrow>* (SKIP,s')"
  assume b: "bval b s"
  have "(?w,s) \<rightarrow> (?if, s)" by blast
  moreover have "(?if, s) \<rightarrow> (c;; ?w, s)" by (simp add: b)
  moreover have "(c;; ?w,s) \<rightarrow>* (SKIP,t)" by(rule seq_comp[OF c w])
  ultimately show "(WHILE b DO c,s) \<rightarrow>* (SKIP,t)" by (metis star.simps)
qed

text\<open>Each case of the induction can be proved automatically:\<close>
lemma  "cs \<Rightarrow> t \<Longrightarrow> cs \<rightarrow>* (SKIP,t)"
proof (induction rule: big_step.induct)
  case Skip show ?case by blast
next
  case Assign show ?case by blast
next
  case Seq thus ?case by (blast intro: seq_comp)
next
  case IfTrue thus ?case by (blast intro: star.step)
next
  case IfFalse thus ?case by (blast intro: star.step)
next
  case WhileFalse thus ?case
    by (metis star.step star_step1 small_step.IfFalse small_step.While)
next
  case WhileTrue
  thus ?case
    by(metis While seq_comp small_step.IfTrue star.step[of small_step])
qed

lemma small1_big_continue:
  "cs \<rightarrow> cs' \<Longrightarrow> cs' \<Rightarrow> t \<Longrightarrow> cs \<Rightarrow> t"
apply (induction arbitrary: t rule: small_step.induct)
apply auto
done

lemma small_to_big:
  "cs \<rightarrow>* (SKIP,t) \<Longrightarrow> cs \<Rightarrow> t"
apply (induction cs "(SKIP,t)" rule: star.induct)
apply (auto intro: small1_big_continue)
done

text \<open>
  Finally, the equivalence theorem:
\<close>
theorem big_iff_small:
  "cs \<Rightarrow> t = cs \<rightarrow>* (SKIP,t)"
by(metis big_to_small small_to_big)

subsection "Final configurations and infinite reductions"

definition "final cs \<longleftrightarrow> \<not>(\<exists>cs'. cs \<rightarrow> cs')"

lemma finalD: "final (c,s) \<Longrightarrow> c = SKIP"
apply(simp add: final_def)
apply(induction c)
apply blast+
done

lemma final_iff_SKIP: "final (c,s) = (c = SKIP)"
by (metis SkipE finalD final_def)

text\<open>Now we can show that \<open>\<Rightarrow>\<close> yields a final state iff \<open>\<rightarrow>\<close>
terminates:\<close>

lemma big_iff_small_termination:
  "(\<exists>t. cs \<Rightarrow> t) \<longleftrightarrow> (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"
by(simp add: big_iff_small final_iff_SKIP)

text\<open>This is the same as saying that the absence of a big step result is
equivalent with absence of a terminating small step sequence, i.e.\ with
nontermination.  Since \<open>\<rightarrow>\<close> is determininistic, there is no difference
between may and must terminate.\<close>

end