theory PathInvariant
imports PathRel
begin

lemma mono_list :
  "push_popL (map snd lst) \<Longrightarrow>
   pathR (mono_rules iv) lst \<Longrightarrow>
   length lst > 0 \<Longrightarrow>
   monoI iv (hd lst) \<Longrightarrow>
   monoI iv (last lst)"
apply (induction "mono_rules iv" lst rule:pathR.induct)
apply (auto simp add:pathR.simps mono_works pathR2 pathR3 push_popL_def)
done

(* top rules *)
(* actually, the mono rules will hold *)
(* but sometime mono push and pop will only hold because
   they are part of call sequences
 *)

(*
mono_pop : because it is a call, and calls have the invariant

this rule has to be proven for each possible call into a contract
for the invariant to hold ...
*)
definition call_rule :: "('a \<Rightarrow> bool) \<Rightarrow> ('a * 'a list) list \<Rightarrow> bool" where
"call_rule iv lst = (
  call (map snd lst) \<longrightarrow> iv (fst (hd lst)) \<longrightarrow>
  iv (fst (last lst))
)"

definition call_out :: "'a list list \<Rightarrow> bool" where
"call_out lst = (
  push_popL lst \<and>
  length lst > 1 \<and>
  (last lst, hd lst) \<in> tlR \<and>
  (\<forall>x \<in> set lst. length x \<ge> length (hd lst))
)"

(*
for pushing, we need to ... well in theory the external call
 could break the invariant and then fix it
*)
definition call_out_rule :: "('a \<Rightarrow> bool) \<Rightarrow> ('a * 'a list) list \<Rightarrow> bool" where
"call_out_rule iv lst = (
  call_out (map snd lst) \<longrightarrow> iv (fst (hd lst)) \<longrightarrow>
  iv (fst (last lst))
)"

lemma mono_same_length :
   "(a,b) \<in> mono_same iv \<Longrightarrow>
    length (snd a) = length (snd b)"
  by (smt fst_conv mem_Collect_eq mono_same_def snd_conv)

lemma mono_pop_length :
   "(a,b) \<in> mono_pop iv \<Longrightarrow>
    length (snd a) = length (snd b) + 1"
  by (smt Suc_eq_plus1 fst_conv length_Cons mem_Collect_eq mono_pop_def snd_conv)

lemma mono_push_length :
   "(a,b) \<in> mono_push iv \<Longrightarrow>
    length (snd a) + 1 = length (snd b)"
  by (smt Int_iff One_nat_def add.right_neutral add_Suc_right fst_conv length_Cons mem_Collect_eq mono_push_def prod.sel(2))

lemma mono_is_push :
  "(a,b) \<in> mono_rules iv \<Longrightarrow>
   length (snd a) + 1 = length (snd b) \<Longrightarrow>
   (a, b) \<in> mono_push iv"
by (metis UnE less_add_same_cancel1 mono_pop_length mono_rules_def mono_same_length not_add_less1 zero_less_one)

lemma mono_is_pop :
  "(a,b) \<in> mono_rules iv \<Longrightarrow>
   length (snd a) = length (snd b) + 1 \<Longrightarrow>
   (a, b) \<in> mono_pop iv"
  by (metis UnE less_add_same_cancel1 mono_push_length mono_rules_def mono_same_length not_add_less1 zero_less_one)

lemma mono_is_same :
  "(a,b) \<in> mono_rules iv \<Longrightarrow>
   length (snd a) = length (snd b) \<Longrightarrow>
   (a, b) \<in> mono_same iv"
  by (metis UnE less_add_same_cancel1 mono_pop_length mono_push_length mono_rules_def not_add_less1 zero_less_one)

(* first the invariant is pushed into stack (second element). *)
lemma call_invariant_push :
  "call (map snd lst) \<Longrightarrow>
   monoI iv (hd lst) \<Longrightarrow>
   pathR (mono_rules iv) lst \<Longrightarrow>
   iv (fst (hd lst)) \<Longrightarrow>
   iv (hd (snd (lst!1)))"
apply (auto simp add:path_defs path_def
  call_def tlR_def)
apply (subgoal_tac "hd lst = lst!0")
apply auto
defer
  apply (metis hd_conv_nth list.size(3) not_numeral_less_zero)
apply (subgoal_tac "(lst!0, lst!1) \<in> mono_push iv")
apply (auto simp add:mono_push_def)[1]
apply (subgoal_tac "(lst!0, lst!1) \<in> mono_rules iv")
defer
  apply simp
apply (subgoal_tac "length (snd (lst!0)) + 1 = length (snd (lst!1))")
using mono_is_push [of "lst!0" "lst!1" iv]
  apply blast
  by (metis One_nat_def less_imp_Suc_add list.size(4) nth_map zero_less_Suc)

(* pushed element cannot change *)
lemma call_invariant_before_after :
  "call lst \<Longrightarrow>
   lst!1 = lst!(length lst-2)"
apply (subgoal_tac "length (lst!1) = length (lst!(length lst-2))")
using call_inside_big_idx [of lst "length lst-2"]
  apply (metis One_nat_def PathRel.take_all Suc_1 Suc_leI Suc_lessD call_def diff_less_mono2 lessI zero_less_diff)
using call_ncall [of lst]
  by (smt One_nat_def Suc_leI Suc_lessD call_def diff_less last_clip le_less length_map ncall_last nth_map numeral_2_eq_2 zero_less_diff zero_less_numeral)

lemma get_mono_inv :
  "monoI iv a \<Longrightarrow>
   length (snd a) > 0 \<Longrightarrow>
   iv (hd (snd a)) \<Longrightarrow>
   iv (fst a)"
  using hd_conv_nth monoI_def by fastforce

lemma ncall_first_step :
  "ncall lst \<Longrightarrow>
   lst!1 = lst!0 + 1"
by (simp add:ncall_def sucR_def)

lemma ncall_next :
  "ncall lst \<Longrightarrow>
   lst ! (length lst - 2) = lst!1"
  by (smt One_nat_def Suc_diff_Suc Suc_lessI diff_le_self last_clip less_eq_Suc_le ncall_def ncall_last numeral_2_eq_2 zero_less_diff)

lemma ncall_last_length :
  "ncall lst \<Longrightarrow>
   last lst + 1 = lst ! (length lst - 2)"
using ncall_stack_length ncall_next ncall_first_step
  by (metis gr_implies_not_zero hd_conv_nth list.size(3) ncall_def)

lemma call_last_length :
  "call lst \<Longrightarrow>
   length (last lst) + 1 =
   length (lst ! (length lst - 2))"
using ncall_stack_length call_ncall
  by (smt One_nat_def call_def diff_less last_index length_map ncall_last_length nth_map numeral_2_eq_2 order.strict_trans zero_less_Suc)

(* because the pushed element didn't change, current must have the
   invariant, and we can use the mono push rule *)
lemma call_mono_invariant :
  "call (map snd lst) \<Longrightarrow>
   monoI iv (hd lst) \<Longrightarrow>
   pathR (mono_rules iv) lst \<Longrightarrow>
   iv (fst (hd lst)) \<Longrightarrow>
   iv (fst (last lst))"
apply (subgoal_tac "monoI iv (lst ! (length lst-2))")
apply (subgoal_tac "iv (hd (snd (lst ! (length lst-2))))")
apply (subgoal_tac "(lst ! (length lst-2), last lst) \<in> mono_pop iv")
apply (subgoal_tac "iv (fst (lst ! (length lst-2)))")
  apply (smt fst_conv list.sel(1) mem_Collect_eq mono_pop_def snd_conv)
  apply (metis (no_types, hide_lams) Suc_eq_plus1 hd_conv_nth length_Cons list.sel(1) list.size(3) monoI_def mono_pop_length nat.simps(3) zero_less_Suc)
apply (subgoal_tac "(lst ! (length lst - 2), last lst) \<in> mono_rules iv")
apply (subgoal_tac "length (snd (last lst)) + 1 = length (snd (lst ! (length lst - 2)))")
  apply (smt UnE add_right_imp_eq mono_push_length mono_rules_def mono_same_length numeral_eq_iff numeral_plus_numeral numerals(1) semiring_norm(2) semiring_norm(6) semiring_norm(85) semiring_norm(87) semiring_normalization_rules(24) semiring_normalization_rules(25))
using call_last_length [of "map snd lst"]
apply simp
apply (subgoal_tac "lst \<noteq> []")
apply (simp add:last_map)
  using call_def apply force
apply (subgoal_tac "lst \<noteq> []")
apply (simp add:path_defs path_def last_conv_nth)
  apply (smt Nil_is_map_conv Nitpick.size_list_simp(2) One_nat_def Suc_diff_Suc call_def diff_less length_greater_0_conv length_tl less_trans_Suc map_tl not_less_less_Suc_eq numeral_2_eq_2 zero_less_numeral)
  using call_def apply force
apply (subgoal_tac "snd (lst ! 1) = snd (lst ! (length (map snd lst) - 2))")
using call_invariant_push [of lst iv]
apply simp
using call_invariant_before_after [of "map snd lst"]
apply simp
  apply (smt Nil_is_map_conv One_nat_def call_def diff_less length_greater_0_conv length_tl less_trans_Suc map_tl nth_map order.strict_trans zero_less_diff zero_less_numeral)
using mono_list [of "take (length lst - 1) lst" iv]
apply (auto simp add:call_def push_popL_def)
apply (subgoal_tac "lst \<noteq> []")
apply auto
apply (subgoal_tac
   "map snd (take (length lst - 1) lst) =
    take (length lst - 1) (map snd lst)")
defer
apply (simp add: take_map)
apply (auto simp add:pathR_take)
  by (metis One_nat_def Suc_1 Suc_diff_Suc Suc_lessD diff_Suc_less hd_take last_take)

lemma call_first_prev :
"call_end lst (last lst) \<Longrightarrow>
 last (take (length lst - Suc 0) lst) = lst!0"
  by (smt Nitpick.size_list_simp(2) One_nat_def Suc_diff_Suc call_end_def diff_Suc_Suc diff_less first_one_smaller_prev last_take length_tl less_numeral_extra(2) zero_less_Suc)

lemma decompose_call_end :
  "call_end lst (last lst) \<Longrightarrow>
   x \<in> set (indexSplit (findIndices (take (length lst-1) lst) (lst!0))
             (take (length lst-1) lst)) \<Longrightarrow>
   call_end x (lst!0) \<or> const_seq x (lst!0)"
using correct_pieces [of "take (length lst-1) lst" x]
apply simp
apply (subgoal_tac "inc_decL (take (length lst - 1) lst)")
defer
apply (simp add:pathR_take call_end_def inc_decL_def)
apply simp
apply (subgoal_tac "lst \<noteq> [] \<and> 1 < length lst")
defer
apply (simp add:call_end_def)
  using less_nat_zero_code apply auto[1]
apply clarsimp
apply (subgoal_tac "hd (take (length lst - Suc 0) lst) = lst!0")
defer
  apply (simp add: hd_conv_nth)
apply simp
apply (subgoal_tac "last (take (length lst - Suc 0) lst) = lst!0")
defer
using call_first_prev apply fastforce
apply (simp add:split_def)
  by (metis One_nat_def call_end_def first_smaller1 first_smaller_before)

lemma decompose_call_end_index :
  "call_end lst (last lst) \<Longrightarrow>
   \<exists>ilst. (\<forall>x \<in> set (indexSplit ilst (take (length lst-1) lst)).
   call_end x (lst!0) \<or> const_seq x (lst!0))"
apply (rule exI[where x =
   "findIndices (take (length lst-1) lst) (lst!0)"])
using decompose_call_end apply fastforce
done

lemma call_e_end :
"call_e lst (last lst) \<Longrightarrow>
 call_end (map length lst) (last (map length lst))"
  using call_end1 call_end_last by fastforce

lemma call_e_pathR:
"call_e lst (last lst) \<Longrightarrow> pathR push_pop lst"
by (simp add:call_e_def push_popL_def)

(*
lemma call_end_inside_big_idx :
"call_end lst (last lst) \<Longrightarrow>
 j < length lst - 1 \<Longrightarrow>
 lst ! 0 \<le> lst ! j"
*)

lemma call_end_inside_big :
"call_end lst (last lst) \<Longrightarrow>
 x \<in> set (take (length lst - 1) lst) \<Longrightarrow>
 lst ! 0 \<le> x"
using first_smaller1 [of "lst" "length lst - 1"]
using first_smaller_before [of "length lst -1" "lst" x]
by (auto simp add:call_end_def sucR_def)

lemma call_e_inside_big_idx :
"call_e lst (last lst) \<Longrightarrow>
 j < length lst - 1 \<Longrightarrow>
 takeLast (length (lst!0)) (lst!j) = lst ! 0"
using stack_unchanged [of "take (Suc j) lst"
   "length (lst!0)"]
apply simp
apply (cases "push_popL (take (Suc j) lst)")
defer
apply (simp add:call_e_def push_popL_def pathR_take)
apply (cases "take (Suc j) lst = []")
apply (simp add:clip_def call_e_def)

apply (simp add:last_take hd_take)
apply (subgoal_tac "\<forall>sti\<in>set (take (Suc j)lst).
        length (lst ! 0) \<le> length sti")
apply auto
  apply (simp add: hd_conv_nth)

subgoal for sti
using call_end_inside_big [of "map length lst" "length sti"]
apply (simp add:call_e_end)
apply (cases "length sti
     \<in> set (take (length (map length lst) - 1) (map length lst))")
apply auto
  apply (simp add: clip_def drop_map take_map)
  by (meson Suc_leI image_eqI set_take_subset_set_take subset_code(1))
done

lemma call_e_inside_big :
 "call_e lst (last lst) \<Longrightarrow>
  a \<in> set (take (length lst - 1) lst) \<Longrightarrow>
  takeLast (length (lst ! 0)) a = lst ! 0"
using ex_idx [of a "take (length lst - 1) lst"]
by (auto simp add: call_e_inside_big_idx)

(* decompose call_e into smaller pieces ... should follow from
   above similarly to call decomposition *)
lemma decompose_call_e_index :
  "call_e lst (last lst) \<Longrightarrow>
   \<exists>ilst. (\<forall>x \<in> set (indexSplit ilst (take (length lst-1) lst)).
   call_e x (lst!0) \<or> const_seq x (lst!0))"
using decompose_call_end_index [of "map length lst"]
      call_e_end [of lst]
apply auto
subgoal for ilst
apply (rule exI[where x=ilst])
apply clarsimp
(* because internally the stack is high,
   it should not change *)
apply (case_tac "const_seq (map length x) (map length lst ! 0) \<or>
    call_end (map length x) (map length lst ! 0)")
defer
subgoal for x
using index_split_map [of x ilst "take (length lst - 1) lst" length]
apply (simp add:take_map drop_map)
apply force
done
subgoal for x
using pathR_split [of "push_pop"
   "take (length lst - 1) lst" x ilst]
  pathR_take [of "push_pop" lst "length lst-1"]
  call_e_pathR [of lst]
apply simp

apply auto
subgoal (* constant *)
using const_seq_convert [of x "map length lst ! 0"]
apply (auto simp add:push_popL_def)
apply (cases x)
using const_seq_empty apply force
subgoal for xa a list
apply (simp add:map_nth)
using const_seq_eq [of a list xa]
apply simp
apply (subgoal_tac "a \<in> set (take (length lst - 1) lst)")
defer
using in_index_split apply fastforce
apply (subgoal_tac "lst ! 0 = a")
apply auto

using call_e_inside_big [of lst a]
  by (metis One_nat_def PathRel.take_all const_seq_eq length_greater_0_conv length_pos_if_in_set nth_map take_eq_Nil)
done
apply (rule call_end2)
  apply (clarsimp simp add: call_e_def)
  apply (metis Suc_lessD nth_map)

  using push_popL_def apply blast
using call_end_last [of "map length x" "length (lst ! 0)"]
using call_e_inside_big [of lst "last x"]
apply simp
apply (subgoal_tac "map length lst ! 0 = length (lst!0)")
defer
apply (simp add:call_e_def)
  using Suc_lessD nth_map apply blast
apply simp
apply (subgoal_tac "last x \<in> set (take (length lst - 1) lst)")
defer
apply (rule in_index_split [of x ilst "take (length lst-1) lst"
  "last x"])
apply auto
apply (simp add:call_end_def)
  apply (metis One_nat_def Suc_lessD diff_Suc_less gr_implies_not_zero in_set_conv_nth last_conv_nth length_0_conv)
apply (subgoal_tac "length (last x) = length (lst!0)")
  apply (metis PathRel.take_all)
apply (simp add:call_end_def)
  by (metis Suc_lessD last_map length_greater_0_conv)
done done

lemma decompose_call_e :
  "call_e lst (last lst) \<Longrightarrow>
  ilst = findIndices
             (take (length lst - Suc 0)
               (map length lst))
             (map length lst ! 0) \<Longrightarrow>
   x \<in> set (indexSplit ilst (take (length lst-1) lst)) \<Longrightarrow>
   call_e x (lst!0) \<or> const_seq x (lst!0)"
using decompose_call_end [of "map length lst" "map length x"]
      call_e_end [of lst]
apply auto
apply (case_tac "const_seq (map length x) (map length lst ! 0) \<or>
    call_end (map length x) (map length lst ! 0)")
defer
using index_split_map [of x ilst "take (length lst - 1) lst" length]
apply (simp add:take_map drop_map)
using pathR_split [of "push_pop"
   "take (length lst - 1) lst" x ilst]
  pathR_take [of "push_pop" lst "length lst-1"]
  call_e_pathR [of lst]
apply simp

apply auto
subgoal (* constant *)
using const_seq_convert [of x "map length lst ! 0"]
apply (auto simp add:push_popL_def)
apply (cases x)
using const_seq_empty apply force
subgoal for xa a list
apply (simp add:map_nth)
using const_seq_eq [of a list xa]
apply simp
apply (subgoal_tac "a \<in> set (take (length lst - 1) lst)")
defer
using in_index_split apply fastforce
apply (subgoal_tac "lst ! 0 = a")
apply auto

using call_e_inside_big [of lst a]
  by (metis One_nat_def PathRel.take_all const_seq_eq length_greater_0_conv length_pos_if_in_set nth_map take_eq_Nil)
done
apply (rule call_end2)
  apply (clarsimp simp add: call_e_def)
  apply (metis Suc_lessD nth_map)

  using push_popL_def apply blast
using call_end_last [of "map length x" "length (lst ! 0)"]
using call_e_inside_big [of lst "last x"]
apply simp
apply (subgoal_tac "map length lst ! 0 = length (lst!0)")
defer
apply (simp add:call_e_def)
  using Suc_lessD nth_map apply blast
apply simp
apply (subgoal_tac "last x \<in> set (take (length lst - 1) lst)")
defer
apply (rule in_index_split [of x ilst "take (length lst-1) lst"
  "last x"])
apply auto
apply (simp add:call_end_def)
  apply (metis One_nat_def Suc_lessD diff_Suc_less gr_implies_not_zero in_set_conv_nth last_conv_nth length_0_conv)
apply (subgoal_tac "length (last x) = length (lst!0)")
  apply (metis PathRel.take_all)
apply (simp add:call_end_def)
by (metis Suc_lessD last_map length_greater_0_conv)

definition psublists :: "'a list \<Rightarrow> 'a list set" where
"psublists lst = {take l (drop i lst) | l i. l < length lst}"

definition callout_rel :: "('a * 'a list \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> ('a * 'a list) rel" where
"callout_rel iv level =
    {(a,b) | a b. length (snd a) = level \<and> length (snd b) = level + 1 \<and> (iv a \<longrightarrow> iv b) }
  \<union> {(a,b) | a b. length (snd a) \<noteq> level \<or> length (snd b) \<noteq> level + 1}"

definition split_no_empty :: "nat list \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
"split_no_empty ilst lst = filter (%lst. lst \<noteq> []) (indexSplit ilst lst)"

lemma concat_filter : "concat (filter (%lst. lst \<noteq> []) lst) = concat lst"
by (induction lst; auto)

definition pieces :: "'a list list \<Rightarrow> 'a list list list" where
"pieces lst =
  split_no_empty
     (findIndices (take (length lst - 1) (map length lst))
             (map length lst ! 0)) (take (length lst-1) lst)"

lemma call_e_from_pieces :
  "call_e lst x \<Longrightarrow>
   concat (pieces lst) = take (length lst-1) lst"
apply (simp add:call_e_def pieces_def split_no_empty_def
  concat_filter)
using split_and_combine2 [of "findIndices
         (take (length lst - Suc 0)
           (map length lst))
         (map length lst ! 0)" "take (length lst-1) lst"]
  by simp

lemma call_e_has_pieces :
  "call_e lst x \<Longrightarrow> length (pieces lst) > 0"
apply (cases "length (concat (pieces lst)) = 0")
using call_e_from_pieces [of lst x]
apply (auto simp add:call_e_def)
  by (metis diff_is_0_eq not_less take_eq_Nil)

lemma decompose_call_e_no_empty :
  "call_e lst (last lst) \<Longrightarrow>
   x \<in> set (pieces lst) \<Longrightarrow>
   call_e x (lst!0) \<or> const_seq x (lst!0)"
using decompose_call_e [of lst
   "(findIndices (take (length lst - 1) (map length lst)) (map length lst ! 0))" x]
by (auto simp:split_no_empty_def pieces_def)

lemma call_e_final : "call_e lst x \<Longrightarrow> last lst = x"
apply (auto simp add : call_e_def first_return_def first_def tlR_def)
  by (metis One_nat_def Suc_lessD last_conv_nth length_greater_0_conv)

lemma no_empty_pieces : "[] \<notin> set (pieces lst)"
by (simp add: pieces_def split_no_empty_def)

lemma piece_last :
   "call_e lst (last lst) \<Longrightarrow>
    b \<in> set (pieces lst) \<Longrightarrow>
    last b = lst!0"
using decompose_call_e_no_empty [of lst b]
apply auto
using call_e_final apply force
apply (cases "b = []")
using no_empty_pieces apply fastforce
apply (simp add:const_seq_def)
  using last_in_set by blast

lemma drop_concat_aux :
 "b \<noteq> [] \<Longrightarrow>
  lst = concat (a#b#rest) @ [x] \<Longrightarrow>
  last b # concat rest @ [x] =
    drop (length a + length b - 1) lst"
apply (subgoal_tac "drop (length a + length b - Suc 0) a = []")
apply (auto)
  apply (smt Suc_leI append_butlast_last_id append_eq_append_conv append_take_drop_id diff_diff_cancel length_Cons length_drop length_greater_0_conv list.size(3))
  by (metis Suc_leI length_greater_0_conv ordered_cancel_comm_monoid_diff_class.le_add_diff semiring_normalization_rules(24))

lemma drop_concat_aux2 :
  "a # b # rest = pieces lst \<Longrightarrow>
   call_e lst (last lst) \<Longrightarrow>
   last b # concat rest @ [last lst] = drop (length a + length b - 1) lst"
apply (rule drop_concat_aux)
  apply (metis list.set_intros(1) list.set_intros(2) no_empty_pieces)
using call_e_from_pieces [of lst "last lst"]
  by (metis (no_types, lifting) Nil_is_append_conv append_butlast_last_id butlast_conv_take concat.simps(2) list.set_intros(1) no_empty_pieces take_eq_Nil)

lemma first_return_drop :
  "first_return (length lst - 1) lst \<Longrightarrow>
   length lst > 0 \<Longrightarrow>
   length (drop x lst) > 0 \<Longrightarrow>
   hd lst = hd (drop x lst) \<Longrightarrow>
   first_return (length (drop x lst) - 1) (drop x lst)"
by (simp add:first_return_def first_def)

(* take away a piece, have new call_e *)
lemma take_piece :
  "call_e lst (last lst) \<Longrightarrow>
   a # b # rest = pieces lst \<Longrightarrow>
   call_e ([last b]@concat rest@[last lst]) (last lst)"
apply (auto simp add: call_e_def)
using piece_last [of lst b]
  apply (metis One_nat_def Suc_lessD call_e_def hd_conv_nth length_greater_0_conv list.set_intros(1) list.set_intros(2))
apply (subgoal_tac
   "last b # concat rest @ [last lst] = drop (length a + length b - 1) lst")
apply (simp add:push_popL_def pathR_drop)
using drop_concat_aux2 [of a b rest lst]
  apply (simp add: call_e_def)

apply (subgoal_tac
   "last b # concat rest @ [last lst] = drop (length a + length b - 1) lst")
using first_return_drop [of lst "length a + length b - 1"]
apply simp
apply (subgoal_tac "lst \<noteq> []")
apply (subgoal_tac "length a + length b - 1 < length lst")
apply (subgoal_tac "hd (drop (length a + length b - Suc 0)
          lst) = last b")
apply (subgoal_tac "Suc (length (concat rest)) = length lst -
       Suc (length a + length b - Suc 0)")
apply simp
apply (subgoal_tac "call_e lst (last lst)")
using piece_last [of lst b]
  apply (metis hd_conv_nth list.set_intros(1) list.set_intros(2))
  apply (simp add: call_e_def)
  apply (metis One_nat_def Suc_diff_Suc length_Cons length_append_singleton length_drop nat.inject)
  apply (metis list.sel(1))
  apply (metis One_nat_def length_drop length_greater_0_conv list.distinct(1) zero_less_diff)
  apply (metis One_nat_def less_numeral_extra(2) list.size(3))
using drop_concat_aux2 [of a b rest lst]
  apply (simp add: call_e_def)
done

lemma combine_call_pieces :
   "concat (call_pieces lst) = clip (length lst-2) 1 lst"
apply (simp add:call_pieces_def)
  by (simp add: split_and_combine2)

lemma tlr_anti : "(a,b) \<in> tlR \<Longrightarrow> (b,a) \<in> tlR \<Longrightarrow> False"
unfolding tlR_def by auto

lemma tlr_anti_ref : "(a,a) \<in> tlR \<Longrightarrow> False"
unfolding tlR_def by auto

lemma first_call_piece :
  "call lst \<Longrightarrow>
   x \<in> set (call_pieces lst) \<Longrightarrow>
   call_e x (lst!1) \<Longrightarrow>
   x = take i (drop j lst) \<Longrightarrow>
   j > 1"
apply (subgoal_tac "length x > 0")
apply (subgoal_tac "i \<ge> length x")
apply (subgoal_tac "(x!0, lst!1) \<in> tlR")
using combine_call_pieces [of lst]
apply (simp add:clip_def)
apply (cases "j = 0")
apply (subgoal_tac "x!0 = lst!0")
apply (clarsimp simp:call_def)
using tlr_anti apply fastforce
  apply simp
apply (cases "j = 1")
apply (subgoal_tac "x!0 = lst!1")
apply (clarsimp simp:call_def)
using tlr_anti_ref apply fastforce
  apply simp
  apply linarith
apply (clarsimp simp:call_e_def)
  apply (metis append_take_drop_id gr_implies_not0 hd_append2 hd_drop_conv_nth take_eq_Nil)
  apply (simp )
apply (clarsimp simp:call_e_def)
  by linarith

lemma call_e_call :
   "call_e (tl lst) (last lst) \<Longrightarrow>
    hd lst = last lst \<Longrightarrow> call lst"
apply (auto simp add:call_e_def call_def)
  apply (metis One_nat_def Suc_lessD hd_conv_nth length_greater_0_conv length_tl nth_tl zero_less_diff)
apply (simp add:push_popL_def)
apply (case_tac lst)
  apply simp
apply simp
apply (case_tac list)
apply simp
apply simp
  apply (simp add: pathR.simps(1) push_pop_def)
  by (simp add: numeral_2_eq_2)

lemma take_tl :
"j > 0 \<Longrightarrow>
 take i (drop j lst) = tl (take (i+1) (drop (j-1) lst))"
by (metis One_nat_def Suc_pred diff_add_inverse2 drop_Suc tl_drop tl_take)

lemma hd_drop :
"length (drop (j-1) lst) > 0 \<Longrightarrow>
 j > 0 \<Longrightarrow>
 hd (drop (j-1) lst) = lst ! (j-1)"
  by (simp add: hd_drop_conv_nth)

fun concat_index :: "'a list list \<Rightarrow> nat \<Rightarrow> nat" where
  "concat_index [] x = 1"
| "concat_index (a#rest) x =
    (if x < length a then 0
     else 1 + concat_index rest (x-length a))"

lemma concat_index_good :
   "x < length (concat lst) \<Longrightarrow>
    concat_index lst x < length lst"
by (induction lst x rule:concat_index.induct; auto)

lemma find_piece1 :
   "x < length (concat ps) \<Longrightarrow>
    length (concat (take (concat_index ps x) ps)) \<le> x"
apply (induction ps x rule:concat_index.induct; auto)
  by linarith

lemma find_piece2 :
   "x < length (concat ps) \<Longrightarrow>
    length (concat (take (concat_index ps x + 1) ps)) > x"
apply (induction ps x rule:concat_index.induct; auto)
  by linarith

(*
lemma piece_from_set :
   "take i (drop j (concat ps)) \<in> set ps \<Longrightarrow>
    length (take i (drop j (concat ps))) > 0 \<Longrightarrow>
    ps ! concat_index ps j = (take i (drop j (concat ps)))"
*)

fun is_piece_at :: "'a list \<Rightarrow> 'a list list \<Rightarrow> nat \<Rightarrow> bool" where
  "is_piece_at x [] idx = False"
| "is_piece_at x (a#rest) idx =
    ((idx = 0 \<and> x = a) \<or>
     (is_piece_at x rest (idx-length a)) \<and> length a \<le> idx)"

(*
fun is_piece_at :: "'a list \<Rightarrow> 'a list list \<Rightarrow> nat \<Rightarrow> bool" where
  "is_piece_at x [] idx = False"
| "is_piece_at x (a#rest) idx =
    ((idx = 0 \<and> x = a) \<or>
     (is_piece_at x rest (idx-length a)) \<and> length a < idx)"
*)

lemma piece_first :
   "length x > 0 \<Longrightarrow>
    is_piece_at x ps j \<Longrightarrow>
    x!0 = concat ps ! j"
by (induction x ps j rule:is_piece_at.induct;
        auto simp add: nth_append)

lemma first_piece2 :
  "call lst \<Longrightarrow>
   is_piece_at x (call_pieces lst) j \<Longrightarrow>
   call_e x (lst!1) \<Longrightarrow>
   j > 0"
apply (subgoal_tac "length x > 0")
apply (subgoal_tac "(x!0, lst!1) \<in> tlR")
using combine_call_pieces [of lst]
apply (simp add:clip_def)
apply (cases "j = 0")
apply (subgoal_tac "x!0 = lst!1")
apply (clarsimp simp:call_def)
using tlr_anti_ref apply fastforce
using piece_first [of x "call_pieces lst" j]
  apply (metis Nitpick.size_list_simp(2) One_nat_def Suc_leI add.right_neutral call_invariant_before_after drop_Nil length_drop list.size(3) nth_drop nth_take zero_less_Suc)
  apply blast
by (auto simp:call_e_def hd_conv_nth)

fun is_piece_last :: "'a list \<Rightarrow> 'a list list \<Rightarrow> nat \<Rightarrow> bool" where
  "is_piece_last x [] idx = False"
| "is_piece_last x (a#rest) idx =
    ((idx = length a - 1 \<and> x = a) \<or>
     (is_piece_last x rest (idx-length a)) \<and> length a < idx)"

fun is_piece_adj :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list \<Rightarrow> nat \<Rightarrow> bool" where
  "is_piece_adj y x [] idx = False"
| "is_piece_adj y x [a] idx = False"
| "is_piece_adj y x (a#b#rest) idx =
    ((Suc idx = length a \<and> y = a \<and> x = b \<and>
      length b > 0) \<or>
     (is_piece_adj y x rest (idx-length a)) \<and> length a < idx)"

lemma piece_at_concat_index :
   "length x > 0 \<Longrightarrow>
    is_piece_at x lst i \<Longrightarrow>
    x = lst ! concat_index lst i"
by (induction x lst i rule:is_piece_at.induct; auto)

lemma piece_last_concat_index :
   "length x > 0 \<Longrightarrow>
    is_piece_last x lst i \<Longrightarrow>
    x = lst ! concat_index lst i"
by (induction lst i arbitrary:x rule:concat_index.induct; auto)

lemma piece_at_concat_index_smaller :
   "length x > 0 \<Longrightarrow>
    i > 0 \<Longrightarrow>
    is_piece_at x lst i \<Longrightarrow>
    concat_index lst (i-1) < concat_index lst i"
by (induction x lst i rule:is_piece_at.induct; auto)

lemma piece_at_concat_index_gt0 :
   "length x > 0 \<Longrightarrow>
    i > 0 \<Longrightarrow>
    is_piece_at x lst i \<Longrightarrow>
    0 < concat_index lst i"
by (induction x lst i rule:is_piece_at.induct; auto)

lemma exists_piece_at :
   "x \<in> set lst \<Longrightarrow>
    length x > 0 \<Longrightarrow>
    \<exists>j. is_piece_at x lst j"
apply (induction lst ; auto)
apply (case_tac "x = a")
  apply auto
subgoal for a lst xa
apply (rule exI[where x = "xa + length a"])
apply simp
done
done

lemma piece_at_concat_length :
   "length x > 0 \<Longrightarrow>
    i > 0 \<Longrightarrow>
    is_piece_at x lst i \<Longrightarrow>
    length (concat (take (concat_index lst i) lst)) = i"
apply (induction lst arbitrary:i; auto)
apply (case_tac "length a = i"; auto)
  using find_piece1 in_set_takeD by force

lemma concat_find_last :
  "length (concat lst) > 0 \<Longrightarrow>
   \<exists>l \<in> set lst - {[]}. last l = last (concat lst)"
apply (induction lst; auto)
  using Nil_eq_concat_conv apply fastforce
  by (metis (no_types, lifting) DiffD1 DiffD2 DiffI Nil_eq_concat_conv insert_iff last_appendR)

lemma call_piece_last :
  "call lst \<Longrightarrow>
   l \<in> set (call_pieces lst) \<Longrightarrow>
   l \<noteq> [] \<Longrightarrow>
   last l = lst!1"
using decompose_call_pieces [of lst l]
apply simp
apply (cases "call_e l (lst ! Suc 0)")
apply auto
  apply (simp add: call_e_final)
apply (simp add:const_seq_def)
  using last_in_set by blast

lemma take_aux :
"length lst > 2 \<Longrightarrow>
 j > 0 \<Longrightarrow>
 j < length lst - 1 \<Longrightarrow>
 lst ! j =
 take (Suc (length lst - 3)) (drop (Suc 0) lst) !
    (j - Suc 0)"
  by (smt One_nat_def Suc_1 Suc_diff_1 Suc_diff_Suc Suc_lessD Suc_less_eq drop_0 drop_Suc length_tl nth_take nth_tl numeral_3_eq_3)

(*
  by (metis (no_types, lifting) Suc_diff_Suc Suc_leI Suc_lessD Suc_pred le_add_diff_inverse less_SucI nth_drop nth_take numeral_2_eq_2 numeral_3_eq_3)
*)

lemma concat_helper :
"j < length (concat (take n lst)) \<Longrightarrow>
 concat (take n lst) ! j =  concat lst ! j"
apply (induction lst arbitrary:j n; auto)
apply (case_tac n; auto)
apply (case_tac "j < length a")
  apply (simp add: nth_append)
  apply (simp add: nth_append)
done

lemma length_concat_take :
  "length (concat (take n lst)) \<le> length (concat lst)"
apply (induction lst arbitrary:n; auto)
by (case_tac n; auto)

lemma extend_call_pieces :
  "call lst \<Longrightarrow>
   is_piece_at x (call_pieces lst) j \<Longrightarrow>
   call_e x (lst!1) \<Longrightarrow>
   call (lst!j # x)"
apply (subgoal_tac "j > 0")
defer
using first_piece2 apply fastforce
apply (rule call_e_call)
apply (cases "x = []")
apply (simp add:call_e_def)
apply clarsimp
  apply (simp add: call_e_final)
apply clarsimp
using piece_at_concat_length [of x j "call_pieces lst"]
apply simp
apply (subgoal_tac
  "lst!j = concat
       (take (concat_index (call_pieces lst) j)
         (call_pieces lst)) ! (j-1)")
apply (subgoal_tac "last x = lst!1")
apply simp
using concat_find_last
 [of "(take (concat_index (call_pieces lst) j)
         (call_pieces lst))"]
apply clarsimp
apply (subgoal_tac "l \<in> set (call_pieces lst)")
subgoal for l
using call_piece_last [of l lst]
  by (metis One_nat_def call_piece_last last_index)
  apply (meson in_set_takeD)
  apply (simp add: call_e_final)
apply (subgoal_tac "concat
     (take (concat_index (call_pieces lst) j)
       (call_pieces lst)) !
    (j - 1) = concat (call_pieces lst) ! (j-1)")
apply simp
using combine_call_pieces [of lst]
apply (simp add:clip_def)
apply (rule take_aux)
apply (simp add:call_def)
apply simp
defer
apply (rule concat_helper)
apply simp
apply (subgoal_tac "length
     (concat
       (take (concat_index (call_pieces lst) j)
         (call_pieces lst))) < length lst - 1")
apply simp
apply (subgoal_tac "length
     (concat (call_pieces lst)) < length lst - 1")
using length_concat_take [of
   "(concat_index (call_pieces lst) j)"
   "(call_pieces lst)"]
  apply linarith
apply (clarsimp simp add:call_def)
  by linarith

(*
definition call_inv2 :: "('a * 'a list \<Rightarrow> bool) \<Rightarrow> ('a * 'a list) list \<Rightarrow> bool" where
"call_inv2 iv l =
   (call_e (map snd l) (snd (last l)) \<longrightarrow> iv (hd l) \<longrightarrow> iv (last l))"

definition call_inv :: "('a * 'a list \<Rightarrow> bool) \<Rightarrow> ('a * 'a list) list \<Rightarrow> bool" where
"call_inv iv l = (call (map snd l) \<longrightarrow> iv (hd l) \<longrightarrow> iv (last l))"

definition stay_rel :: "('a * 'a list \<Rightarrow> bool) \<Rightarrow> ('a * 'a list) rel" where
"stay_rel iv =
  {(a,b) | a b. length (snd a) = length (snd b) \<and> (iv a \<longrightarrow> iv b) }
\<union> {(a,b) | a b. length (snd a) \<noteq> length (snd b)}"
*)

(*
definition pcs :: "'a list list \<Rightarrow> 'a list list list" where
"pcs lst = filter (%x. x \<noteq> []) (call_pieces lst)"
*)

definition pcs :: "('b * 'a list) list \<Rightarrow> ('b * 'a list) list list" where
"pcs lst = filter (%x. x \<noteq> [])
   (let ilst = findIndices
       (clip (length lst-2) 1 (map (length \<circ> snd) lst))
       (length (snd (lst!1))) in
   indexSplit ilst (clip (length lst-2) 1 lst))"

lemma pcs_call_pieces :
   "a \<in> set (pcs lst) \<Longrightarrow>
    length lst > 1 \<Longrightarrow>
    map snd a \<in> set (call_pieces (map snd lst))"
by (simp add:pcs_def call_pieces_def clip_def
    drop_map index_split_map take_map)

(* perhaps there could be some kind of driver
   that generates a good induction principle
   *)

lemma get_last_gen :
"j < length ps \<Longrightarrow>
 [] \<notin> set ps \<Longrightarrow>
 concat ps ! (length (concat (take (Suc j) ps)) - 1) =
 last (ps ! j)"
apply (induction ps arbitrary:j; auto)
apply (case_tac j; auto)
  apply (simp add: last_conv_nth nth_append)
apply (case_tac ps; auto)
  by (metis Nat.add_diff_assoc Suc_leI add_gr_0 length_greater_0_conv nth_append_length_plus)

lemma pcs_not_empty :
"[] \<notin> set (pcs lst)"
by (auto simp add:pcs_def)

lemma combine_pcs :
   "concat (pcs lst) = clip (length lst-2) 1 lst"
by (simp add: pcs_def concat_filter split_and_combine2)

lemma clip_nth :
"length lst > 2 \<Longrightarrow>
 j > 0 \<Longrightarrow>
 j < length lst-1 \<Longrightarrow>
 clip (length lst - 2) 1 lst ! (j-1) = lst ! j"
by (simp add:clip_def)

lemma has_pieces :
"length lst > 2 \<Longrightarrow>
 length (pcs lst) > 0"
apply (case_tac lst)
apply (auto simp: pcs_def call_pieces_def clip_def)
apply (case_tac list)
apply (auto simp: pcs_def call_pieces_def clip_def)
apply (case_tac lista)
apply (auto simp: pcs_def call_pieces_def clip_def)
done

lemma has_piece :
"length lst > 2 \<Longrightarrow>
 \<exists>xs\<in>set (take (Suc j) (pcs lst)). xs \<noteq> []"
apply (cases "pcs lst")
using has_pieces apply force
  by (metis list.set_intros(1) pcs_not_empty take_Suc_Cons)

lemma concat_pcs_length :
  "length lst > 2 \<Longrightarrow>
   length (concat (pcs lst)) = length lst - 2"
by (simp add:combine_pcs clip_def)

lemma get_last :
"length lst > 2 \<Longrightarrow>
 j < length (pcs lst) \<Longrightarrow>
 lst ! length (concat (take (Suc j) (pcs lst))) = last (pcs lst ! j)"
using get_last_gen [of j "pcs lst"]
apply (simp add:pcs_not_empty combine_pcs)
using clip_nth [of lst "length (concat (take (Suc j) (pcs lst)))"]
apply (simp add:has_piece)
using concat_pcs_length [of lst]
apply simp
  by (metis One_nat_def Suc_pred diff_Suc_eq_diff_pred gr_zeroI le_imp_less_Suc length_concat_take less_diff_conv less_numeral_extra(2) numeral_2_eq_2 one_add_one)

lemma get_first_gen :
"j < length ps \<Longrightarrow>
 [] \<notin> set ps \<Longrightarrow>
 concat ps ! length (concat (take j ps)) = hd (ps ! j)"
by (induction ps arbitrary:j; case_tac j; auto simp add: hd_conv_nth nth_append)

lemma calc_len :
"length lst > 2 \<Longrightarrow>
 length (take (Suc (length lst - 3)) (drop (Suc 0) lst)) = length lst - 2"
  by (simp add: Suc_diff_Suc numeral_2_eq_2 numeral_3_eq_3)

lemma len_con_take :
 "length (concat (take j lst)) =
  length (concat lst) - length (concat (drop j lst))"
apply (induction lst arbitrary:j; auto)
apply (case_tac j)
apply auto
  by (metis (no_types, lifting) add.left_neutral append_take_drop_id concat_append diff_is_0_eq' eq_iff length_append linear ordered_cancel_comm_monoid_diff_class.add_diff_assoc)

lemma concat_mem_length :
"l \<in> set lst \<Longrightarrow> length l \<le> length (concat lst)"
by (induction lst; auto)

lemma get_first :
"length lst > 2 \<Longrightarrow>
 j < length (pcs lst) \<Longrightarrow>
 lst ! (length (concat (take j (pcs lst))) + 1) = hd (pcs lst ! j)"
using get_first_gen [of j "pcs lst"]
apply (simp add:pcs_not_empty combine_pcs)
using concat_pcs_length [of lst]
apply (simp add:clip_def)
apply (subgoal_tac "take (Suc (length lst - 3))
     (drop (Suc 0) lst) !
    length (concat (take j (pcs lst))) = lst !
    Suc
     (length
       (concat (take j (pcs lst))))")
apply simp
apply (subgoal_tac "length (concat (take j (pcs lst))) <
  length (take (Suc (length lst - 3))
     (drop (Suc 0) lst))")
  apply (smt Suc_diff_Suc Suc_eq_plus1 Suc_mono clip_def combine_pcs diff_Suc_1 less_trans_Suc numeral_1_eq_Suc_0 numeral_2_eq_2 numeral_3_eq_3 numeral_One take_aux zero_less_Suc)
apply (auto simp add:calc_len)
  apply (metis Suc_diff_Suc Suc_lessD le_imp_less_Suc length_concat_take numeral_2_eq_2)
apply (simp add:len_con_take)
apply (subgoal_tac "length (concat (drop j (pcs lst))) > 0")
  apply linarith
apply (subgoal_tac "length
         (concat (drop j (pcs lst))) \<ge> length (pcs lst!j)")
apply (subgoal_tac "length (pcs lst!j) > 0")
  apply linarith
apply auto
  using nth_mem pcs_not_empty apply force
using concat_mem_length [of "(pcs lst ! j)" "pcs lst"]
  by (metis Cons_nth_drop_Suc concat_mem_length list.set_intros(1))

lemma decompose_pcs :
  "call (map snd lst) \<Longrightarrow>
   x \<in> set (pcs lst) \<Longrightarrow>
   call_e (map snd x) (snd (lst!1)) \<or>
   const_seq (map snd x) (snd (lst!1))"
using decompose_call_pieces [of "map snd lst" "map snd x"]
pcs_call_pieces [of x lst]
apply (subgoal_tac "length lst > 1")
  apply (auto simp add:call_def)
done

lemma call_pcs_hd :
 "call (map snd lst) \<Longrightarrow>
  hd (pcs lst) \<in> set (pcs lst)"
apply (subgoal_tac "length lst > 0")
using has_pieces [of lst]
  apply (metis Suc_lessI add_diff_cancel_left' call_invariant_before_after call_last_length diff_Suc_1 diff_add_zero last_conv_nth length_map less_numeral_extra(3) list.set_sel(1) list.size(3) numeral_2_eq_2 one_add_one zero_neq_one)
by (auto simp add:call_def)

lemma call_length_simp :
  "call (map snd lst) \<Longrightarrow>
   length lst > 2"
by (simp add:call_def)

lemma call_pcs_helper :
 "call (map snd lst) \<Longrightarrow>
  pcs lst \<noteq> []"
apply (subgoal_tac "length lst > 2")
using has_pieces [of lst]
by (auto simp add:call_def)

(* first piece is a constant seq *)
lemma first_pcs_const :
  "call (map snd lst) \<Longrightarrow>
   const_seq (map snd (hd (pcs lst))) (snd (lst!1))"
using decompose_pcs [of lst "hd (pcs lst)"]
apply (simp add:call_pcs_hd)
apply (cases "call_e (map snd (hd (pcs lst)))
     (snd (lst ! Suc 0))"; auto)
using get_first [of lst 0 ]
apply (simp add:call_length_simp call_pcs_helper)
apply (subgoal_tac "length (pcs lst) > 0")
apply (auto simp add:call_e_def hd_conv_nth)
  apply (metis Suc_lessD hd_map length_greater_0_conv tlr_anti)
  using call_pcs_helper by blast

lemma pathR_pcs :
   "a \<in> set (pcs lst) \<Longrightarrow>
    pathR r lst \<Longrightarrow>
    pathR r a"
apply (simp add:pcs_def)
  using pathR_clip pathR_split by blast

lemma call_last_pcs :
   "call (map snd lst) \<Longrightarrow>
    x \<in> set (pcs lst) \<Longrightarrow>
    snd (last x) = snd (lst!1)"
using decompose_pcs [of lst x]
apply simp
apply (subgoal_tac "length lst > 2 \<and> x \<noteq> []")
apply (cases "const_seq (map snd x) (snd (lst ! 1))"; simp)
apply (clarsimp simp add:const_seq_def)
  apply (simp add: image_subset_iff)
apply clarsimp
using call_e_final [of "map snd x" "snd (lst ! Suc 0)"]
  apply (simp add: last_map)
apply (auto simp add:call_length_simp pcs_not_empty)
done

lemma cut_concat :
"j < length ps \<Longrightarrow>
 take (length (ps!j))
    (drop (length (concat (take j ps))) (concat ps)) = ps ! j"
by (induction ps arbitrary:j; case_tac j; auto simp add: hd_conv_nth nth_append)

lemma cut_concat_clip :
  "length lst > 2 \<Longrightarrow>
   i+j \<le> length lst - 2 \<Longrightarrow>
   take i (drop j (clip (length lst - 2) (Suc 0) lst)) =
   take i (drop (Suc j) lst)"
apply (simp add:clip_def)
apply (rule List.nth_equalityI)
apply simp
apply simp
apply auto
  by (smt One_nat_def Suc_diff_Suc Suc_lessD Suc_mono add.commute calc_len diff_Suc_1 length_drop length_take less_diff_conv less_imp_le_nat nth_drop numeral_2_eq_2 take_aux zero_less_Suc)

lemma cut_concat_pcs :
  "j < length (pcs lst) \<Longrightarrow>
   length lst > 2 \<Longrightarrow>
   take (length (pcs lst!j))
    (drop (length (concat (take j (pcs lst))) + 1) lst) =
   pcs lst ! j"
using cut_concat [of j "pcs lst"]
apply simp
using combine_pcs [of lst]
apply simp
apply (subgoal_tac "take (length (pcs lst ! j))
   (drop
       (length (concat (take j (pcs lst))))
       (clip (length lst - 2) (Suc 0)
         lst)) = take (length (pcs lst ! j))
     (drop
       (Suc
         (length
           (concat (take j (pcs lst)))))
       lst)")
apply simp
apply (rule cut_concat_clip)
apply auto
  by (metis (no_types, lifting) List.take_all Nat.le_diff_conv2 concat_pcs_length length_concat_take length_drop less_imp_le_nat not_le)

lemma extend_piece :
   "take i (drop (j+1) lst) = x \<Longrightarrow>
    lst!j = y \<Longrightarrow>
    length lst > j \<Longrightarrow>
    take (i+1) (drop j lst) = y # x"
  by (metis Cons_nth_drop_Suc Suc_eq_plus1 take_Suc_Cons)

lemma length_concat_pcs_helper :
"call (map snd lst) \<Longrightarrow>
 length (concat (take j (pcs lst))) < length lst - 1"
using length_concat_take [of j "pcs lst"]
 concat_pcs_length [of lst]
  by (metis One_nat_def Suc_diff_Suc Suc_lessD call_length_simp le_imp_less_Suc numeral_2_eq_2)

lemma pcs_not_empty_idx : "j < length (pcs lst) \<Longrightarrow> pcs lst!j \<noteq> []"
  using nth_mem pcs_not_empty by fastforce

lemma extend_const_seq :
 "const_seq lst x \<Longrightarrow> const_seq (x # lst) x"
by (simp add:const_seq_def)

lemma helper_2 :
"call (map snd lst) \<Longrightarrow>
 j > 0 \<Longrightarrow>
 j < length (pcs lst) \<Longrightarrow>
 min (length lst - length (concat (take j (pcs lst))))
     (Suc (length (pcs lst ! j)))
    < length lst"
apply (cases "(length lst - length (concat (take j (pcs lst)))) \<ge>
     (Suc (length (pcs lst ! j)))")
apply (simp add:min_def)
using concat_pcs_length [of lst]
  apply (smt Suc_diff_Suc Suc_lessD Suc_n_not_le_n call_length_simp concat_mem_length diff_Suc_1 diff_less diff_zero le_neq_implies_less length_greater_0_conv less_trans_Suc list.size(3) nth_mem numeral_2_eq_2)
apply (simp add:min_def)
  by (metis Suc_diff_1 Suc_lessD call_length_simp concat_eq_Nil_conv diff_less has_piece length_greater_0_conv numerals(2))

(*
definition iv_cond :: "('b * 'a list \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> ('b * 'a list) rel" where
"iv_cond iv level =
  {(a,b) | a b. length (snd a) = level \<and> length (snd b) = level \<and> (iv a \<longrightarrow> iv b) }
\<union> {(a,b) | a b. length (snd a) = level \<and> length (snd b) + 1 = level \<and> (iv a \<longrightarrow> iv b) }
\<union> {(a,b) | a b. length (snd a) + 1 = level \<and> length (snd b) = level \<and> (iv a \<longrightarrow> iv b) }
\<union> {(a,b) | a b. length (snd a) \<noteq> level \<and> length (snd b) \<noteq> level}"
*)

definition iv_cond :: "('b * 'a list \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> ('b * 'a list) rel" where
"iv_cond iv level =
  (* stay inside call *)
  {(a,b) | a b. length (snd a) = level \<and> length (snd b) = level \<and> (iv a \<longrightarrow> iv b) }
  (* exit call *)
\<union> {(a,b) | a b. length (snd a) = level \<and> length (snd b) + 1 = level \<and> (iv a \<longrightarrow> iv b) }
  (* enter call (no extra conditions) *)
\<union> {(a,b) | a b. length (snd a) + 1 = level \<and> length (snd b) = level }
  (* call other *)
\<union> {(a,b) | a b. length (snd a) = level \<and> length (snd b) = level + 1 \<and> (iv a \<longrightarrow> iv b) }
  (* other exited (no extra conditions) *)
\<union> {(a,b) | a b. length (snd a) = level + 1 \<and> length (snd b) = level }
  (* not directly related *)
\<union> {(a,b) | a b. length (snd a) \<noteq> level \<and> length (snd b) \<noteq> level}"

lemma handle_const_seq :
   "pathR (iv_cond iv (length (snd (lst ! 0)))) lst \<Longrightarrow>
    iv (lst ! 0) \<Longrightarrow>
    length lst > 0 \<Longrightarrow>
    const_seq (map snd lst) (snd (lst ! 0)) \<Longrightarrow>
    iv (last lst)"
apply (induction lst; auto)
by (case_tac lst; auto; simp add:iv_cond_def pathR.simps const_seq_def)

lemma iv_cond_push :
 "(x, y) \<in> iv_cond iv len \<Longrightarrow> iv x \<Longrightarrow>
  length (snd x) = len \<Longrightarrow>
  (snd y, snd x) \<in> tlR \<Longrightarrow>
  iv y"
apply (simp add:iv_cond_def tlR_def)
  by (smt n_not_Suc_n snd_conv)

lemma iv_cond_pop :
 "(x, y) \<in> iv_cond iv len \<Longrightarrow> iv x \<Longrightarrow>
  length (snd x) = len \<Longrightarrow>
  (snd x, snd y) \<in> tlR \<Longrightarrow>
  iv y"
apply (simp add:iv_cond_def tlR_def)
  by (smt n_not_Suc_n snd_conv)

(*
lemma iv_cond_error :
 "(x, y) \<in> iv_cond iv len \<Longrightarrow>
  length (snd x) = len \<Longrightarrow>
  (snd y, snd x) \<in> tlR \<Longrightarrow>
  False"
apply (simp add:iv_cond_def tlR_def)
  by (smt length_Cons lessI list.size(4) not_add_less1 prod.collapse snd_conv)
*)

lemma call_invariant_aux :
 "\<forall>i j. length (take i (drop j lst)) < length lst \<longrightarrow>
      call (map snd (take i (drop j lst))) \<longrightarrow>
      iv (take i (drop j lst) ! 1) \<longrightarrow>
      iv (last (take i (drop j lst))) \<Longrightarrow>
    call (map snd lst) \<Longrightarrow>
    pathR (iv_cond iv (length (snd (lst ! 1)))) lst \<Longrightarrow>
    j < length (pcs lst) \<Longrightarrow>
    iv (lst!1) \<Longrightarrow>
    iv (lst ! length (concat (take (Suc j) (pcs lst))))"
apply (induction j)
apply auto
apply (cases "pcs lst")
apply simp
apply (subst get_last)
apply (auto simp add:call_length_simp call_pcs_helper)
apply (subgoal_tac "const_seq (map snd a) (snd (lst!1))")
defer
using first_pcs_const [of lst] apply force
defer
apply (subgoal_tac "lst!1 = a!0")
subgoal for a list
apply (rule handle_const_seq [of iv a])
apply auto
using pathR_pcs [of a lst ] apply force
  by (metis list.set_intros(1) pcs_not_empty)
using get_first [of lst 0]
  apply (metis (no_types, lifting) One_nat_def call_length_simp clip_nth combine_pcs concat_eq_Nil_conv diff_Suc_1 get_first_gen hd_conv_nth length_pos_if_in_set less_diff_conv less_numeral_extra(3) list.set_intros(1) list.size(3) nth_Cons_0 one_add_one pcs_not_empty take_eq_Nil zero_less_one)
subgoal for j
using get_last [of lst j]
using get_first [of lst "Suc j"]
using get_last [of lst "Suc j"]
apply (simp add:call_length_simp call_pcs_helper)
using decompose_pcs [of lst "pcs lst ! Suc j"]
apply simp
apply (cases "const_seq (map snd (pcs lst ! Suc j))
     (snd (lst ! Suc 0))")
apply simp
using cut_concat_pcs [of "Suc j" lst]
apply (simp add:call_length_simp call_pcs_helper)
using extend_piece [of "length (pcs lst ! Suc j)"
   "length (concat (take (Suc j) (pcs lst)))" lst
    "pcs lst!Suc j" "last (pcs lst ! j)"]
apply simp
apply (subgoal_tac
"length (concat (take (Suc j) (pcs lst)))
     < length lst")
defer
using length_concat_pcs_helper [of lst "Suc j"] apply force
defer
apply simp
using handle_const_seq [of iv "take (Suc (length (pcs lst ! Suc j)))
     (drop (length (concat (take (Suc j) (pcs lst)))) lst)"]
apply simp
apply (subgoal_tac "pathR (iv_cond iv (length (snd (last (pcs lst ! j)))))
      (last (pcs lst ! j) # pcs lst ! Suc j)")
apply (subgoal_tac "const_seq
      (snd (last (pcs lst ! j)) # map snd (pcs lst ! Suc j))
      (snd (last (pcs lst ! j)))")
apply (simp)
apply (subgoal_tac "pcs lst ! Suc j \<noteq> []")
apply simp
using pcs_not_empty_idx [of "Suc j" lst]
apply simp
apply (subgoal_tac "snd (lst ! Suc 0) = snd (last (pcs lst ! j))")
apply simp
apply (rule extend_const_seq)
apply simp
  apply (metis One_nat_def Suc_lessD call_last_pcs nth_mem)
apply (subgoal_tac "snd (lst ! Suc 0) = snd (last (pcs lst ! j))")
apply simp

apply (subgoal_tac " pathR (iv_cond iv (length (snd (last (pcs lst ! j)))))
  (take (Suc (length (pcs lst ! Suc j)))
     (drop (length (concat (take (Suc j) (pcs lst)))) lst))")
apply force
using pathR_take [of "iv_cond iv (length (snd (last (pcs lst ! j))))"]
 pathR_drop [of "iv_cond iv (length (snd (last (pcs lst ! j))))"]
  apply blast
  apply (metis One_nat_def Suc_lessD call_last_pcs nth_mem)
apply simp
(* lets extend this piece too *)
using cut_concat_pcs [of "Suc j" lst]
apply (simp add:call_length_simp call_pcs_helper)
using extend_piece [of "length (pcs lst ! Suc j)"
   "length (concat (take (Suc j) (pcs lst)))" lst
    "pcs lst!Suc j" "last (pcs lst ! j)"]
apply simp
apply (subgoal_tac
"length (concat (take (Suc j) (pcs lst)))
     < length lst")
defer
using length_concat_pcs_helper [of lst "Suc j"] apply force
apply simp
apply (subgoal_tac "call (map snd (take (Suc (length (pcs lst ! Suc j)))
     (drop (length (concat (take (Suc j) (pcs lst)))) lst)))")
apply (drule spec2[where x = "Suc (length (pcs lst ! Suc j))" and
   y = "length (concat (take (Suc j) (pcs lst)))"])
apply clarsimp
apply (subgoal_tac "min (length lst - length (concat (take (Suc j) (pcs lst))))
     (Suc (length (pcs lst ! Suc j)))
    < length lst")
apply clarsimp
apply (subgoal_tac "iv (pcs lst ! Suc j ! 0)")
apply clarsimp
apply (subgoal_tac "pcs lst ! Suc j \<noteq> []")
apply clarsimp
using pcs_not_empty_idx [of "Suc j" lst]
apply simp
defer
using helper_2 apply force
apply (rule call_e_call)
apply simp
apply (subgoal_tac "pcs lst ! Suc j \<noteq> []")
apply simp
apply (subgoal_tac "snd (lst ! Suc 0) = snd (last (pcs lst ! j))")
apply simp
  apply (metis call_e_final)
  apply (metis One_nat_def Suc_lessD call_last_pcs nth_mem)
  using \<open>Suc j < length (pcs lst) \<Longrightarrow> pcs lst ! Suc j \<noteq> []\<close> apply blast
apply simp
  apply (metis (no_types, lifting) One_nat_def Suc_lessD call_e_final call_last_pcs nth_mem)
apply (subgoal_tac
  "(last (pcs lst ! j), hd (pcs lst ! Suc j)) \<in> iv_cond iv (length (snd (lst ! 1)))")
subgoal
using iv_cond_push [of "last (pcs lst ! j)" "hd (pcs lst ! Suc j)" iv
  "length (snd (lst ! Suc 0))"]
apply simp
apply (subgoal_tac "snd (lst ! Suc 0) = snd (last (pcs lst ! j))")
apply simp
apply (subgoal_tac
"(snd (hd (pcs lst ! Suc j)), snd (last (pcs lst ! j))) \<in> tlR")
apply simp
  apply (metis \<open>Suc j < length (pcs lst) \<Longrightarrow> pcs lst ! Suc j \<noteq> []\<close> hd_conv_nth)
  apply (metis \<open>Suc j < length (pcs lst) \<Longrightarrow> pcs lst ! Suc j \<noteq> []\<close> call_e_def list.map_sel(1))
  by (metis One_nat_def Suc_lessD call_last_pcs nth_mem)
apply (simp add:path_defs path_def)
  by (metis One_nat_def \<open>call (map snd lst) \<Longrightarrow> length (concat (take (Suc j) (pcs lst))) < length lst - 1\<close>)
done

lemma call_invariant :
  "\<forall>i j. length (take i (drop j lst)) < length lst \<longrightarrow>
      call (map snd (take i (drop j lst))) \<longrightarrow>
      iv (take i (drop j lst) ! 1) \<longrightarrow>
      iv (last (take i (drop j lst))) \<Longrightarrow>
   call (map snd lst) \<Longrightarrow>
   pathR (iv_cond iv (length (snd (lst!1)))) lst \<Longrightarrow>
   iv (lst!1) \<Longrightarrow>
   iv (last lst)"
using call_invariant_aux [of lst iv "length (pcs lst) - 1"]
apply simp
apply (subgoal_tac "length (pcs lst) > 0")
apply simp
defer
  using call_pcs_helper apply blast
using concat_pcs_length [of lst]
apply (subgoal_tac "2 < length lst")
apply simp
apply (subgoal_tac "(lst ! (length lst - 2), last lst) \<in> iv_cond iv (length (snd (lst ! Suc 0)))")
using iv_cond_pop [of "lst ! (length lst - 2)" "last lst" iv "length (snd (lst ! Suc 0))"]
apply simp
apply (subgoal_tac "length (snd (lst ! (length lst - 2))) = length (snd (lst ! Suc 0))")
apply (subgoal_tac "(snd (lst ! (length lst - 2)), snd (last lst)) \<in> tlR")
apply simp
defer
apply (subgoal_tac "snd (lst ! (length lst - 2)) = snd (lst!1)")
apply simp
  using call_invariant_before_after apply fastforce
apply (simp add:path_defs path_def)
  apply (metis (no_types, lifting) One_nat_def Suc_diff_Suc gr_implies_not0 last_conv_nth length_0_conv lessI less_trans_Suc numeral_2_eq_2 zero_less_numeral)
  using call_length_simp apply blast
apply (subgoal_tac "snd (lst ! (length lst - 2)) = snd (lst!1)")
apply simp
apply (subgoal_tac "snd (last lst) = snd (lst!0)")
apply simp
  apply (metis One_nat_def Suc_1 Suc_lessD call_def nth_map)
defer
  apply (smt Suc_1 Suc_lessD call_invariant_before_after diff_less length_greater_0_conv length_map less_numeral_extra(2) list.size(3) nth_map zero_less_numeral)
using call_stack_length [of "map snd lst"]
  by (metis gr_implies_not0 hd_conv_nth last_map length_0_conv length_greater_0_conv map_is_Nil_conv nth_map)

lemma tr_invariant :
  "\<forall>lst2.
    length lst2 \<le> length lst \<longrightarrow> pathR tr lst2 \<longrightarrow>
    call (map snd lst2) \<longrightarrow>
    pathR (iv_cond iv (length (snd (lst2 ! 1)))) lst \<Longrightarrow>
  pathR tr lst \<Longrightarrow>
  call (map snd lst) \<Longrightarrow>
  iv (lst!1) \<Longrightarrow>
  iv (last lst)"
apply (induction "length lst" arbitrary:lst rule:nat_less_induct)
apply (rule call_invariant; simp)
using pathR_drop pathR_take
  by (smt diff_is_0_eq' le_trans length_drop length_take nat_le_linear not_gr0 zero_less_diff)

end


header {* \isaheader{CFG well-formedness} *}

theory CFG_wf imports CFG begin

subsection {* Well-formedness of the abstract CFG *}

locale CFG_wf = CFG sourcenode targetnode kind valid_edge Entry
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> 'state edge_kind" and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')") +
  fixes Def::"'node \<Rightarrow> 'var set"
  fixes Use::"'node \<Rightarrow> 'var set"
  fixes state_val::"'state \<Rightarrow> 'var \<Rightarrow> 'val"
  assumes Entry_empty:"Def (_Entry_) = {} \<and> Use (_Entry_) = {}"
  and CFG_edge_no_Def_equal:
    "\<lbrakk>valid_edge a; V \<notin> Def (sourcenode a); pred (kind a) s\<rbrakk>
     \<Longrightarrow> state_val (transfer (kind a) s) V = state_val s V"
  and CFG_edge_transfer_uses_only_Use:
    "\<lbrakk>valid_edge a; \<forall>V \<in> Use (sourcenode a). state_val s V = state_val s' V;
      pred (kind a) s; pred (kind a) s'\<rbrakk>
      \<Longrightarrow> \<forall>V \<in> Def (sourcenode a). state_val (transfer (kind a) s) V =
                                     state_val (transfer (kind a) s') V"
  and CFG_edge_Uses_pred_equal:
    "\<lbrakk>valid_edge a; pred (kind a) s;
      \<forall>V \<in> Use (sourcenode a). state_val s V = state_val s' V\<rbrakk>
       \<Longrightarrow> pred (kind a) s'"
  and deterministic:"\<lbrakk>valid_edge a; valid_edge a'; sourcenode a = sourcenode a';
    targetnode a \<noteq> targetnode a'\<rbrakk>
  \<Longrightarrow> \<exists>Q Q'. kind a = (Q)\<^sub>\<surd> \<and> kind a' = (Q')\<^sub>\<surd> \<and>
             (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))"

begin

lemma [dest!]: "V \<in> Use (_Entry_) \<Longrightarrow> False"
by(simp add:Entry_empty)

lemma [dest!]: "V \<in> Def (_Entry_) \<Longrightarrow> False"
by(simp add:Entry_empty)

lemma CFG_path_no_Def_equal:
  "\<lbrakk>n -as\<rightarrow>* n'; \<forall>n \<in> set (sourcenodes as). V \<notin> Def n; preds (kinds as) s\<rbrakk>
    \<Longrightarrow> state_val (transfers (kinds as) s) V = state_val s V"
proof(induct arbitrary:s rule:path.induct)
  case (empty_path n)
  thus ?case by(simp add:sourcenodes_def kinds_def)
next
  case (Cons_path n'' as n' a n)
  note IH = `\<And>s. \<lbrakk>\<forall>n\<in>set (sourcenodes as). V \<notin> Def n; preds (kinds as) s\<rbrakk> \<Longrightarrow>
            state_val (transfers (kinds as) s) V = state_val s V`
  from `preds (kinds (a#as)) s` have "pred (kind a) s"
    and "preds (kinds as) (transfer (kind a) s)" by(simp_all add:kinds_def)
  from `\<forall>n\<in>set (sourcenodes (a#as)). V \<notin> Def n`
    have noDef:"V \<notin> Def (sourcenode a)"
    and all:"\<forall>n\<in>set (sourcenodes as). V \<notin> Def n"
    by(auto simp:sourcenodes_def)
  from `valid_edge a` noDef `pred (kind a) s`
  have "state_val (transfer (kind a) s) V = state_val s V"
    by(rule CFG_edge_no_Def_equal)
  with IH[OF all `preds (kinds as) (transfer (kind a) s)`] show ?case
    by(simp add:kinds_def)
qed

end

end


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

chapter \<open>Mopup Turing Machine that deletes all "registers", except one\<close>

theory Abacus_Mopup
  imports Uncomputable
begin

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

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

fun mopup :: "nat \<Rightarrow> instr list"
  where
    "mopup 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
 = (W0, Suc (2 * n + 2))"
  apply(subgoal_tac "length (mopup_a n) = 4 * n")
   apply(auto simp: mopup_b_def nth_append shift.simps)
  done

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

declare replicate_Suc[simp]

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

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

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

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

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

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

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

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

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

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

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

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 wf_mopup[intro]: "tm_wf (mopup n, 0)"
  by(induct n, auto simp add: shift.simps mopup_b_def tm_wf.simps)

end