(* Title: thys/Abacus_Mopup.thy
   Author: Jian Xu, Xingyuan Zhang, and Christian Urban
   Modifications: Sebastiaan Joosten
   Modifications: Franz Regensburger (FABR) 08/2022
     additional comments an re-structuring of section hierarchy
 *)

chapter \<open>Abacus Programs\<close>

text \<open>Abacus Machines (aka Counter Machines) and their programs
 are discussed in \<^cite>\<open>"Boolos07"\<close>.
They serve as an intermediate computation model in the course of
the translation of Recursive Functions into Turing Machines.
\<close>

section \<open>A Mopup Turing Machine that deletes all "registers" on the tape, except one\<close>

text \<open>In this section we define the higher order function mopup\_n\_tm that generates
a mopup Turing Machine for every argument n. The generated mopup function deletes all
numerals from the right tape except the n-th one. Such mopup machines will be used
in order to tidy up the result computed by Turing Machines that were compiled from Abacus programs.
Refer to  \<^cite>\<open>"Boolos07"\<close> for more details.
\<close>

theory Abacus_Mopup
  imports
    Turing_Hoare
begin

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

declare adjust.simps[simp del]

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

(* Temporary removal *)
declare replicate_Suc[simp del]

fun mopup_a :: "nat \<Rightarrow> instr list"
  where
    "mopup_a 0 = []" |
    "mopup_a (Suc n) = mopup_a n @
       [(R, 2*n + 3), (WB, 2*n + 2), (R, 2*n + 1), (WO, 2*n + 2)]"

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

fun mopup_n_tm :: "nat \<Rightarrow> instr list"
  where
    "mopup_n_tm n = mopup_a n @ shift mopup_b (2*n)"

type_synonym mopup_type = "config \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> cell list \<Rightarrow> bool"

fun mopup_stop :: "mopup_type"
  where
    "mopup_stop (s, l, r) lm n ires=
        (\<exists> ln rn. l = Bk\<up>ln @ Bk # Bk # ires \<and> r = <lm ! n> @ Bk\<up>rn)"

fun mopup_bef_erase_a :: "mopup_type"
  where
    "mopup_bef_erase_a (s, l, r) lm n ires=
         (\<exists> ln m rn. l = Bk\<up>ln @ Bk # Bk # ires \<and>
                  r = Oc\<up>m@ Bk # <(drop ((s + 1) div 2) lm)> @ Bk\<up>rn)"

fun mopup_bef_erase_b :: "mopup_type"
  where
    "mopup_bef_erase_b (s, l, r) lm n ires =
      (\<exists> ln m rn. l = Bk\<up>ln @ Bk # Bk # ires \<and> r = Bk # Oc\<up>m @ Bk #
                                      <(drop (s div 2) lm)> @ Bk\<up>rn)"

fun mopup_jump_over1 :: "mopup_type"
  where
    "mopup_jump_over1 (s, l, r) lm n ires =
      (\<exists> ln m1 m2 rn. m1 + m2 = Suc (lm ! n) \<and>
        l = Oc\<up>m1 @ Bk\<up>ln @ Bk # Bk # ires \<and>
     (r = Oc\<up>m2 @ Bk # <(drop (Suc n) lm)> @ Bk\<up>rn \<or>
     (r = Oc\<up>m2 \<and> (drop (Suc n) lm) = [])))"

fun mopup_aft_erase_a :: "mopup_type"
  where
    "mopup_aft_erase_a (s, l, r) lm n ires =
      (\<exists> lnl lnr rn (ml::nat list) m.
          m = Suc (lm ! n) \<and> l = Bk\<up>lnr @ Oc\<up>m @ Bk\<up>lnl @ Bk # Bk # ires \<and>
                                   (r = <ml> @ Bk\<up>rn))"

fun mopup_aft_erase_b :: "mopup_type"
  where
    "mopup_aft_erase_b (s, l, r) lm n ires=
   (\<exists> lnl lnr rn (ml::nat list) m.
      m = Suc (lm ! n) \<and>
      l = Bk\<up>lnr @ Oc\<up>m @ Bk\<up>lnl @ Bk # Bk # ires \<and>
     (r = Bk # <ml> @ Bk\<up>rn \<or>
      r = Bk # Bk # <ml> @ Bk\<up>rn))"

fun mopup_aft_erase_c :: "mopup_type"
  where
    "mopup_aft_erase_c (s, l, r) lm n ires =
 (\<exists> lnl lnr rn (ml::nat list) m.
     m = Suc (lm ! n) \<and>
     l = Bk\<up>lnr @ Oc\<up>m @ Bk\<up>lnl @ Bk # Bk # ires \<and>
    (r = <ml> @ Bk\<up>rn \<or> r = Bk # <ml> @ Bk\<up>rn))"

fun mopup_left_moving :: "mopup_type"
  where
    "mopup_left_moving (s, l, r) lm n ires =
  (\<exists> lnl lnr rn m.
     m = Suc (lm ! n) \<and>
   ((l = Bk\<up>lnr @ Oc\<up>m @ Bk\<up>lnl @ Bk # Bk # ires \<and> r = Bk\<up>rn) \<or>
    (l = Oc\<up>(m - 1) @ Bk\<up>lnl @ Bk # Bk # ires \<and> r = Oc # Bk\<up>rn)))"

fun mopup_jump_over2 :: "mopup_type"
  where
    "mopup_jump_over2 (s, l, r) lm n ires =
     (\<exists> ln rn m1 m2.
          m1 + m2 = Suc (lm ! n)
        \<and> r \<noteq> []
        \<and> (hd r = Oc \<longrightarrow> (l = Oc\<up>m1 @ Bk\<up>ln @ Bk # Bk # ires \<and> r = Oc\<up>m2 @ Bk\<up>rn))
        \<and> (hd r = Bk \<longrightarrow> (l = Bk\<up>ln @ Bk # ires \<and> r = Bk # Oc\<up>(m1+m2)@ Bk\<up>rn)))"

fun mopup_inv :: "mopup_type"
  where
    "mopup_inv (s, l, r) lm n ires =
      (if s = 0 then mopup_stop (s, l, r) lm n ires
       else if s \<le> 2*n then
               if s mod 2 = 1 then mopup_bef_erase_a (s, l, r) lm n ires
                   else mopup_bef_erase_b (s, l, r) lm n ires
            else if s = 2*n + 1 then
                mopup_jump_over1 (s, l, r) lm n ires
            else if s = 2*n + 2 then mopup_aft_erase_a (s, l, r) lm n ires
            else if s = 2*n + 3 then mopup_aft_erase_b (s, l, r) lm n ires
            else if s = 2*n + 4 then mopup_aft_erase_c (s, l, r) lm n ires
            else if s = 2*n + 5 then mopup_left_moving (s, l, r) lm n ires
            else if s = 2*n + 6 then mopup_jump_over2 (s, l, r) lm n ires
            else False)"

lemma mop_bef_length[simp]: "length (mopup_a n) = 4 * n"
  by(induct n, simp_all)

lemma mopup_a_nth:
  "\<lbrakk>q < n; x < 4\<rbrakk> \<Longrightarrow> mopup_a n ! (4 * q + x) =
                             mopup_a (Suc q) ! ((4 * q) + x)"
proof(induct n)
  case (Suc n)
  then show ?case
    by(cases "q < n";cases "q = n", auto simp add: nth_append)
qed auto

lemma fetch_bef_erase_a_b[simp]:
  "\<lbrakk>0 < s; s \<le> 2 * n; s mod 2 = Suc 0\<rbrakk>
   \<Longrightarrow>  (fetch (mopup_a n @ shift mopup_b (2 * n)) s Bk) = (R, s + 2)"
  apply(subgoal_tac "\<exists> q. s = 2*q + 1", auto)
   apply(subgoal_tac "length (mopup_a n) = 4*n")
    apply(auto simp: nth_append)
   apply(subgoal_tac "mopup_a n ! (4 * q + 0) =
                       mopup_a (Suc q) ! ((4 * q + 0))",
      simp add: nth_append)
   apply(rule mopup_a_nth, auto)
  apply arith
  done

lemma fetch_bef_erase_b_b:
  assumes "n < length lm" "0 < s" "s \<le> 2 * n" "s mod 2 = 0"
  shows "(fetch (mopup_a n @ shift mopup_b (2 * n)) s Bk) = (R, s - 1)"
proof -
  from assms obtain q where q:"s = 2 * q" by auto
  then obtain nat where nat:"q = Suc nat" using assms(2) by (cases q, auto)
  from assms(3) mopup_a_nth[of nat n 2]
  have "mopup_a n ! (4 * nat + 2) = mopup_a (Suc nat) ! ((4 * nat) + 2)"
    unfolding nat q by auto
  thus ?thesis using assms nat q by (auto simp: nth_append)
qed

lemma fetch_jump_over1_o:
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (2 * n)) Oc
  = (R, Suc (2 * n))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_jump_over1_b:
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (2 * n)) Bk
 = (R, Suc (Suc (2 * n)))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_aft_erase_a_o:
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (Suc (2 * n))) Oc
 = (WB, Suc (2 * n + 2))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_aft_erase_a_b:
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (Suc (Suc (2 * n))) Bk
  = (L, Suc (2 * n + 4))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_aft_erase_b_b:
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (2*n + 3) Bk
  = (R, Suc (2 * n + 3))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 3 = Suc (2*n + 2)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_aft_erase_c_o:
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 4) Oc
 = (WB, Suc (2 * n + 2))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 4 = Suc (2*n + 3)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_aft_erase_c_b:
  "fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 4) Bk
 = (R, Suc (2 * n + 1))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 4 = Suc (2*n + 3)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_left_moving_o:
  "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 5) Oc)
 = (L, 2*n + 6)"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 5 = Suc (2*n + 4)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_left_moving_b:
  "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 5) Bk)
  = (L, 2*n + 5)"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 5 = Suc (2*n + 4)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_jump_over2_b:
  "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 6) Bk)
 = (R, 0)"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 6 = Suc (2*n + 5)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemma fetch_jump_over2_o:
  "(fetch (mopup_a n @ shift mopup_b (2 * n)) (2 * n + 6) Oc)
 = (L, 2*n + 6)"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(subgoal_tac "2*n + 6 = Suc (2*n + 5)", simp only: fetch.simps)
    apply(auto simp: mopup_b_def nth_append shift.simps)
  done

lemmas mopupfetchs =
  fetch_bef_erase_a_o fetch_bef_erase_a_b fetch_bef_erase_b_b
  fetch_jump_over1_o fetch_jump_over1_b fetch_aft_erase_a_o
  fetch_aft_erase_a_b fetch_aft_erase_b_b fetch_aft_erase_c_o
  fetch_aft_erase_c_b fetch_left_moving_o fetch_left_moving_b
  fetch_jump_over2_b fetch_jump_over2_o

declare
  mopup_jump_over2.simps[simp del] mopup_left_moving.simps[simp del]
  mopup_aft_erase_c.simps[simp del] mopup_aft_erase_b.simps[simp del]
  mopup_aft_erase_a.simps[simp del] mopup_jump_over1.simps[simp del]
  mopup_bef_erase_a.simps[simp del] mopup_bef_erase_b.simps[simp del]
  mopup_stop.simps[simp del]

lemma mopup_bef_erase_b_Bk_via_a_Oc[simp]:
  "\<lbrakk>mopup_bef_erase_a (s, l, Oc # xs) lm n ires\<rbrakk> \<Longrightarrow>
  mopup_bef_erase_b (Suc s, l, Bk # xs) lm n ires"
  apply(auto simp: mopup_bef_erase_a.simps mopup_bef_erase_b.simps)
  by (metis cell.distinct(1) hd_append list.sel(1) list.sel(3) tl_append2 tl_replicate)

lemma mopup_false1:
  "\<lbrakk>0 < s; s \<le> 2 * n; s mod 2 = Suc 0;  \<not> Suc s \<le> 2 * n\<rbrakk>
  \<Longrightarrow> RR"
  apply(arith)
  done

lemma mopup_bef_erase_a_implies_two[simp]:
  "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n; s mod 2 = Suc 0;
   mopup_bef_erase_a (s, l, Oc # xs) lm n ires; r = Oc # xs\<rbrakk>
 \<Longrightarrow> (Suc s \<le> 2 * n \<longrightarrow> mopup_bef_erase_b (Suc s, l, Bk # xs) lm n ires)  \<and>
     (\<not> Suc s \<le> 2 * n \<longrightarrow> mopup_jump_over1 (Suc s, l, Bk # xs) lm n ires) "
  apply(auto elim!: mopup_false1)
  done

lemma tape_of_nl_cons: "<m # lm> = (if lm = [] then Oc\<up>(Suc m)
                    else Oc\<up>(Suc m) @ Bk # <lm>)"
  by(cases lm, simp_all add: tape_of_list_def  tape_of_nat_def split: if_splits)

lemma drop_tape_of_cons:
  "\<lbrakk>Suc q < length lm; x = lm ! q\<rbrakk> \<Longrightarrow> <drop q lm> = Oc # Oc \<up> x @ Bk # <drop (Suc q) lm>"
  using Suc_lessD append_Cons list.simps(2) Cons_nth_drop_Suc replicate_Suc tape_of_nl_cons
  by metis

lemma erase2jumpover1:
  "\<lbrakk>q < length list;
             \<forall>rn. <drop q list> \<noteq> Oc # Oc \<up> (list ! q) @ Bk # <drop (Suc q) list> @ Bk \<up> rn\<rbrakk>
       \<Longrightarrow> <drop q list> = Oc # Oc \<up> (list ! q)"
  apply(erule_tac x = 0 in allE, simp)
  apply(cases "Suc q < length list")
   apply(erule_tac notE)
   apply(rule_tac drop_tape_of_cons, simp_all)
  apply(subgoal_tac "length list = Suc q", auto)
  apply(subgoal_tac "drop q list = [list ! q]")
   apply(simp add: tape_of_nat_def tape_of_list_def replicate_Suc)
  by (metis append_Nil2 append_eq_conv_conj Cons_nth_drop_Suc lessI)

lemma erase2jumpover2:
  "\<lbrakk>q < length list; \<forall>rn. <drop q list> @ Bk # Bk \<up> n \<noteq>
  Oc # Oc \<up> (list ! q) @ Bk # <drop (Suc q) list> @ Bk \<up> rn\<rbrakk>
  \<Longrightarrow> RR"
  apply(cases "Suc q < length list")
   apply(erule_tac x = "Suc n" in allE, simp)
   apply(erule_tac notE, simp add: replicate_Suc)
   apply(rule_tac drop_tape_of_cons, simp_all)
  apply(subgoal_tac "length list = Suc q", auto)
  apply(erule_tac x = "n" in allE, simp add: tape_of_list_def)
  by (metis append_Nil2 append_eq_conv_conj Cons_nth_drop_Suc lessI replicate_Suc tape_of_list_def tape_of_nl_cons)

lemma mod_ex1: "(a mod 2 = Suc 0) = (\<exists> q. a = Suc (2 * q))"
  by arith

declare replicate_Suc[simp]

lemma mopup_bef_erase_a_2_jump_over[simp]:
  "\<lbrakk>n < length lm; 0 < s; s mod 2 = Suc 0;  s \<le> 2 * n;
   mopup_bef_erase_a (s, l, Bk # xs) lm n ires; \<not> (Suc (Suc s) \<le> 2 * n)\<rbrakk>
\<Longrightarrow> mopup_jump_over1 (s', Bk # l, xs) lm n ires"
proof(cases n)
  case (Suc nat)
  assume assms: "n < length lm" "0 < s" "s mod 2 = Suc 0" "s \<le> 2 * n"
    "mopup_bef_erase_a (s, l, Bk # xs) lm n ires" "\<not> (Suc (Suc s) \<le> 2 * n)"
  from assms obtain a lm' where Cons:"lm = Cons a lm'" by (cases lm,auto)
  from assms have n:"Suc s div 2 = n" by auto
  have [simp]:"s = Suc (2 * q) \<longleftrightarrow> q = nat" for q using assms Suc by presburger
  from assms obtain ln m rn where ln:"l = Bk \<up> ln @ Bk # Bk # ires"
    and "Bk # xs = Oc \<up> m @ Bk # <drop (Suc s div 2) lm> @ Bk \<up> rn"
    by (auto simp: mopup_bef_erase_a.simps mopup_jump_over1.simps)
  hence xs:"xs = <drop n lm> @ Bk \<up> rn" by(cases m;auto simp: n mod_ex1)
  have [intro]:"nat < length lm' \<Longrightarrow>
    \<forall>rna. xs \<noteq> Oc # Oc \<up> (lm' ! nat) @ Bk # <drop (Suc nat) lm'> @ Bk \<up> rna \<Longrightarrow>
    <drop nat lm'> @ Bk \<up> rn = Oc # Oc \<up> (lm' ! nat)"
    by(cases rn, auto elim: erase2jumpover1 erase2jumpover2 simp:xs Suc Cons)
  have [intro]:"<drop nat lm'> \<noteq> Oc # Oc \<up> (lm' ! nat) @ Bk # <drop (Suc nat) lm'> @ Bk \<up> 0 \<Longrightarrow> length lm' \<le> Suc nat"
    using drop_tape_of_cons[of nat lm'] by fastforce
  from assms(1,3) have [intro!]:"
            0 + Suc (lm' ! nat) = Suc (lm' ! nat) \<and>
            Bk # Bk \<up> ln = Oc \<up> 0 @ Bk \<up> Suc ln \<and>
            ((\<exists>rna. xs = Oc \<up> Suc (lm' ! nat) @ Bk # <drop (Suc nat) lm'> @ Bk \<up> rna) \<or>
             xs = Oc \<up> Suc (lm' ! nat) \<and> length lm' \<le> Suc nat)"
    by (auto simp:Cons ln xs Suc)
  from assms(1,3) show ?thesis unfolding Cons ln Suc
    by(auto simp: mopup_bef_erase_a.simps mopup_jump_over1.simps simp del:split_head_repeat)
qed auto

lemma Suc_Suc_div:  "\<lbrakk>0 < s; s mod 2 = Suc 0; Suc (Suc s) \<le> 2 * n\<rbrakk>
           \<Longrightarrow> (Suc (Suc (s div 2))) \<le> n" by(arith)

lemma mopup_bef_erase_a_2_a[simp]:
  assumes "n < length lm" "0 < s" "s mod 2 = Suc 0"
    "mopup_bef_erase_a (s, l, Bk # xs) lm n ires"
    "Suc (Suc s) \<le> 2 * n"
  shows "mopup_bef_erase_a (Suc (Suc s), Bk # l, xs) lm n ires"
proof-
  from assms obtain rn m ln where
    rn:"l = Bk \<up> ln @ Bk # Bk # ires" "Bk # xs = Oc \<up> m @ Bk # <drop (Suc s div 2) lm> @ Bk \<up> rn"
    by (auto simp: mopup_bef_erase_a.simps)
  hence m:"m = 0" using assms by (cases m,auto)
  hence d:"drop (Suc (Suc (s div 2))) lm \<noteq> []"
    using assms(1,3,5) by auto arith
  hence "Bk # l = Bk \<up> Suc ln @ Bk # Bk # ires \<and>
    xs = Oc \<up> Suc (lm ! (Suc s div 2)) @ Bk # <drop ((Suc (Suc s) + 1) div 2) lm> @ Bk \<up> rn"
    using rn by(auto intro:drop_tape_of_cons simp:m)
  thus ?thesis unfolding mopup_bef_erase_a.simps by blast
qed

lemma mopup_false2:
  "\<lbrakk>0 < s; s \<le> 2 * n;
   s mod 2 = Suc 0; Suc s \<noteq> 2 * n;
   \<not> Suc (Suc s) \<le> 2 * n\<rbrakk> \<Longrightarrow> RR"
  by(arith)

lemma ariths[simp]: "\<lbrakk>0 < s; s \<le> 2 *n; s mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow>
                                      (s - Suc 0) mod 2 = Suc 0"
  "\<lbrakk>0 < s; s \<le> 2 *n; s mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow>
                                       s - Suc 0 \<le> 2 * n"
  "\<lbrakk>0 < s; s \<le> 2 *n; s mod 2 \<noteq> Suc 0\<rbrakk> \<Longrightarrow> \<not> s \<le> Suc 0"
  by(arith)+

lemma take_suc[intro]:
  "\<exists>lna. Bk # Bk \<up> ln = Bk \<up> lna"
  by(rule_tac x = "Suc ln" in exI, simp)

lemma mopup_bef_erase[simp]: "mopup_bef_erase_a (s, l, []) lm n ires \<Longrightarrow>
                        mopup_bef_erase_a (s, l, [Bk]) lm n ires"
  "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n; s mod 2 = Suc 0; \<not> Suc (Suc s) \<le> 2 *n;
     mopup_bef_erase_a (s, l, []) lm n ires\<rbrakk>
    \<Longrightarrow>  mopup_jump_over1 (s', Bk # l, []) lm n ires"
  "mopup_bef_erase_b (s, l, Oc # xs) lm n ires \<Longrightarrow> l \<noteq> []"
  "\<lbrakk>n < length lm; 0 < s; s \<le> 2 * n;
               s mod 2 \<noteq> Suc 0;
               mopup_bef_erase_b (s, l, Bk # xs) lm n ires; r = Bk # xs\<rbrakk>
           \<Longrightarrow> mopup_bef_erase_a (s - Suc 0, Bk # l, xs) lm n ires"
  "\<lbrakk>mopup_bef_erase_b (s, l, []) lm n ires\<rbrakk> \<Longrightarrow>
                   mopup_bef_erase_a (s - Suc 0, Bk # l, []) lm n ires"
  by(auto simp: mopup_bef_erase_b.simps mopup_bef_erase_a.simps)

lemma mopup_jump_over1_in_ctx[simp]:
  assumes "mopup_jump_over1 (Suc (2 * n), l, Oc # xs) lm n ires"
  shows "mopup_jump_over1 (Suc (2 * n), Oc # l, xs) lm n ires"
proof -
  from assms obtain ln m1 m2 rn where
    "m1 + m2 = Suc (lm ! n)"
    "l = Oc \<up> m1 @ Bk \<up> ln @ Bk # Bk # ires"
    "(Oc # xs = Oc \<up> m2 @ Bk # <drop (Suc n) lm> @ Bk \<up> rn \<or>
         Oc # xs = Oc \<up> m2 \<and> drop (Suc n) lm = [])" unfolding mopup_jump_over1.simps by blast
  thus ?thesis unfolding mopup_jump_over1.simps
    apply(rule_tac x = ln in exI, rule_tac x = "Suc m1" in exI
        ,rule_tac x = "m2 - 1" in exI)
    by(cases "m2", auto)
qed

lemma mopup_jump_over1_2_aft_erase_a[simp]:
  assumes "mopup_jump_over1 (Suc (2 * n), l, Bk # xs) lm n ires"
  shows "mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, xs) lm n ires"
proof -
  from assms obtain ln m1 m2 rn where
    "m1 + m2 = Suc (lm ! n)"
    "l = Oc \<up> m1 @ Bk \<up> ln @ Bk # Bk # ires"
    "(Bk # xs = Oc \<up> m2 @ Bk # <drop (Suc n) lm> @ Bk \<up> rn \<or>
        Bk # xs = Oc \<up> m2 \<and> drop (Suc n) lm = [])" unfolding mopup_jump_over1.simps by blast
  thus ?thesis unfolding mopup_aft_erase_a.simps
    apply( rule_tac x = ln in exI, rule_tac x = "Suc 0" in exI,rule_tac x = rn in exI
        , rule_tac x = "drop (Suc n) lm" in exI)
    by(cases m2, auto)
qed

lemma mopup_aft_erase_a_via_jump_over1[simp]:
  "\<lbrakk>mopup_jump_over1 (Suc (2 * n), l, []) lm n ires\<rbrakk> \<Longrightarrow>
    mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, []) lm n ires"
proof(rule mopup_jump_over1_2_aft_erase_a)
  assume a:"mopup_jump_over1 (Suc (2 * n), l, []) lm n ires"
  then obtain ln where ln:"length lm \<le> Suc n \<Longrightarrow> l = Oc # Oc \<up> (lm ! n) @ Bk \<up> ln @ Bk # Bk # ires"
    unfolding mopup_jump_over1.simps by auto
  show "mopup_jump_over1 (Suc (2 * n), l, [Bk]) lm n ires"
    unfolding mopup_jump_over1.simps
    apply(rule_tac x = ln in exI, rule_tac x = "Suc (lm ! n)" in exI,
        rule_tac x = 0 in exI)
    using a ln by(auto simp: mopup_jump_over1.simps tape_of_list_def )
qed

(*
The lemma was moved to Numerals.thy by FABR

lemma tape_of_list_empty[simp]: "<[]> = []" by (simp add: tape_of_list_def)
*)

lemma mopup_aft_erase_b_via_a[simp]:
  assumes "mopup_aft_erase_a (Suc (Suc (2 * n)), l, Oc # xs) lm n ires"
  shows "mopup_aft_erase_b (Suc (Suc (Suc (2 * n))), l, Bk # xs) lm n ires"
proof -
  from assms obtain lnl lnr rn ml where
    assms:
    "l = Bk \<up> lnr @ Oc \<up> Suc (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
    "Oc # xs = <ml::nat list> @ Bk \<up> rn"
    unfolding mopup_aft_erase_a.simps by auto
  then obtain a list where ml:"ml = a # list" by (cases ml,cases rn,auto)
  with assms show ?thesis unfolding mopup_aft_erase_b.simps
    apply(auto simp add: tape_of_nl_cons split: if_splits)
     apply(cases a, simp_all)
      apply(rule_tac x = rn in exI, rule_tac x = "[]" in exI, force)
     apply(rule_tac x = rn in exI, rule_tac x = "[a-1]" in exI)
     apply(cases "a"; force simp add: tape_of_list_def tape_of_nat_def)
    apply(cases "a")
     apply(rule_tac x = rn in exI, rule_tac x = list in exI, force)
    apply(rule_tac x = rn in exI,rule_tac x = "(a-1) # list" in exI, simp add: tape_of_nl_cons)
    done
qed

lemma mopup_left_moving_via_aft_erase_a[simp]:
  assumes "mopup_aft_erase_a (Suc (Suc (2 * n)), l, Bk # xs) lm n ires"
  shows "mopup_left_moving (5 + 2 * n, tl l, hd l # Bk # xs) lm n ires"
proof-
  from assms[unfolded mopup_aft_erase_a.simps] obtain lnl lnr rn ml where
    "l = Bk \<up> lnr @ Oc \<up> Suc (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
    "Bk # xs = <ml::nat list> @ Bk \<up> rn"
    by auto
  thus ?thesis unfolding mopup_left_moving.simps
    by(cases lnr;cases ml,auto simp: tape_of_nl_cons)
qed

lemma mopup_aft_erase_a_nonempty[simp]:
  "mopup_aft_erase_a (Suc (Suc (2 * n)), l, xs) lm n ires \<Longrightarrow> l \<noteq> []"
  by(auto simp only: mopup_aft_erase_a.simps)

lemma mopup_left_moving_via_aft_erase_a_emptylst[simp]:
  assumes "mopup_aft_erase_a (Suc (Suc (2 * n)), l, []) lm n ires"
  shows "mopup_left_moving (5 + 2 * n, tl l, [hd l]) lm n ires"
proof -
  have [intro!]:"[Bk] = Bk \<up> 1" by auto
  from assms obtain lnl lnr where "l = Bk \<up> lnr @ Oc # Oc \<up> (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
    unfolding mopup_aft_erase_a.simps by auto
  thus ?thesis by(case_tac lnr, auto simp add:mopup_left_moving.simps)
qed

lemma mopup_aft_erase_b_no_Oc[simp]: "mopup_aft_erase_b (2 * n + 3, l, Oc # xs) lm n ires = False"
  by(auto simp: mopup_aft_erase_b.simps)

lemma tape_of_ex1[intro]:
  "\<exists>rna ml. Oc \<up> a @ Bk \<up> rn = <ml::nat list> @ Bk \<up> rna \<or> Oc \<up> a @ Bk \<up> rn = Bk # <ml> @ Bk \<up> rna"
  by(rule_tac x = rn in exI, rule_tac x = "if a = 0 then [] else [a-1]" in exI,
      simp add: tape_of_list_def tape_of_nat_def)

lemma mopup_aft_erase_b_via_c_helper: "\<exists>rna ml. Oc \<up> a @ Bk # <list::nat list> @ Bk \<up> rn =
  <ml> @ Bk \<up> rna \<or> Oc \<up> a @ Bk # <list> @ Bk \<up> rn = Bk # <ml::nat list> @ Bk \<up> rna"
  apply(cases "list = []", simp add: replicate_Suc[THEN sym] del: replicate_Suc split_head_repeat)
   apply(rule_tac rn = "Suc rn" in tape_of_ex1)
  apply(cases a, simp)
   apply(rule_tac x = rn in exI, rule_tac x = list in exI, simp)
  apply(rule_tac x = rn in exI, rule_tac x = "(a-1) # list" in exI)
  apply(simp add: tape_of_nl_cons)
  done

lemma mopup_aft_erase_c_aft_erase_a[simp]:
  assumes "mopup_aft_erase_c (2 * n + 4, l, Bk # xs) lm n ires"
  shows "mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, xs) lm n ires"
proof -
  from assms obtain lnl lnr rn ml where
    "l = Bk \<up> lnr @ Oc \<up> Suc (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
    "(Bk # xs = <ml::nat list> @ Bk \<up> rn \<or> Bk # xs = Bk # <ml> @ Bk \<up> rn)"
    unfolding mopup_aft_erase_c.simps by auto
  thus ?thesis unfolding mopup_aft_erase_a.simps
    apply(clarify)
    apply(erule disjE)
     apply(subgoal_tac "ml = []", simp, case_tac rn,
        simp, simp, rule conjI)
       apply(rule_tac x = lnl in exI, rule_tac x = "Suc lnr" in exI, simp)
      apply (insert tape_of_list_empty,blast)
     apply(case_tac ml, simp, simp add: tape_of_nl_cons split: if_splits)
    apply(rule_tac x = lnl in exI, rule_tac x = "Suc lnr" in exI)
    apply(rule_tac x = rn in exI, rule_tac x = "ml" in exI, simp)
    done
qed

lemma mopup_aft_erase_a_via_c[simp]:
  "\<lbrakk>mopup_aft_erase_c (2 * n + 4, l, []) lm n ires\<rbrakk>
 \<Longrightarrow> mopup_aft_erase_a (Suc (Suc (2 * n)), Bk # l, []) lm n ires"
  by (rule mopup_aft_erase_c_aft_erase_a)
    (auto simp:mopup_aft_erase_c.simps)

lemma mopup_aft_erase_b_2_aft_erase_c[simp]:
  assumes "mopup_aft_erase_b (2 * n + 3, l, Bk # xs) lm n ires"
  shows "mopup_aft_erase_c (4 + 2 * n, Bk # l, xs) lm n ires"
proof -
  from assms obtain lnl lnr ml rn where
    "l = Bk \<up> lnr @ Oc \<up> Suc (lm ! n) @ Bk \<up> lnl @ Bk # Bk # ires"
    "Bk # xs = Bk # <ml::nat list> @ Bk \<up> rn \<or> Bk # xs = Bk # Bk # <ml> @ Bk \<up> rn"
    unfolding  mopup_aft_erase_b.simps by auto
  thus ?thesis unfolding mopup_aft_erase_c.simps
    by (rule_tac x = "lnl" in exI) auto
qed

lemma mopup_aft_erase_c_via_b[simp]:
  "\<lbrakk>mopup_aft_erase_b (2 * n + 3, l, []) lm n ires\<rbrakk>
 \<Longrightarrow> mopup_aft_erase_c (4 + 2 * n, Bk # l, []) lm n ires"
  by(auto simp add: mopup_aft_erase_b.simps intro:mopup_aft_erase_b_2_aft_erase_c)

lemma mopup_left_moving_nonempty[simp]:
  "mopup_left_moving (2 * n + 5, l, Oc # xs) lm n ires \<Longrightarrow> l \<noteq> []"
  by(auto simp: mopup_left_moving.simps)

lemma exp_ind: "a\<up>(Suc x) = a\<up>x @ [a]"
  by(induct x, auto)

lemma mopup_jump_over2_via_left_moving[simp]:
  "\<lbrakk>mopup_left_moving (2 * n + 5, l, Oc # xs) lm n ires\<rbrakk>
  \<Longrightarrow> mopup_jump_over2 (2 * n + 6, tl l, hd l # Oc # xs) lm n ires"
  apply(simp only: mopup_left_moving.simps mopup_jump_over2.simps)
  apply(erule_tac exE)+
  apply(erule conjE, erule disjE, erule conjE)
   apply (simp add: Cons_replicate_eq)
  apply(rename_tac Lnl lnr rn m)
  apply(cases "hd l", simp add:  )
   apply(cases "lm ! n", simp)
    apply(rule exI, rule_tac x = "length xs" in exI,
      rule_tac x = "Suc 0" in exI, rule_tac x = 0 in exI)
    apply(case_tac Lnl, simp,simp,  simp add: exp_ind[THEN sym])
   apply(cases "lm ! n", simp)
   apply(case_tac Lnl, simp, simp)
  apply(rule_tac x = Lnl in exI, rule_tac x = "length xs" in exI, auto)
  apply(cases "lm ! n", simp)
   apply(case_tac Lnl, simp_all add: numeral_2_eq_2)
  done

lemma mopup_left_moving_nonempty_snd[simp]: "mopup_left_moving (2 * n + 5, l, xs) lm n ires \<Longrightarrow> l \<noteq> []"
  apply(auto simp: mopup_left_moving.simps)
  done

lemma mopup_left_moving_hd_Bk[simp]:
  "\<lbrakk>mopup_left_moving (2 * n + 5, l, Bk # xs) lm n ires\<rbrakk>
 \<Longrightarrow> mopup_left_moving (2 * n + 5, tl l, hd l # Bk # xs) lm n ires"
  apply(simp only: mopup_left_moving.simps)
  apply(erule exE)+ apply(rename_tac lnl Lnr rn m)
  apply(case_tac Lnr, auto)
  done

lemma mopup_left_moving_emptylist[simp]:
  "\<lbrakk>mopup_left_moving (2 * n + 5, l, []) lm n ires\<rbrakk>
    \<Longrightarrow> mopup_left_moving (2 * n + 5, tl l, [hd l]) lm n ires"
  apply(simp only: mopup_left_moving.simps)
  apply(erule exE)+ apply(rename_tac lnl Lnr rn m)
  apply(case_tac Lnr, auto)
  apply(rule_tac x = 1 in exI, simp)
  done

lemma mopup_jump_over2_Oc_nonempty[simp]:
  "mopup_jump_over2 (2 * n + 6, l, Oc # xs) lm n ires \<Longrightarrow> l \<noteq> []"
  apply(auto simp: mopup_jump_over2.simps )
  done

lemma mopup_jump_over2_context[simp]:
  "\<lbrakk>mopup_jump_over2 (2 * n + 6, l, Oc # xs) lm n ires\<rbrakk>
 \<Longrightarrow>  mopup_jump_over2 (2 * n + 6, tl l, hd l # Oc # xs) lm n ires"
  apply(simp only: mopup_jump_over2.simps)
  apply(erule_tac exE)+
  apply(simp, erule conjE, erule_tac conjE)
  apply(rename_tac Ln Rn M1 M2)
  apply(case_tac M1, simp)
   apply(rule_tac x = Ln in exI, rule_tac x = Rn in exI,
      rule_tac x = 0 in exI)
   apply(case_tac Ln, simp, simp, simp only: exp_ind[THEN sym], simp)
  apply(rule_tac x = Ln in exI, rule_tac x = Rn in exI,
      rule_tac x = "M1-1" in exI, rule_tac x = "Suc M2" in exI, simp)
  done

lemma mopup_stop_via_jump_over2[simp]:
  "\<lbrakk>mopup_jump_over2 (2 * n + 6, l, Bk # xs) lm n ires\<rbrakk>
  \<Longrightarrow> mopup_stop (0, Bk # l, xs) lm n ires"
  apply(auto simp: mopup_jump_over2.simps mopup_stop.simps tape_of_nat_def)
  apply(simp add: exp_ind[THEN sym])
  done

lemma mopup_jump_over2_nonempty[simp]: "mopup_jump_over2 (2 * n + 6, l, []) lm n ires = False"
  by(auto simp: mopup_jump_over2.simps)

declare fetch.simps[simp del]
lemma mod_ex2: "(a mod (2::nat) = 0) = (\<exists> q. a = 2 * q)"
  by arith

lemma mod_2: "x mod 2  = 0 \<or>  x mod 2 = Suc 0"
  by arith

lemma mopup_inv_step:
  "\<lbrakk>n < length lm; mopup_inv (s, l, r) lm n ires\<rbrakk>
  \<Longrightarrow> mopup_inv (step (s, l, r) (mopup_a n @ shift mopup_b (2 * n), 0)) lm n ires"
  apply(cases r;cases "hd r")
     apply(auto split:if_splits simp add:step.simps mopupfetchs fetch.simps(1))
      apply(drule_tac mopup_false2, simp_all add: mopup_bef_erase_b.simps)
    apply(drule_tac mopup_false2, simp_all)
   apply(drule_tac mopup_false2, simp_all)
  by presburger

declare mopup_inv.simps[simp del]
lemma mopup_inv_steps:
  "\<lbrakk>n < length lm; mopup_inv (s, l, r) lm n ires\<rbrakk> \<Longrightarrow>
     mopup_inv (steps (s, l, r) (mopup_a n @ shift mopup_b (2 * n), 0)  stp) lm n ires"
proof(induct stp)
  case (Suc stp)
  then show ?case
    by ( cases "steps (s, l, r)
                (mopup_a n @ shift mopup_b (2 * n), 0) stp"
        , auto simp add: steps.simps intro:mopup_inv_step)
qed (auto simp add: steps.simps)

fun abc_mopup_stage1 :: "config \<Rightarrow> nat \<Rightarrow> nat"
  where
    "abc_mopup_stage1 (s, l, r) n =
           (if s > 0 \<and> s \<le> 2*n then 6
            else if s = 2*n + 1 then 4
            else if s \<ge> 2*n + 2 \<and> s \<le> 2*n + 4 then 3
            else if s = 2*n + 5 then 2
            else if s = 2*n + 6 then 1
            else 0)"

fun abc_mopup_stage2 :: "config \<Rightarrow> nat \<Rightarrow> nat"
  where
    "abc_mopup_stage2 (s, l, r) n =
           (if s > 0 \<and> s \<le> 2*n then length r
            else if s = 2*n + 1 then length r
            else if s = 2*n + 5 then length l
            else if s = 2*n + 6 then length l
            else if s \<ge> 2*n + 2 \<and> s \<le> 2*n + 4 then length r
            else 0)"

fun abc_mopup_stage3 :: "config \<Rightarrow> nat \<Rightarrow> nat"
  where
    "abc_mopup_stage3 (s, l, r) n =
          (if s > 0 \<and> s \<le> 2*n then
              if hd r = Bk then 0
              else 1
           else if s = 2*n + 2 then 1
           else if s = 2*n + 3 then 0
           else if s = 2*n + 4 then 2
           else 0)"

definition
  "abc_mopup_measure = measures [\<lambda>(c, n). abc_mopup_stage1 c n,
                                 \<lambda>(c, n). abc_mopup_stage2 c n,
                                 \<lambda>(c, n). abc_mopup_stage3 c n]"

lemma wf_abc_mopup_measure:
  shows "wf abc_mopup_measure"
  unfolding abc_mopup_measure_def
  by auto

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

lemma mopup_erase_nonempty[simp]:
  "mopup_bef_erase_a (a, aa, []) lm n ires = False"
  "mopup_bef_erase_b (a, aa, []) lm n ires = False"
  "mopup_aft_erase_b (2 * n + 3, aa, []) lm n ires = False"
  by(auto simp: mopup_bef_erase_a.simps mopup_bef_erase_b.simps mopup_aft_erase_b.simps)

declare mopup_inv.simps[simp del]

lemma fetch_mopup_a_shift[simp]:
  assumes "0 < q" "q \<le> n"
  shows "fetch (mopup_a n @ shift mopup_b (2 * n)) (2*q) Bk = (R, 2*q - 1)"
proof(cases q)
  case (Suc nat) with assms
  have "mopup_a n ! (4 * nat + 2) = mopup_a (Suc nat) ! ((4 * nat) + 2)" using assms
    by (metis Suc_le_lessD add_2_eq_Suc' less_Suc_eq mopup_a_nth numeral_Bit0)
  then show ?thesis using assms Suc
    by(auto simp: fetch.simps nth_of.simps nth_append)
qed (insert assms,auto)

lemma mopup_halt:
  assumes
    less: "n < length lm"
    and inv: "mopup_inv (Suc 0, l, r) lm n ires"
    and f: "f = (\<lambda> stp. (steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) stp, n))"
    and P: "P = (\<lambda> (c, n). is_final c)"
  shows "\<exists> stp. P (f stp)"
proof (induct rule: abc_mopup_measure_induct)
  case (Step na)
  have h: "\<not> P (f na)" by fact
  show "(f (Suc na), f na) \<in> abc_mopup_measure"
  proof(simp add: f)
    obtain a b c where g:"steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na = (a, b, c)"
      apply(case_tac "steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na", auto)
      done
    then have "mopup_inv (a, b, c) lm n ires"
      using inv less mopup_inv_steps[of n lm "Suc 0" l r ires na]
      apply(simp)
      done
    moreover have "a > 0"
      using h g
      apply(simp add: f P)
      done
    ultimately
    have "((step (a, b, c) (mopup_a n @ shift mopup_b (2 * n), 0), n), (a, b, c), n) \<in> abc_mopup_measure"
      apply(case_tac c;cases "hd c")
         apply(auto split:if_splits simp add:step.simps mopup_inv.simps mopup_bef_erase_b.simps)
      by (auto split:if_splits simp: mopupfetchs abc_mopup_measure_def )
    thus "((step (steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na)
      (mopup_a n @ shift mopup_b (2 * n), 0), n),
      steps (Suc 0, l, r) (mopup_a n @ shift mopup_b (2 * n), 0) na, n)
      \<in> abc_mopup_measure"
      using g by simp
  qed
qed

lemma mopup_inv_start:
  "n < length am \<Longrightarrow> mopup_inv (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) am n ires"
  apply(cases am;auto simp: mopup_inv.simps mopup_bef_erase_a.simps mopup_jump_over1.simps)
    apply(auto simp: tape_of_nl_cons)
     apply(rule_tac x = "Suc (hd am)" in exI, rule_tac x = k in exI, simp)
    apply(cases k;cases n;force)
   apply(cases n; force)
  by(cases n; force split:if_splits)

lemma mopup_correct:
  assumes less: "n < length (am::nat list)"
    and rs: "am ! n = rs"
  shows "\<exists> stp i j. (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)
    = (0, Bk\<up>i @ Bk # Bk # ires, Oc # Oc\<up> rs @ Bk\<up>j)"
  using less
proof -
  have a: "mopup_inv (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) am n ires"
    using less
    apply(simp add: mopup_inv_start)
    done
  then have "\<exists> stp. is_final (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)"
    using less mopup_halt[of n am  "Bk # Bk # ires" "<am> @ Bk \<up> k" ires
        "(\<lambda>stp. (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp, n))"
        "(\<lambda>(c, n). is_final c)"]
    apply(simp)
    done
  from this obtain stp where b:
    "is_final (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)" ..
  from a b have
    "mopup_inv (steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k) (mopup_a n @ shift mopup_b (2 * n), 0) stp)
    am n ires"
    apply(rule_tac mopup_inv_steps, simp_all add: less)
    done
  from b and this show "?thesis"
    apply(rule_tac x = stp in exI, simp)
    apply(case_tac "steps (Suc 0, Bk # Bk # ires, <am> @ Bk \<up> k)
      (mopup_a n @ shift mopup_b (2 * n), 0) stp")
    apply(simp add: mopup_inv.simps mopup_stop.simps rs)
    using rs
    apply(simp add: tape_of_nat_def)
    done
qed

lemma composable_mopup_n_tm[intro]: "composable_tm (mopup_n_tm n, 0)"
  by(induct n, auto simp add: shift.simps mopup_b_def composable_tm.simps)

end


(* File:   Akra_Bazzi_Asymptotics.thy
   Author: Manuel Eberl <manuel@pruvisto.org>

   Proofs for the four(ish) asymptotic inequalities required for proving the
   Akra Bazzi theorem with variation functions in the recursive calls.
*)

section \<open>Asymptotic bounds\<close>
theory Akra_Bazzi_Asymptotics
imports
  Complex_Main
  Akra_Bazzi_Library
  "HOL-Library.Landau_Symbols"
begin

locale akra_bazzi_asymptotics_bep =
  fixes b e p hb :: real
  assumes bep: "b > 0" "b < 1" "e > 0" "hb > 0"
begin

context
begin

text \<open>
  Functions that are negligible w.r.t. @{term "ln (b*x) powr (e/2 + 1)"}.
\<close>
private abbreviation (input) negl :: "(real \<Rightarrow> real) \<Rightarrow> bool" where
  "negl f \<equiv> f \<in> o(\<lambda>x. ln (b*x) powr (-(e/2 + 1)))"

private lemma neglD: "negl f \<Longrightarrow> c > 0 \<Longrightarrow> eventually (\<lambda>x. \<bar>f x\<bar> \<le> c / ln (b*x) powr (e/2+1)) at_top"
  by (drule (1) landau_o.smallD, subst (asm) powr_minus) (simp add: field_simps)

private lemma negl_mult: "negl f \<Longrightarrow> negl g \<Longrightarrow> negl (\<lambda>x. f x * g x)"
  by (erule landau_o.small_1_mult, rule landau_o.small_imp_big, erule landau_o.small_trans)
     (insert bep, simp)

private lemma ev4:
  assumes g: "negl g"
  shows   "eventually (\<lambda>x. ln (b*x) powr (-e/2) - ln x powr (-e/2) \<ge> g x) at_top"
proof (rule smallo_imp_le_real)
  define h1 where [abs_def]:
    "h1 x = (1 + ln b/ln x) powr (-e/2) - 1 + e/2 * (ln b/ln x)" for x
  define h2 where [abs_def]:
    "h2 x = ln x powr (- e / 2) * ((1 + ln b / ln x) powr (- e / 2) - 1)" for x
  from bep have "((\<lambda>x. ln b / ln x) \<longlongrightarrow> 0) at_top"
    by (simp add: tendsto_0_smallo_1)
  note one_plus_x_powr_Taylor2_bigo[OF this, of "-e/2"]
  also have "(\<lambda>x. (1 + ln b / ln x) powr (- e / 2) - 1 - - e / 2 * (ln b / ln x)) = h1"
    by (simp add: h1_def)
  finally have "h1 \<in> o(\<lambda>x. 1 / ln x)"
    by (rule landau_o.big_small_trans) (insert bep, simp add: power2_eq_square)
  with bep have "(\<lambda>x. h1 x - e/2 * (ln b / ln x)) \<in> \<Theta>(\<lambda>x. 1 / ln x)" by simp
  also have "(\<lambda>x. h1 x - e/2 * (ln b/ln x)) = (\<lambda>x. (1 + ln b/ ln x) powr (-e/2) - 1)"
    by (rule ext) (simp add: h1_def)
  finally have "h2 \<in> \<Theta>(\<lambda>x. ln x powr (-e/2) * (1 / ln x))" unfolding h2_def
    by (intro landau_theta.mult) simp_all
  also have "(\<lambda>x. ln x powr (-e/2) * (1 / ln x)) \<in> \<Theta>(\<lambda>x. ln x powr (-(e/2+1)))" by simp
  also from g bep have "(\<lambda>x. ln x powr (-(e/2+1))) \<in> \<omega>(g)" by (simp add: smallomega_iff_smallo)
  finally have "g \<in> o(h2)" by (simp add: smallomega_iff_smallo)
  also have "eventually (\<lambda>x. h2 x = ln (b*x) powr (-e/2) - ln x powr (-e/2)) at_top"
    using eventually_gt_at_top[of "1::real"] eventually_gt_at_top[of "1/b"]
    by eventually_elim (insert bep, simp add: field_simps powr_diff [symmetric]  h2_def
                                      ln_mult [symmetric] powr_divide del: ln_mult)
  hence "h2 \<in> \<Theta>(\<lambda>x. ln (b*x) powr (-e/2) - ln x powr (-e/2))" by (rule bigthetaI_cong)
  finally show "g \<in> o(\<lambda>x. ln (b * x) powr (- e / 2) - ln x powr (- e / 2))" .
next
  show "eventually (\<lambda>x. ln (b*x) powr (-e/2) - ln x powr (-e/2) \<ge> 0) at_top"
    using eventually_gt_at_top[of "1/b"] eventually_gt_at_top[of "1::real"]
    by eventually_elim (insert bep, auto intro!: powr_mono2' simp: field_simps simp del: ln_mult)
qed

private lemma ev1:
  "negl (\<lambda>x. (1 + c * inverse b * ln x powr (-(1+e))) powr p - 1)"
proof-
  from bep have "((\<lambda>x. c * inverse b * ln x powr (-(1+e))) \<longlongrightarrow> 0) at_top"
    by (simp add: tendsto_0_smallo_1)
  have "(\<lambda>x. (1 + c * inverse b * ln x powr (-(1+e))) powr p - 1)
           \<in> O(\<lambda>x. c * inverse b * ln x powr - (1 + e))"
    using bep by (intro one_plus_x_powr_Taylor1_bigo) (simp add: tendsto_0_smallo_1)
  also from bep have "negl (\<lambda>x. c * inverse b * ln x powr - (1 + e))" by simp
  finally show ?thesis .
qed

private lemma ev2_aux:
  defines "f \<equiv> \<lambda>x. (1 + 1/ln (b*x) * ln (1 + hb / b * ln x powr (-1-e))) powr (-e/2)"
  obtains h where "eventually (\<lambda>x. f x \<ge> 1 + h x) at_top" "h \<in> o(\<lambda>x. 1 / ln x)"
proof (rule that[of "\<lambda>x. f x - 1"])
  define g where [abs_def]: "g x = 1/ln (b*x) * ln (1 + hb / b * ln x powr (-1-e))" for x
  have lim: "((\<lambda>x. ln (1 + hb / b * ln x powr (- 1 - e))) \<longlongrightarrow> 0) at_top"
    by (rule tendsto_eq_rhs[OF tendsto_ln[OF tendsto_add[OF tendsto_const, of _ 0]]])
       (insert bep, simp_all add: tendsto_0_smallo_1)
  hence lim': "(g \<longlongrightarrow> 0) at_top" unfolding g_def
    by (intro tendsto_mult_zero) (insert bep, simp add: tendsto_0_smallo_1)
  from one_plus_x_powr_Taylor2_bigo[OF this, of "-e/2"]
    have "(\<lambda>x. (1 + g x) powr (-e/2) - 1 - - e/2 * g x) \<in> O(\<lambda>x. (g x)\<^sup>2)" .
  also from lim' have "(\<lambda>x. g x ^ 2) \<in> o(\<lambda>x. g x * 1)" unfolding power2_eq_square
    by (intro landau_o.big_small_mult smalloI_tendsto) simp_all
  also have "o(\<lambda>x. g x * 1) = o(g)" by simp
  also have "(\<lambda>x. (1 + g x) powr (-e/2) - 1 - - e/2 * g x) = (\<lambda>x. f x - 1 + e/2 * g x)"
    by (simp add: f_def g_def)
  finally have A: "(\<lambda>x. f x - 1 + e / 2 * g x) \<in> O(g)" by (rule landau_o.small_imp_big)
  hence "(\<lambda>x. f x - 1 + e/2 * g x - e/2 * g x) \<in> O(g)"
    by (rule sum_in_bigo) (insert bep, simp)
  also have "(\<lambda>x. f x - 1 + e/2 * g x - e/2 * g x) = (\<lambda>x. f x - 1)" by simp
  finally have "(\<lambda>x. f x - 1) \<in> O(g)" .
  also from bep lim have "g \<in> o(\<lambda>x. 1 / ln x)" unfolding g_def
    by (auto intro!: smallo_1_tendsto_0)
  finally show "(\<lambda>x. f x - 1) \<in> o(\<lambda>x. 1 / ln x)" .
qed simp_all

private lemma ev2:
  defines "f \<equiv> \<lambda>x. ln (b * x + hb * x / ln x powr (1 + e)) powr (-e/2)"
  obtains h where
    "negl h"
    "eventually (\<lambda>x. f x \<ge> ln (b * x) powr (-e/2) + h x) at_top"
    "eventually (\<lambda>x. \<bar>ln (b * x) powr (-e/2) + h x\<bar> < 1) at_top"
proof -
  define f'
    where "f' x = (1 + 1 / ln (b*x) * ln (1 + hb / b * ln x powr (-1-e))) powr (-e/2)" for x
  from ev2_aux obtain g where g: "eventually (\<lambda>x. 1 + g x \<le> f' x) at_top" "g \<in> o(\<lambda>x. 1 / ln x)"
    unfolding f'_def .
  define h where [abs_def]: "h x = ln (b*x) powr (-e/2) * g x" for x
  show ?thesis
  proof (rule that[of h])
    from bep g show "negl h" unfolding h_def
      by (auto simp: powr_diff elim: landau_o.small_big_trans)
  next
    from g(2) have "g \<in> o(\<lambda>x. 1)" by (rule landau_o.small_big_trans) simp
    with bep have "eventually (\<lambda>x. \<bar>ln (b*x) powr (-e/2) * (1 + g x)\<bar> < 1) at_top"
      by (intro smallo_imp_abs_less_real) simp_all
    thus "eventually (\<lambda>x. \<bar>ln (b*x) powr (-e/2) + h x\<bar> < 1) at_top"
      by (simp add: algebra_simps h_def)
  next
    from eventually_gt_at_top[of "1/b"] and g(1)
      show "eventually (\<lambda>x. f x \<ge> ln (b*x) powr (-e/2) + h x) at_top"
    proof eventually_elim
      case (elim x)
      from bep have "b * x + hb * x / ln x powr (1 + e) = b*x * (1 + hb / b * ln x powr (-1 - e))"
        by (simp add: field_simps powr_diff powr_add powr_minus)
      also from elim(1) bep
        have "ln \<dots> = ln (b*x) * (1 + 1/ln (b*x) * ln (1 + hb / b * ln x powr (-1-e)))"
        by (subst ln_mult) (simp_all add: add_pos_nonneg field_simps)
      also from elim(1) bep have "\<dots> powr (-e/2) = ln (b*x) powr (-e/2) * f' x"
        by (subst powr_mult) (simp_all add: field_simps f'_def)
      also from elim have "\<dots> \<ge> ln (b*x) powr (-e/2) * (1 + g x)"
        by (intro mult_left_mono) simp_all
      finally show "f x \<ge> ln (b*x) powr (-e/2) + h x"
        by (simp add: f_def h_def algebra_simps)
    qed
  qed
qed

private lemma ev21:
  obtains g where
    "negl g"
    "eventually (\<lambda>x. 1 + ln (b * x + hb * x / ln x powr (1 + e)) powr (-e/2) \<ge>
         1 + ln (b * x) powr (-e/2) + g x) at_top"
    "eventually (\<lambda>x. 1 + ln (b * x) powr (-e/2) + g x > 0) at_top"
proof-
  from ev2 guess g . note g = this
  from g(3) have "eventually (\<lambda>x. 1 + ln (b * x) powr (-e/2) + g x > 0) at_top"
    by eventually_elim simp
  with g(1,2) show ?thesis by (intro that[of g]) simp_all
qed

private lemma ev22:
  obtains g where
    "negl g"
    "eventually (\<lambda>x. 1 - ln (b * x + hb * x / ln x powr (1 + e)) powr (-e/2) \<le>
         1 - ln (b * x) powr (-e/2) - g x) at_top"
    "eventually (\<lambda>x. 1 - ln (b * x) powr (-e/2) - g x > 0) at_top"
proof-
  from ev2 guess g . note g = this
  from g(2) have "eventually (\<lambda>x. 1 - ln (b * x + hb * x / ln x powr (1 + e)) powr (-e/2) \<le>
                                      1 - ln (b * x) powr (-e/2) - g x) at_top"
    by eventually_elim simp
  moreover from g(3) have "eventually (\<lambda>x. 1 - ln (b * x) powr (-e/2) - g x > 0) at_top"
    by eventually_elim simp
  ultimately show ?thesis using g(1) by (intro that[of g]) simp_all
qed

lemma asymptotics1:
  shows "eventually (\<lambda>x.
             (1 + c * inverse b * ln x powr -(1+e)) powr p *
             (1 + ln (b * x + hb * x / ln x powr (1 + e)) powr (- e / 2)) \<ge>
             1 + (ln x powr (-e/2))) at_top"
proof-
  let ?f = "\<lambda>x. (1 + c * inverse b * ln x powr -(1+e)) powr p"
  let ?g = "\<lambda>x. 1 + ln (b * x + hb * x / ln x powr (1 + e)) powr (- e / 2)"
  define f where [abs_def]: "f x = 1 - ?f x" for x
  from ev1[of c] have "negl f" unfolding f_def
    by (subst landau_o.small.uminus_in_iff [symmetric]) simp
  from landau_o.smallD[OF this zero_less_one]
    have f: "eventually (\<lambda>x. f x \<le> ln (b*x) powr -(e/2+1)) at_top"
    by eventually_elim (simp add: f_def)

  from ev21 guess g . note g = this
  define h where [abs_def]: "h x = -g x + f x + f x * ln (b*x) powr (-e/2) + f x * g x" for x

  have A: "eventually (\<lambda>x. ?f x * ?g x \<ge> 1 + ln (b*x) powr (-e/2) - h x) at_top"
    using g(2,3) f
  proof eventually_elim
    case (elim x)
    let ?t = "ln (b*x) powr (-e/2)"
    have "1 + ?t - h x = (1 - f x) * (1 + ln (b*x) powr (-e/2) + g x)"
      by (simp add: algebra_simps h_def)
    also from elim have "?f x * ?g x \<ge> (1 - f x) * (1 + ln (b*x) powr (-e/2) + g x)"
      by (intro mult_mono[OF _ elim(1)]) (simp_all add: algebra_simps f_def)
    finally show "?f x * ?g x \<ge> 1 + ln (b*x) powr (-e/2) - h x" .
  qed
  from bep \<open>negl f\<close> g(1) have "negl h" unfolding h_def
    by (fastforce intro!: sum_in_smallo landau_o.small.mult simp: powr_diff
                  intro: landau_o.small_trans)+
  from ev4[OF this] A show ?thesis by eventually_elim simp
qed

lemma asymptotics2:
  shows "eventually (\<lambda>x.
             (1 + c * inverse b * ln x powr -(1+e)) powr p *
             (1 - ln (b * x + hb * x / ln x powr (1 + e)) powr (- e / 2)) \<le>
             1 - (ln x powr (-e/2))) at_top"
proof-
  let ?f = "\<lambda>x. (1 + c * inverse b * ln x powr -(1+e)) powr p"
  let ?g = "\<lambda>x. 1 - ln (b * x + hb * x / ln x powr (1 + e)) powr (- e / 2)"

  define f where [abs_def]: "f x = 1 - ?f x" for x
  from ev1[of c] have "negl f" unfolding f_def
    by (subst landau_o.small.uminus_in_iff [symmetric]) simp
  from landau_o.smallD[OF this zero_less_one]
    have f: "eventually (\<lambda>x. f x \<le> ln (b*x) powr -(e/2+1)) at_top"
    by eventually_elim (simp add: f_def)

  from ev22 guess g . note g = this
  define h where [abs_def]: "h x = -g x - f x + f x * ln (b*x) powr (-e/2) + f x * g x" for x
  have "((\<lambda>x. ln (b * x + hb * x / ln x powr (1 + e)) powr - (e / 2)) \<longlongrightarrow> 0) at_top"
    apply (insert bep, intro tendsto_neg_powr, simp)
    apply (rule filterlim_compose[OF ln_at_top])
    apply (rule filterlim_at_top_smallomega_1, simp)
    using eventually_gt_at_top[of "max 1 (1/b)"]
    apply (auto elim!: eventually_mono intro!: add_pos_nonneg simp: field_simps)
    apply (smt (z3) divide_nonneg_nonneg mult_neg_pos mult_nonneg_nonneg powr_non_neg)
    done
  hence ev_g: "eventually (\<lambda>x. \<bar>1 - ?g x\<bar> < 1) at_top"
    by (intro smallo_imp_abs_less_real smalloI_tendsto) simp_all

  have A: "eventually (\<lambda>x. ?f x * ?g x \<le> 1 - ln (b*x) powr (-e/2) + h x) at_top"
    using g(2,3) ev_g f
  proof eventually_elim
    case (elim x)
    let ?t = "ln (b*x) powr (-e/2)"
    from elim have "?f x * ?g x \<le> (1 - f x) * (1 - ln (b*x) powr (-e/2) - g x)"
      by (intro mult_mono) (simp_all add: f_def)
    also have "... = 1 - ?t + h x" by (simp add: algebra_simps h_def)
    finally show "?f x * ?g x \<le> 1 - ln (b*x) powr (-e/2) + h x" .
  qed
  from bep \<open>negl f\<close> g(1) have "negl h" unfolding h_def
    by (fastforce intro!: sum_in_smallo landau_o.small.mult simp: powr_diff
                  intro: landau_o.small_trans)+
  from ev4[OF this] A show ?thesis by eventually_elim simp
qed

lemma asymptotics3: "eventually (\<lambda>x. (1 + (ln x powr (-e/2))) / 2 \<le> 1) at_top"
  (is "eventually (\<lambda>x. ?f x \<le> 1) _")
proof (rule eventually_mp[OF always_eventually], clarify)
  from bep have "(?f \<longlongrightarrow> 1/2) at_top"
    by (force intro: tendsto_eq_intros tendsto_neg_powr ln_at_top)
  hence "\<And>e. e>0 \<Longrightarrow> eventually (\<lambda>x. \<bar>?f x - 0.5\<bar> < e) at_top"
    by (subst (asm) tendsto_iff) (simp add: dist_real_def)
  from this[of "0.5"] show "eventually (\<lambda>x. \<bar>?f x - 0.5\<bar> < 0.5) at_top" by simp
  fix x assume "\<bar>?f x - 0.5\<bar> < 0.5"
  thus "?f x \<le> 1" by simp
qed

lemma asymptotics5: "eventually (\<lambda>x. ln (b*x - hb*x*ln x powr -(1+e)) powr (-e/2) < 1) at_top"
proof-
  from bep have "((\<lambda>x. b - hb * ln x powr -(1+e)) \<longlongrightarrow> b - 0) at_top"
    by (intro tendsto_intros tendsto_mult_right_zero tendsto_neg_powr ln_at_top) simp_all
  hence "LIM x at_top. (b - hb * ln x powr -(1+e)) * x :> at_top"
    by (rule filterlim_tendsto_pos_mult_at_top[OF _ _ filterlim_ident], insert bep) simp_all
  also have "(\<lambda>x. (b - hb * ln x powr -(1+e)) * x) = (\<lambda>x. b*x - hb*x*ln x powr -(1+e))"
    by (intro ext) (simp add: algebra_simps)
  finally have "filterlim ... at_top at_top" .
  with bep have "((\<lambda>x. ln (b*x - hb*x*ln x powr -(1+e)) powr -(e/2)) \<longlongrightarrow> 0) at_top"
    by (intro tendsto_neg_powr filterlim_compose[OF ln_at_top]) simp_all
  hence "eventually (\<lambda>x. \<bar>ln (b*x - hb*x*ln x powr -(1+e)) powr (-e/2)\<bar> < 1) at_top"
    by (subst (asm) tendsto_iff) (simp add: dist_real_def)
  thus ?thesis by simp
qed

lemma asymptotics6: "eventually (\<lambda>x. hb / ln x powr (1 + e) < b/2) at_top"
  and asymptotics7: "eventually (\<lambda>x. hb / ln x powr (1 + e) < (1 - b) / 2) at_top"
  and asymptotics8: "eventually (\<lambda>x. x*(1 - b - hb / ln x powr (1 + e)) > 1) at_top"
proof-
  from bep have A: "(\<lambda>x. hb / ln x powr (1 + e)) \<in> o(\<lambda>_. 1)" by simp
  from bep have B: "b/3 > 0" and C: "(1 - b)/3 > 0" by simp_all
  from landau_o.smallD[OF A B] show "eventually (\<lambda>x. hb / ln x powr (1+e) < b/2) at_top"
    by eventually_elim (insert bep, simp)
  from landau_o.smallD[OF A C] show "eventually (\<lambda>x. hb / ln x powr (1 + e) < (1 - b)/2) at_top"
    by eventually_elim (insert bep, simp)

  from bep have "(\<lambda>x. hb / ln x powr (1 + e)) \<in> o(\<lambda>_. 1)" "(1 - b) / 2 > 0" by simp_all
  from landau_o.smallD[OF this] eventually_gt_at_top[of "1::real"]
    have A: "eventually (\<lambda>x. 1 - b - hb / ln x powr (1 + e) > 0) at_top"
    by eventually_elim (insert bep, simp add: field_simps)
  from bep have "(\<lambda>x. x * (1 - b - hb / ln x powr (1+e))) \<in> \<omega>(\<lambda>_. 1)" "(0::real) < 2" by simp_all
  from landau_omega.smallD[OF this] A eventually_gt_at_top[of "0::real"]
    show "eventually (\<lambda>x. x*(1 - b - hb / ln x powr (1 + e)) > 1) at_top"
    by eventually_elim (simp_all add: abs_mult)
qed

end
end

definition "akra_bazzi_asymptotic1 b hb e p x \<longleftrightarrow>
  (1 - hb * inverse b * ln x powr -(1+e)) powr p * (1 + ln (b*x + hb*x/ln x powr (1+e)) powr (-e/2))
  \<ge> 1 + (ln x powr (-e/2) :: real)"
definition "akra_bazzi_asymptotic1' b hb e p x \<longleftrightarrow>
  (1 + hb * inverse b * ln x powr -(1+e)) powr p * (1 + ln (b*x + hb*x/ln x powr (1+e)) powr (-e/2))
  \<ge> 1 + (ln x powr (-e/2) :: real)"
definition "akra_bazzi_asymptotic2 b hb e p x \<longleftrightarrow>
  (1 + hb * inverse b * ln x powr -(1+e)) powr p * (1 - ln (b*x + hb*x/ln x powr (1+e)) powr (-e/2))
      \<le> 1 - ln x powr (-e/2 :: real)"
definition "akra_bazzi_asymptotic2' b hb e p x \<longleftrightarrow>
  (1 - hb * inverse b * ln x powr -(1+e)) powr p * (1 - ln (b*x + hb*x/ln x powr (1+e)) powr (-e/2))
      \<le> 1 - ln x powr (-e/2 :: real)"
definition "akra_bazzi_asymptotic3 e x \<longleftrightarrow> (1 + (ln x powr (-e/2))) / 2 \<le> (1::real)"
definition "akra_bazzi_asymptotic4 e x \<longleftrightarrow> (1 - (ln x powr (-e/2))) * 2 \<ge> (1::real)"
definition "akra_bazzi_asymptotic5 b hb e x \<longleftrightarrow>
  ln (b*x - hb*x*ln x powr -(1+e)) powr (-e/2::real) < 1"

definition "akra_bazzi_asymptotic6 b hb e x \<longleftrightarrow> hb / ln x powr (1 + e :: real) < b/2"
definition "akra_bazzi_asymptotic7 b hb e x \<longleftrightarrow> hb / ln x powr (1 + e :: real) < (1 - b) / 2"
definition "akra_bazzi_asymptotic8 b hb e x \<longleftrightarrow> x*(1 - b - hb / ln x powr (1 + e :: real)) > 1"

definition "akra_bazzi_asymptotics b hb e p x \<longleftrightarrow>
  akra_bazzi_asymptotic1 b hb e p x \<and> akra_bazzi_asymptotic1' b hb e p x \<and>
  akra_bazzi_asymptotic2 b hb e p x \<and> akra_bazzi_asymptotic2' b hb e p x \<and>
  akra_bazzi_asymptotic3 e x \<and> akra_bazzi_asymptotic4 e x \<and> akra_bazzi_asymptotic5 b hb e x \<and>
  akra_bazzi_asymptotic6 b hb e x \<and> akra_bazzi_asymptotic7 b hb e x \<and>
  akra_bazzi_asymptotic8 b hb e x"

lemmas akra_bazzi_asymptotic_defs =
  akra_bazzi_asymptotic1_def akra_bazzi_asymptotic1'_def
  akra_bazzi_asymptotic2_def akra_bazzi_asymptotic2'_def akra_bazzi_asymptotic3_def
  akra_bazzi_asymptotic4_def akra_bazzi_asymptotic5_def akra_bazzi_asymptotic6_def
  akra_bazzi_asymptotic7_def akra_bazzi_asymptotic8_def akra_bazzi_asymptotics_def

lemma akra_bazzi_asymptotics:
  assumes "\<And>b. b \<in> set bs \<Longrightarrow> b \<in> {0<..<1}"
  assumes "hb > 0" "e > 0"
  shows "eventually (\<lambda>x. \<forall>b\<in>set bs. akra_bazzi_asymptotics b hb e p x) at_top"
proof (intro eventually_ball_finite ballI)
  fix b assume "b \<in> set bs"
  with assms interpret akra_bazzi_asymptotics_bep b e p hb by unfold_locales auto
  show "eventually (\<lambda>x. akra_bazzi_asymptotics b hb e p x) at_top"
    unfolding akra_bazzi_asymptotic_defs
    using asymptotics1[of "-c" for c] asymptotics2[of "-c" for c]
    by (intro eventually_conj asymptotics1 asymptotics2 asymptotics3
              asymptotics4 asymptotics5 asymptotics6 asymptotics7 asymptotics8) simp_all
qed simp

end


(*  Title:       General Algorithms for Iterators
    Author:      Thomas Tuerk <tuerk@in.tum.de>
    Maintainer:  Thomas Tuerk <tuerk@in.tum.de>
*)
header {* General Algorithms for Iterators over Finite Sets *}
theory SetIteratorCollectionsGA
imports
  "../spec/SetSpec"
  "../spec/MapSpec"
begin

subsection {* Iterate add to Set *}

definition iterate_add_to_set where
    "iterate_add_to_set s ins (it::('x,'x_set) set_iterator) =
     it (\<lambda>_. True) (\<lambda>x \<sigma>. ins x \<sigma>) s"

lemma iterate_add_to_set_correct :
assumes ins_OK: "set_ins \<alpha> invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "\<alpha> (iterate_add_to_set s ins it) = S0 \<union> \<alpha> s \<and> invar (iterate_add_to_set s ins it)"
unfolding iterate_add_to_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>S \<sigma>. \<alpha> \<sigma> = S \<union> \<alpha> s \<and> invar \<sigma>"])
apply (insert ins_OK s_OK)
apply (simp_all add: set_ins_def)
done

lemma iterate_add_to_set_dj_correct :
assumes ins_dj_OK: "set_ins_dj \<alpha> invar ins_dj"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
assumes dj: "S0 \<inter> \<alpha> s = {}"
shows "\<alpha> (iterate_add_to_set s ins_dj it) = S0 \<union> \<alpha> s \<and> invar (iterate_add_to_set s ins_dj it)"
unfolding iterate_add_to_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>S \<sigma>. \<alpha> \<sigma> = S \<union> \<alpha> s \<and> invar \<sigma>"])
apply (insert ins_dj_OK s_OK dj)
apply (simp_all add: set_ins_dj_def set_eq_iff)
done

subsection {* Iterator to Set *}

definition iterate_to_set where
    "iterate_to_set emp ins_dj (it::('x,'x_set) set_iterator) =
     iterate_add_to_set (emp ()) ins_dj it"

lemma iterate_to_set_alt_def[code] :
    "iterate_to_set emp ins_dj (it::('x,'x_set) set_iterator) =
     it (\<lambda>_. True) (\<lambda>x \<sigma>. ins_dj x \<sigma>) (emp ())"
unfolding iterate_to_set_def iterate_add_to_set_def by simp

lemma iterate_to_set_correct :
assumes ins_dj_OK: "set_ins_dj \<alpha> invar ins_dj"
assumes emp_OK: "set_empty \<alpha> invar emp"
assumes it: "set_iterator it S0"
shows "\<alpha> (iterate_to_set emp ins_dj it) = S0 \<and> invar (iterate_to_set emp ins_dj it)"
unfolding iterate_to_set_def
using iterate_add_to_set_dj_correct [OF ins_dj_OK _ it, of "emp ()"] emp_OK
by (simp add: set_empty_def)

subsection {* Iterate image/filter add to Set *}

text {* Iterators only visit element once. Therefore the image operations makes sense for
filters only if an injective function is used. However, when adding to a set using
non-injective functions is fine. *}

lemma iterate_image_filter_add_to_set_correct :
assumes ins_OK: "set_ins \<alpha> invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "\<alpha> (iterate_add_to_set s ins (set_iterator_image_filter f it)) =
          {b . \<exists>a. a \<in> S0 \<and> f a = Some b} \<union> \<alpha> s \<and>
       invar (iterate_add_to_set s ins  (set_iterator_image_filter f it))"
unfolding iterate_add_to_set_def set_iterator_image_filter_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>S \<sigma>. \<alpha> \<sigma> = {b . \<exists>a. a \<in> S \<and> f a = Some b} \<union> \<alpha> s \<and> invar \<sigma>"])
apply (insert ins_OK s_OK)
apply (simp_all add: set_ins_def split: option.split)
apply auto
done

lemma iterate_image_filter_to_set_correct :
assumes ins_OK: "set_ins \<alpha> invar ins"
assumes emp_OK: "set_empty \<alpha> invar emp"
assumes it: "set_iterator it S0"
shows "\<alpha> (iterate_to_set emp ins (set_iterator_image_filter f it)) =
          {b . \<exists>a. a \<in> S0 \<and> f a = Some b} \<and>
       invar (iterate_to_set emp ins  (set_iterator_image_filter f it))"
unfolding iterate_to_set_def
using iterate_image_filter_add_to_set_correct [OF ins_OK _ it, of "emp ()" f] emp_OK
by (simp add: set_empty_def)

text{* For completeness lets also consider injective versions. *}

lemma iterate_inj_image_filter_add_to_set_correct :
assumes ins_dj_OK: "set_ins_dj \<alpha> invar ins"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
assumes dj: "{y. \<exists>x. x \<in> S0 \<and> f x = Some y} \<inter> \<alpha> s = {}"
assumes f_inj_on: "inj_on f (S0 \<inter> dom f)"
shows "\<alpha> (iterate_add_to_set s ins (set_iterator_image_filter f it)) =
          {b . \<exists>a. a \<in> S0 \<and> f a = Some b} \<union> \<alpha> s \<and>
       invar (iterate_add_to_set s ins  (set_iterator_image_filter f it))"
proof -
  from set_iterator_image_filter_correct [OF it f_inj_on]
  have it_f: "set_iterator (set_iterator_image_filter f it)
        {y. \<exists>x. x \<in> S0 \<and> f x = Some y}" by simp

  from iterate_add_to_set_dj_correct [OF ins_dj_OK, OF s_OK it_f dj]
  show ?thesis by auto
qed

lemma iterate_inj_image_filter_to_set_correct :
assumes ins_OK: "set_ins_dj \<alpha> invar ins"
assumes emp_OK: "set_empty \<alpha> invar emp"
assumes it: "set_iterator it S0"
assumes f_inj_on: "inj_on f (S0 \<inter> dom f)"
shows "\<alpha> (iterate_to_set emp ins (set_iterator_image_filter f it)) =
          {b . \<exists>a. a \<in> S0 \<and> f a = Some b} \<and>
       invar (iterate_to_set emp ins  (set_iterator_image_filter f it))"
unfolding iterate_to_set_def
using iterate_inj_image_filter_add_to_set_correct [OF ins_OK _ it _ f_inj_on, of "emp ()"] emp_OK
by (simp add: set_empty_def)

subsection {* Iterate diff Set *}

definition iterate_diff_set where
    "iterate_diff_set s del (it::('x,'x_set) set_iterator) =
     it (\<lambda>_. True) (\<lambda>x \<sigma>. del x \<sigma>) s"

lemma iterate_diff_correct :
assumes del_OK: "set_delete \<alpha> invar del"
assumes s_OK: "invar s"
assumes it: "set_iterator it S0"
shows "\<alpha> (iterate_diff_set s del it) = \<alpha> s - S0 \<and> invar (iterate_diff_set s del it)"
unfolding iterate_diff_set_def
apply (rule set_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>S \<sigma>. \<alpha> \<sigma> = \<alpha> s - S \<and> invar \<sigma>"])
apply (insert del_OK s_OK)
apply (auto simp add: set_delete_def set_eq_iff)
done

subsection {* Iterate add to Map *}

definition iterate_add_to_map where
    "iterate_add_to_map m update (it::('k \<times> 'v,'kv_map) set_iterator) =
     it (\<lambda>_. True) (\<lambda>(k,v) \<sigma>. update k v \<sigma>) m"

lemma iterate_add_to_map_correct :
assumes upd_OK: "map_update \<alpha> invar upd"
assumes m_OK: "invar m"
assumes it: "map_iterator it M"
shows "\<alpha> (iterate_add_to_map m upd it) = \<alpha> m ++ M  \<and> invar (iterate_add_to_map m upd it)"
using assms
unfolding iterate_add_to_map_def
apply (rule_tac map_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>d \<sigma>. (\<alpha> \<sigma> = \<alpha> m ++ M |` d) \<and> invar \<sigma>"])
apply (simp_all add: map_update_def restrict_map_insert)
done

lemma iterate_add_to_map_dj_correct :
assumes upd_OK: "map_update_dj \<alpha> invar upd"
assumes m_OK: "invar m"
assumes it: "map_iterator it M"
assumes dj: "dom M \<inter> dom (\<alpha> m) = {}"
shows "\<alpha> (iterate_add_to_map m upd it) = \<alpha> m ++ M  \<and> invar (iterate_add_to_map m upd it)"
using assms
unfolding iterate_add_to_map_def
apply (rule_tac map_iterator_no_cond_rule_insert_P [OF it,
         where ?I="\<lambda>d \<sigma>. (\<alpha> \<sigma> = \<alpha> m ++ M |` d) \<and> invar \<sigma>"])
apply (simp_all add: map_update_dj_def restrict_map_insert set_eq_iff)
done

subsection {* Iterator to Map *}

definition iterate_to_map where
    "iterate_to_map emp upd_dj (it::('k \<times> 'v,'kv_map) set_iterator) =
     iterate_add_to_map (emp ()) upd_dj it"

lemma iterate_to_map_alt_def[code] :
    "iterate_to_map emp upd_dj it =
     it (\<lambda>_. True) (\<lambda>(k, v) \<sigma>. upd_dj k v \<sigma>) (emp ())"
unfolding iterate_to_map_def iterate_add_to_map_def by simp

lemma iterate_to_map_correct :
assumes upd_dj_OK: "map_update_dj \<alpha> invar upd_dj"
assumes emp_OK: "map_empty \<alpha> invar emp"
assumes it: "map_iterator it M"
shows "\<alpha> (iterate_to_map emp upd_dj it) = M \<and> invar (iterate_to_map emp upd_dj it)"
unfolding iterate_to_map_def
using iterate_add_to_map_dj_correct [OF upd_dj_OK _ it, of "emp ()"] emp_OK
by (simp add: map_empty_def)

end