# Theory TS

theory TS
imports Phase_Partitioning List_Factoring
```(*  Title:       Competitive Analysis of TS
Author:      Max Haslbeck
*)

section "TS: another 2-competitive Algorithm"

theory TS
imports
OPT2
Phase_Partitioning
Move_to_Front
List_Factoring
RExp_Var
begin

subsection "Definition of TS"

definition TS_step_d where
"TS_step_d s q = ((
(
let li = index (snd s) q in
(if li = length  (snd s) then 0 ― ‹requested for first time›
else (let sincelast = take li  (snd s)
in (let S={x. x < q in (fst s) ∧ count_list sincelast x ≤ 1}
in
(if S={} then 0
else
(index (fst s) q) - Min ( (index (fst s)) ` S)))
)
)
)
,[]), q#(snd s))"

(* FIXME: generalizing regular expressions equivalence checking
enables relaxing the type here to 'a::linord *)
definition rTS :: "nat list ⇒ (nat,nat list) alg_on"   where "rTS h = ((λs. h), TS_step_d)"

fun TSstep where
"TSstep qs n (is,s)
= ((qs!n)#is,
step s (qs!n) ((
let li = index is (qs!n) in
(if li = length is then 0 ― ‹requested for first time›
else (let sincelast = take li is
in (let S={x. x < (qs!n) in s ∧ count_list sincelast x ≤ 1}
in
(if S={} then 0
else
(index s (qs!n)) - Min ( (index s) ` S)))
)
)
),[]))"

lemma TSnopaid: "(snd (fst (snd (rTS initH) is q))) = []"

abbreviation TSdet where
"TSdet init initH qs n == config (rTS initH) init (take n qs)"

lemma TSdet_Suc: "Suc n ≤ length qs ⟹ TSdet init initH qs (Suc n) = Step (rTS initH) (TSdet init initH qs n) (qs!n)"

(* now do the proof with TSdet *)

definition s_TS where "s_TS init initH qs n  = fst (TSdet init initH qs n)"

lemma sndTSdet: "n≤length xs ⟹ snd (TSdet init initH xs n) = rev (take n xs) @ initH"
apply(induct n)
by(simp add: split_def TS_step_d_def take_Suc_conv_app_nth config'_snoc Step_def rTS_def)

subsection "Behaviour of TS on lists of length 2"

lemma
fixes hs x y
assumes "x≠y"
shows oneTS_step :    "TS_step_d ([x, y], x#y#hs)     y = ((1, []), y # x # y # hs)"
and oneTS_stepyyy:  "TS_step_d ([x, y], y#x#hs)     y = ((Suc 0, []), y#y#x#hs)"
and oneTS_stepx:    "TS_step_d ([x, y], x#x#hs)     y = ((0, []), y # x # x # hs)"
and oneTS_stepy:    "TS_step_d ([x, y], [])         y = ((0, []), [y])"
and oneTS_stepxy:   "TS_step_d ([x, y], [x])        y = ((0, []), [y, x])"
and oneTS_stepyy:   "TS_step_d ([x, y], [y])        y = ((Suc 0, []), [y, y])"
and oneTS_stepyx:   "TS_step_d ([x, y], hs)         x = ((0, []), x # hs)"
using assms by(auto simp add: step_def mtf2_def swap_def TS_step_d_def before_in_def)

lemmas oneTS_steps = oneTS_stepx oneTS_stepxy oneTS_stepyx oneTS_stepy oneTS_stepyy oneTS_stepyyy oneTS_step

subsection "Analysis of the Phases"

definition "TS_inv c x i ≡ (∃hs. c = return_pmf ((if x=hd i then i else rev i),[x,x]@hs) )
∨ c = return_pmf ((if x=hd i then i else rev i),[])"

lemma TS_inv_sym: "a≠b ⟹ {a,b}={x,y} ⟹ z∈{x,y} ⟹ TS_inv c z [a,b] = TS_inv c z [x,y]"
unfolding TS_inv_def by auto

abbreviation "TS_inv' s x i == TS_inv (return_pmf s) x i"

lemma TS_inv'_det: "TS_inv' s x i = ((∃hs. s = ((if x=hd i then i else rev i),[x,x]@hs) )
∨ s = ((if x=hd i then i else rev i),[]))"
unfolding TS_inv_def by auto

lemma TS_inv'_det2: "TS_inv' (s,h) x i = (∃hs. (s,h) = ((if x=hd i then i else rev i),[x,x]@hs) )
∨  (s,h) = ((if x=hd i then i else rev i),[])"
unfolding TS_inv_def by auto

(*
TS_A   (x+1)yy →         Plus(Atom (x::nat)) One,(Atom y), (Atom y)]
TS_B   (x+1)yx(yx)*yy →  Plus(Atom x) One,(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom y),(Atom y)]
TS_C   (x+1)yx(yx)*x  →  Plus(Atom x) One,(Atom y),(Atom x),Star(Times (Atom y)(Atom x)),(Atom x)]
TD_D   xx             →  seq[(Atom x),(Atom x)]
*)

subsubsection "(yx)*?"

lemma TS_yx': assumes "x ≠ y" "qs ∈ lang (Star(Times (Atom y) (Atom x)))"
"∃hs. h=[x,y]@hs"
shows "T_on' (rTS h0) ([x,y],h) (qs@r) = length qs + T_on' (rTS h0) ([x,y],((rev qs) @h))  r
∧ (∃hs. ((rev qs) @h) = [x, y] @ hs)
∧ config' (rTS h0) ([x, y],h) qs = ([x,y],rev qs @ h)"
proof -
from assms have "qs ∈ star ({[y]} @@ {[x]})" by (simp)
from this assms(3) show ?thesis
proof (induct qs arbitrary: h rule: star_induct)
case Nil
then show ?case by(simp add: rTS_def)
next
case (append u v)
then have uyx: "u = [y,x]" by auto
from append obtain hs where a: "h = [x,y]@hs" by blast

have "T_on' (rTS h0) ([x, y], (rev u @ h)) (v @ r) = length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r
∧ (∃hs. rev v @ (rev u @ h) = [x, y] @ hs)
∧ config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ (rev u @ h))"
apply(simp only: uyx) apply(rule append(3)) by simp
then have yy: "T_on' (rTS h0) ([x, y], (rev u @ h)) (v @ r) = length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r"
and history: "(∃hs. rev v @ (rev u @ h) = [x, y] @ hs)"
and state: "config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ (rev u @ h))" by auto

have s0: "s_TS [x, y] h [y, x] 0 = [x,y]" unfolding s_TS_def by(simp)

from assms(1) have hahah: " {xa. xa < y in [x, y] ∧ count_list [x] xa ≤ 1} = {x}"
unfolding before_in_def by auto

have "config' (rTS h0) ([x, y],h) u = ([x, y], x # y # x # y # hs)"
apply(simp add: split_def rTS_def uyx a )
using assms(1) by(auto simp add: Step_def oneTS_steps step_def mtf2_def swap_def)

then have s2: "config' (rTS h0) ([x, y],h) u =  ([x, y], ((rev u) @ h))"
unfolding a uyx by simp

have "config' (rTS h0) ([x, y], h) (u @ v) =
config' (rTS h0) (Partial_Cost_Model.config' (rTS h0) ([x, y], h) u) v" by (rule config'_append2)
also
have "… = config' (rTS h0)  ([x, y], ((rev u) @ h)) v" by(simp only: s2)
also
have "… = ([x, y], rev (u @ v) @ h)" by (simp add: state)
finally
have alles: "config' (rTS h0) ([x, y], h) (u @ v) = ([x, y], rev (u @ v) @ h)" .

have ta: "T_on' (rTS h0) ([x,y],h) u = 2"
unfolding rTS_def uyx a apply(simp only: T_on'.simps(2))
using assms(1) apply(auto simp add: Step_def step_def mtf2_def swap_def oneTS_steps)

have "T_on' (rTS h0) ([x,y],h) ((u @ v) @ r)
= T_on' (rTS h0) ([x,y],h) (u @ (v @ r))" by auto
also have "…
= T_on' (rTS h0) ([x,y],h) u
+ T_on' (rTS h0) (config' (rTS h0) ([x, y],h) u) (v @ r)"
by(rule T_on'_append)
also have "… = T_on' (rTS h0) ([x,y],h) u
+ T_on' (rTS h0) ([x, y],(rev u @ h)) (v @ r)" by(simp only: s2)
also have "… = T_on' (rTS h0) ([x,y],h) u + length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" by(simp only: yy)
also have "… = 2 + length v + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" by(simp only: ta)
also have "… = length (u @ v) + T_on' (rTS h0) ([x, y], rev v @ (rev u @ h)) r" using uyx by auto
also have "… = length (u @ v) + T_on' (rTS h0) ([x, y], (rev (u @ v) @ h)) r" by auto
finally show ?case using history alles by simp
qed
qed

subsubsection "?x"

lemma TS_x': "T_on' (rTS h0) ([x,y],h) [x] = 0 ∧ config' (rTS h0) ([x, y],h) [x] = ([x,y], rev [x] @ h)"
by(auto simp add: t⇩p_def rTS_def TS_step_d_def Step_def step_def)

subsubsection "?yy"

lemma TS_yy': assumes "x ≠ y" "∃hs. h = [x, y] @ hs"
shows "T_on' (rTS h0) ([x,y],h) [y, y] = 1" "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)"
proof -
from assms obtain hs where a: "h = [x,y]@hs" by blast

from a show "T_on' (rTS h0) ([x,y],h) [y, y] = 1"
unfolding rTS_def
using assms(1) apply(auto simp add: oneTS_steps Step_def step_def mtf2_def swap_def)

show "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)"
unfolding rTS_def a using assms(1)
by(simp add: Step_def oneTS_steps step_def mtf2_def swap_def)
qed

subsubsection "yx(yx)*?"

lemma TS_yxyx': assumes [simp]: "x ≠ y" and "qs ∈ lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
"(∃hs. h=[x,x]@hs) ∨ index h y = length h"
shows "T_on' (rTS h0) ([x,y],h) (qs@r) = length qs - 1 + T_on' (rTS h0) ([x,y],rev qs @ h) r
∧ (∃hs. (rev qs @ h) = [x, y] @ hs)
∧ config' (rTS h0) ([x, y],h) qs = ([x,y], rev qs @ h)"
proof -
obtain u v where uu: "u ∈ lang (Times (Atom y) (Atom x))"
and vv: "v ∈ lang (seq[ Star(Times (Atom y) (Atom x))])"
and qsuv: "qs = u @ v"
using assms(2)
by (auto simp: conc_def)
from uu have uyx: "u = [y,x]" by(auto)

from qsuv uyx have vqs: "length v = length qs - 2" by auto
from qsuv uyx  have vqs2: "length v + 1 = length qs - 1" by auto

have firststep: "TS_step_d ([x, y], h) y = ((0, []), y # h)"
proof (cases "index h y = length h")
case True
then show ?thesis unfolding TS_step_d_def by(simp)
next
case False
with assms(3) obtain hs where a: "h = [x,x]@hs" by auto
then show ?thesis by(simp add: oneTS_steps)
qed

have s2: "config' (rTS h0) ([x,y],h) u = ([x, y], x # y # h)"
unfolding rTS_def uyx apply(simp add: )
unfolding Step_def by(simp add: firststep step_def oneTS_steps)

have ta: "T_on' (rTS h0) ([x,y],h) u = 1"
unfolding rTS_def uyx
apply(simp)
unfolding Step_def
using assms(1) by (simp add: firststep step_def oneTS_steps t⇩p_def)

have ttt:
"T_on' (rTS h0) ([x,y],rev u @ h) (v@r) = length v + T_on' (rTS h0) ([x,y],((rev v) @(rev u @ h)))  r
∧ (∃hs. ((rev v) @(rev u @ h)) = [x, y] @ hs)
∧ config' (rTS h0) ([x, y],(rev u @ h)) v = ([x,y],rev v @ (rev u @ h))"
apply(rule TS_yx')
apply(fact)
using vv apply(simp)
using uyx by(simp)
then have tat: "T_on' (rTS h0) ([x,y], x # y # h) (v@r) =
length v + T_on' (rTS h0) ([x,y],rev qs @ h)  r"
and history:  "(∃hs. (rev qs @ h) = [x, y] @ hs)"
and state: "config' (rTS h0) ([x, y], x # y # h) v = ([x,y],rev qs @ h)" using qsuv uyx
by auto

have "config' (rTS h0) ([x, y], h) qs = config' (rTS h0) (config' (rTS h0) ([x, y], h) u) v"
unfolding qsuv by (rule config'_append2)
also
have "… = ([x, y], rev qs @ h)" by(simp add: s2 state)
finally
have his: "config' (rTS h0) ([x, y], h) qs = ([x, y], rev qs @ h)" .

have "T_on' (rTS h0) ([x,y],h) (qs@r) = T_on' (rTS h0) ([x,y],h) (u @ v @ r)" using qsuv  by auto
also have "…
= T_on' (rTS h0) ([x,y],h) u + T_on' (rTS h0) (config' (rTS h0) ([x,y],h) u) (v @ r)"
by(rule T_on'_append)
also have "… = T_on' (rTS h0) ([x,y],h) u + T_on' (rTS h0) ([x, y], x # y # h) (v @ r)" by(simp only: s2)
also have "… = T_on' (rTS h0) ([x,y],h) u + length v + T_on' (rTS h0) ([x,y],rev qs @ h) r" by (simp only: tat)
also have "… = 1 + length v + T_on' (rTS h0) ([x,y],rev qs @ h) r" by(simp only: ta)
also have "… = length qs - 1 + T_on' (rTS h0) ([x,y],rev qs @ h) r" using vqs2 by auto
finally show ?thesis
apply(safe)
using history apply(simp)
using his by auto
qed

lemma TS_xr': assumes "x ≠ y" "qs ∈ lang (Plus (Atom x) One)"
"h = [] ∨ (∃hs. h = [x, x] @ hs) "
shows "T_on' (rTS h0) ([x,y],h) (qs@r) = T_on' (rTS h0) ([x,y],rev qs@h) r"
"((∃hs. (rev qs @ h) = [x, x] @ hs) ∨ (rev qs @ h) = [x] ∨ (rev qs @ h)=[]) "
"config' (rTS h0) ([x,y],h) (qs@r) = config' (rTS h0) ([x,y],rev qs @ h) r"
using assms
by (auto simp add: T_on'_append Step_def rTS_def TS_step_d_def step_def t⇩p_def)

subsubsection "(x+1)yx(yx)*yy"

lemma ts_b': assumes "x ≠ y"
"v ∈ lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
"(∃hs. h = [x, x] @ hs) ∨ h = [x] ∨ h = []"
shows "T_on' (rTS h0) ([x, y], h) v = (length v - 2)
∧  (∃hs. (rev v @ h) = [y,y]@hs) ∧ config' (rTS h0) ([x,y], h) v = ([y,x], rev v @ h)"
proof -
from assms have lenvmod: "length v mod 2 = 0" apply(simp)
proof -
assume "v ∈ ({[y]} @@ {[x]}) @@ star ({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}"
then obtain p q r where pqr: "v=p@q@r" and "p∈({[y]} @@ {[x]})"
and q: "q ∈ star ({[y]} @@ {[x]})" and "r ∈ {[y]} @@ {[y]}" by (metis concE)
then have "p = [y,x]" "r=[y,y]" by auto
with pqr have a: "length v = 4+length q" by auto

from q have b: "length q mod 2 = 0"
apply(induct q rule: star_induct) by (auto)
from a b show ?thesis by auto
qed

with assms(1,3) have fall: "(∃hs. h = [x, x] @ hs) ∨ index h y = length h"
by(auto)

from assms(2) have "v ∈ lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
@@ lang (seq[Atom y, Atom y])" by (auto simp: conc_def)
then obtain a b where aa: "a ∈ lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
and "b ∈ lang (seq[Atom y, Atom y])"
and vab: "v = a @ b"
by(erule concE)
then have bb: "b=[y,y]" by auto
from aa have lena: "length a > 0" by auto

from TS_yxyx'[OF assms(1) aa fall] have stars: "T_on' (rTS h0) ([x, y], h) (a @ b) =
length a - 1 + T_on' (rTS h0) ([x, y], rev a @ h) b"
and history: "(∃hs. rev a @ h = [x, y] @ hs)"
and state: "config' (rTS h0) ([x, y], h) a = ([x,y],rev a @ h)" by auto
(* "T_on' (rTS h0) ([x,y],h) [y, y] = 1" "config' (rTS h0) ([x, y],h) [y,y] = ([y,x],rev [y,y] @ h)" *)
have suffix: "T_on' (rTS h0) ([x, y], rev a @ h) b = 1"
and jajajaj: "config' (rTS h0) ([x, y],rev a @ h) b = ([y,x],rev b @ rev a @ h)" unfolding bb
using TS_yy' history assms(1) by auto

from stars suffix have "T_on' (rTS h0) ([x, y], h) (a @ b) = length a" using lena by auto
then have whatineed: "T_on' (rTS h0) ([x, y], h) v = (length v - 2)" using vab bb by auto

have grgr:"config' (rTS h0) ([x, y], h) v = ([y, x], rev v @ h)"
unfolding vab
apply(simp only: config'_append2 state jajajaj) by simp

from history obtain hs' where "rev a @ h = [x, y] @ hs'" by auto
then obtain hs2 where reva: "rev a @ h = x # hs2" by auto

show ?thesis using whatineed grgr
by(auto simp add: reva vab bb)
qed

lemma TS_b'1: assumes "x ≠ y" "h = [] ∨ (∃hs. h = [x, x] @ hs)"
"qs ∈ lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 2)
∧ TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
proof -
have f: "qs ∈ lang (seq [Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"

from ts_b'[OF assms(1) f] assms(2) have
T_star: "T_on' (rTS h0) ([x, y], h) qs = length qs - 2"
and inv1:   "config' (rTS h0) ([x, y],  h) qs = ([y, x], rev qs @ h)"
and inv2:   "(∃hs. rev qs @ h = [y, y] @ hs)" by auto

from T_star have TS: "T_on' (rTS h0) ([x, y], h) qs = (length qs - 2)" by metis

have lqs: "last qs = y" using assms(3) by force

from inv1 have inv: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]"
apply(subst TS_inv'_det)
using assms(2) inv2  by(simp)

show ?thesis unfolding TS
apply(safe)
by(fact inv)
qed

lemma TS_b1'': assumes
"x ≠ y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
"set qs ⊆ {x, y}"
"qs ∈ lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
∧ T_on_rand' (embed (rTS h0)) s qs = (length qs - 2)"
proof -
from assms(1,2) have kas: "(x0=x ∧ y0=y) ∨ (y0=x ∧ x0=y)" by(auto)
then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] ∨ (∃hs. h = [x, x] @ hs)"
apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

have l: "qs ≠ []" using assms by auto
{
fix x y qs h0
fix h:: "nat list"
assume A: "x ≠ y"
and B: "qs ∈ lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
and C: "h = [] ∨ (∃hs. h = [x, x] @ hs)"

then have C': "(∃hs. h = [x, x] @ hs) ∨ h = [x] ∨ h = []" by blast
from B have lqs: "last qs = y" using assms(5) by(auto simp add: conc_def)

have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] ∧
T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 2"
apply(simp only: T_on'_embed[symmetric] config'_embed)
using ts_b'[OF A B C'] A lqs unfolding TS_inv'_det by auto
} note b1=this

show ?thesis unfolding S
using kas apply(rule disjE)
apply(simp only:)
apply(rule b1)
using assms apply(simp)
using h apply(simp)
apply(simp only:)

apply(subst TS_inv_sym[of y x x y])
using assms(1) apply(simp)
apply(blast)
defer
apply(rule b1)
using assms apply(simp)
using h apply(simp)
using last_in_set l assms(4) by blast
qed

lemma ts_b2': assumes "x ≠ y"
"qs ∈ lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
"(∃hs. h = [x, x] @ hs) ∨ h = []"
shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 3)
∧  config' (rTS h0) ([x,y], h) qs = ([y,x],rev qs@h) ∧ (∃hs. (rev qs @ h) = [y,y]@hs)"
proof -
from assms(2) obtain v where qs: "qs = [x]@v"
and V: "v∈lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"

from assms(3) have 3: "(∃hs. x#h = [x, x] @ hs) ∨ x#h = [x] ∨ x#h = []" by auto

from ts_b'[OF assms(1) V 3]
have T: "T_on' (rTS h0) ([x, y], x#h) v = length v - 2"
and C: "config' (rTS h0) ([x, y], x#h) v = ([y, x], rev v @ x#h)"
and H: "(∃hs. rev v @ x#h = [y, y] @ hs)" by auto

have t: "t⇩p [x, y] x (fst (snd (rTS h0) ([x, y], h) x)) = 0"
by (simp add: step_def rTS_def TS_step_d_def t⇩p_def)
have c: "Partial_Cost_Model.Step (rTS h0) ([x, y], h) x
= ([x,y], x#h)" by (simp add: Step_def rTS_def TS_step_d_def step_def)

show ?thesis
unfolding qs apply(safe)
apply(simp add: T_on'_append T c t)
using H by simp
qed

lemma TS_b2'': assumes
"x ≠ y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
"set qs ⊆ {x, y}"
"qs ∈ lang (seq [Atom x, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
∧ T_on_rand' (embed (rTS h0)) s qs = (length qs - 3)"
proof -
from assms(1,2) have kas: "(x0=x ∧ y0=y) ∨ (y0=x ∧ x0=y)" by(auto)
then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] ∨ (∃hs. h = [x, x] @ hs)"
apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

have l: "qs ≠ []" using assms by auto
{
fix x y qs h0
fix h:: "nat list"
assume A: "x ≠ y"
and B: "qs ∈ lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
and C: "h = [] ∨ (∃hs. h = [x, x] @ hs)"

from B have lqs: "last qs = y" using assms(5) by(auto simp add: conc_def)

from C have C': "(∃hs. h = [x, x] @ hs) ∨ h = []" by blast

have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] ∧
T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 3"
apply(simp only: T_on'_embed[symmetric] config'_embed)
using ts_b2'[OF A B C'] A lqs unfolding TS_inv'_det by auto
} note b2=this

show ?thesis unfolding S
using kas apply(rule disjE)
apply(simp only:)
apply(rule b2)
using assms apply(simp)
using h apply(simp)
apply(simp only:)

apply(subst TS_inv_sym[of y x x y])
using assms(1) apply(simp)
apply(blast)
defer
apply(rule b2)
using assms apply(simp)
using h apply(simp)
using last_in_set l assms(4) by blast
qed

lemma TS_b': assumes "x ≠ y" "h = [] ∨ (∃hs. h = [x, x] @ hs)"
"qs ∈ lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
shows "T_on' (rTS h0) ([x, y], h) qs
≤ 2 * T⇩p [x, y] qs (OPT2 qs [x, y]) ∧ TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
proof -
obtain u v where uu: "u ∈ lang (Plus (Atom x) One)"
and vv: "v ∈ lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom y, Atom y])"
and qsuv: "qs = u @ v"
using assms(3)
by (auto simp: conc_def)

from TS_xr'[OF assms(1) uu assms(2)]  have
T_pre: "T_on' (rTS h0) ([x, y], h) (u @ v) =
T_on' (rTS h0) ([x, y], rev u @ h) v"
and fall': "(∃hs. (rev u @ h) = [x, x] @ hs) ∨ (rev u @ h) = [x] ∨ (rev u @ h)=[]"
and conf: "config' (rTS h0) ([x,y],h) (u@v) = config' (rTS h0) ([x,y],rev u @ h) v"
by auto

with assms uu have fall: "(∃hs. (rev u @ h) = [x, x] @ hs) ∨ index (rev u @ h) y = length (rev u @ h)"
by(auto)

from ts_b'[OF assms(1) vv fall'] have
T_star: "T_on' (rTS h0) ([x, y], rev u @ h) v = length v - 2"
and inv1:   "config' (rTS h0) ([x, y], rev u @ h) v = ([y, x], rev v @ rev u @ h)"
and inv2:   "(∃hs. rev v @ rev u @ h = [y, y] @ hs)" by auto

from T_pre T_star qsuv have TS: "T_on' (rTS h0) ([x, y], h) qs = (length v - 2)" by metis

(* OPT *)

from uu have uuu: "u=[] ∨ u=[x]" by auto
from vv have vvv: "v ∈ lang (seq
[Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom y, Atom y])" by(auto simp: conc_def)
have OPT: "T⇩p [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_B) by(fact)+

have lqs: "last qs = y" using assms(3) by force

have "config' (rTS h0) ([x, y], h) qs = ([y, x], rev qs @ h)"
unfolding qsuv conf inv1 by simp

then have inv: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]"
apply(subst TS_inv'_det)
using assms(2) inv2 qsuv by(simp)

show ?thesis unfolding TS OPT
apply(safe)
apply(simp)
by(fact inv)
qed

subsubsection "(x+1)yy"

lemma ts_a': assumes "x ≠ y" "qs ∈ lang (seq [Plus (Atom x) One, Atom y, Atom y])"
"h = [] ∨ (∃hs. h = [x, x] @ hs)"
shows "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]
∧ T_on' (rTS h0) ([x, y], h) qs = 2"
proof -
obtain u v where uu: "u ∈ lang (Plus (Atom x) One)"
and vv: "v ∈ lang (seq[Atom y, Atom y])"
and qsuv: "qs = u @ v"
using assms(2)
by (auto simp: conc_def)

from vv have vv2: "v = [y,y]" by auto

from uu have TS_prefix: " T_on' (rTS h0) ([x, y], h) u = 0"
using assms(1) by(auto simp add: rTS_def oneTS_steps t⇩p_def)

have h_split: "rev u @ h = [] ∨ rev u @ h = [x] ∨ (∃ hs. rev u @ h = [x,x]@hs)"
using assms(3) uu by(auto)

then have e: "T_on' (rTS h0) ([x,y],rev u @ h) [y,y] = 2"
using assms(1)
oneTS_steps
Step_def step_def t⇩p_def) done

have conf: "config' (rTS h0) ([x, y], h) u = ([x,y], rev u @ h)"
using uu by(auto simp add: Step_def rTS_def TS_step_d_def step_def)

have "T_on' (rTS h0) ([x, y], h) qs = T_on' (rTS h0) ([x, y], h) (u @ v)" using qsuv  by auto
also have "…
=T_on' (rTS h0) ([x, y], h) u + T_on' (rTS h0) (config' (rTS h0) ([x, y], h) u) v"
by(rule T_on'_append)
also have "…
= T_on' (rTS h0) ([x, y], h) u + T_on' (rTS h0) ([x,y],rev u @ h) [y,y]"
also have "… = T_on' (rTS h0) ([x, y], h) u + 2" by (simp only: e)
also have "… = 2" by (simp add: TS_prefix)
finally have TS: "T_on' (rTS h0) ([x, y], h) qs= 2" .

(* dannach *)

have lqs: "last qs = y" using assms(2) by force

from assms(1) have "config' (rTS h0) ([x, y], h) qs = ([y,x], rev qs @ h)"
unfolding qsuv
apply(simp only: config'_append2 conf vv2)
using h_split
oneTS_steps
step_def)

with assms(1) have "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
apply(subst TS_inv'_det)

show ?thesis unfolding TS apply(auto) by fact
qed

lemma TS_a': assumes  "x ≠ y"
"h = [] ∨ (∃hs. h = [x, x] @ hs)"
and "qs ∈ lang (seq [Plus (Atom x) rexp.One, Atom y, Atom y])"
shows "T_on' (rTS h0) ([x, y], h) qs ≤ 2 * T⇩p [x, y] qs (OPT2 qs [x, y])
∧ TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x, y]
∧ T_on' (rTS h0) ([x, y], h) qs = 2"
proof -
have OPT: "T⇩p [x,y] qs (OPT2 qs [x,y]) = 1" using OPT2_A[OF assms(1,3)] by auto
show ?thesis using OPT ts_a'[OF assms(1,3,2)] by auto
qed

lemma TS_a'': assumes
"x ≠ y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
"set qs ⊆ {x, y}" "qs ∈ lang (seq [Plus (Atom x) One, Atom y, Atom y])"
shows
"TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
∧ T⇩p_on_rand' (embed (rTS h0)) s qs = 2"
proof -
from assms(1,2) have kas: "(x0=x ∧ y0=y) ∨ (y0=x ∧ x0=y)" by(auto)
then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] ∨ (∃hs. h = [x, x] @ hs)"
apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

have l: "qs ≠ []" using assms by auto

{
fix x y qs h0
fix h:: "nat list"
assume A: "x ≠ y"
"qs ∈ lang (seq [question (Atom x), Atom y, Atom y])"
"h = [] ∨ (∃hs. h = [x, x] @ hs)"

have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] ∧
T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = 2"
apply(simp only: T_on'_embed[symmetric] config'_embed)
using ts_a'[OF A] by auto
} note b=this

show ?thesis unfolding S
using kas apply(rule disjE)
apply(simp only:)
apply(rule b)
using assms apply(simp)
using assms apply(simp)
using h apply(simp)
apply(simp only:)

apply(subst TS_inv_sym[of y x x y])
using assms(1) apply(simp)
apply(blast)
defer
apply(rule b)
using assms apply(simp)
using assms apply(simp)
using h apply(simp)
using last_in_set l assms(4) by blast
qed

subsubsection "x+yx(yx)*x"

lemma ts_c': assumes "x ≠ y"
"v ∈ lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
"(∃hs. h = [x, x] @ hs) ∨ h = [x] ∨ h = []"
shows "T_on' (rTS h0) ([x, y], h) v = (length v - 2)
∧  config' (rTS h0) ([x,y], h) v = ([x,y],rev v@h) ∧ (∃hs. (rev v @ h) = [x,x]@hs)"
proof -
from assms have lenvmod: "length v mod 2 = 1" apply(simp)
proof -
assume "v ∈ ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}"
then obtain p q r where pqr: "v=p@q@r" and "p∈({[y]} @@ {[x]})"
and q: "q ∈ star ({[y]} @@ {[x]})" and "r ∈ {[x]}" by (metis concE)
then have "p = [y,x]" "r=[x]" by auto
with pqr have a: "length v = 3+length q" by auto

from q have b: "length q mod 2 = 0"
apply(induct q rule: star_induct) by (auto)
from a b show "length v mod 2 = Suc 0" by auto
qed

with assms(1,3) have fall: "(∃hs. h = [x, x] @ hs) ∨ index h y = length h"
by(auto)

from assms(2) have "v ∈ lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])
@@ lang (seq[Atom x])" by (auto simp: conc_def)
then obtain a b where aa: "a ∈ lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x))])"
and "b ∈ lang (seq[Atom x])"
and vab: "v = a @ b"
by(erule concE)
then have bb: "b=[x]" by auto
from aa have lena: "length a > 0" by auto

from TS_yxyx'[OF assms(1) aa fall] have stars: "T_on' (rTS h0) ([x, y], h) (a @ b) =
length a - 1 + T_on' (rTS h0) ([x, y],rev a @ h) b"
and history: "(∃hs. rev a @ h = [x, y] @ hs)"
and state: "config' (rTS h0) ([x, y], h) a =  ([x, y], rev a @ h)" by auto

have suffix: "T_on' (rTS h0) ( [x, y],rev a @ h) b = 0"
and suState: "config' (rTS h0) ([x, y], rev a @ h) b = ([x,y], rev b @ (rev a @ h))"
unfolding bb using TS_x' by auto

from stars suffix have "T_on' (rTS h0) ([x, y], h) (a @ b) = length a - 1" by auto
then have whatineed: "T_on' (rTS h0) ([x, y], h) v = (length v - 2)" using vab bb by auto

have conf: "config' (rTS h0) ([x, y], h) v = ([x, y], rev v @ h)"
by(simp add: vab config'_append2 state suState)

from history obtain hs' where "rev a @ h = [x, y] @ hs'" by auto
then obtain hs2 where reva: "rev a @ h = x # hs2" by auto

show ?thesis using whatineed
apply(auto)
using conf apply(simp)
qed

lemma TS_c1'': assumes
"x ≠ y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
"set qs ⊆ {x, y}"
"qs ∈ lang (seq [Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
∧ T_on_rand' (embed (rTS h0)) s qs = (length qs - 2)"
proof -
from assms(1,2) have kas: "(x0=x ∧ y0=y) ∨ (y0=x ∧ x0=y)" by(auto)
then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] ∨ (∃hs. h = [x, x] @ hs)"
apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

have l: "qs ≠ []" using assms by auto
{
fix x y qs h0
fix h:: "nat list"
assume A: "x ≠ y"
and B: "qs ∈ lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
and C: "h = [] ∨ (∃hs. h = [x, x] @ hs)"

then have C': "(∃hs. h = [x, x] @ hs) ∨ h = [x] ∨ h = []" by blast
from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)

have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] ∧
T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 2"
apply(simp only: T_on'_embed[symmetric] config'_embed)
using ts_c'[OF A B C'] A lqs unfolding TS_inv'_det by auto
} note c1=this

show ?thesis unfolding S
using kas apply(rule disjE)
apply(simp only:)
apply(rule c1)
using assms apply(simp)
using h apply(simp)
apply(simp only:)

apply(subst TS_inv_sym[of y x x y])
using assms(1) apply(simp)
apply(blast)
defer
apply(rule c1)
using assms apply(simp)
using h apply(simp)
using last_in_set l assms(4) by blast
qed

lemma ts_c2': assumes "x ≠ y"
"qs ∈ lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
"(∃hs. h = [x, x] @ hs) ∨ h = []"
shows "T_on' (rTS h0) ([x, y], h) qs = (length qs - 3)
∧  config' (rTS h0) ([x,y], h) qs = ([x,y],rev qs@h) ∧ (∃hs. (rev qs @ h) = [x,x]@hs)"
proof -
from assms(2) obtain v where qs: "qs = [x]@v"
and V: "v∈lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"

from assms(3) have 3: "(∃hs. x#h = [x, x] @ hs) ∨ x#h = [x] ∨ x#h = []" by auto

from ts_c'[OF assms(1) V 3]
have T: "T_on' (rTS h0) ([x, y], x#h) v = length v - 2"
and C: "config' (rTS h0) ([x, y], x#h) v = ([x, y], rev v @ x#h)"
and H: "(∃hs. rev v @ x#h = [x, x] @ hs)" by auto

have t: "t⇩p [x, y] x (fst (snd (rTS h0) ([x, y], h) x)) = 0"
by (simp add: step_def rTS_def TS_step_d_def t⇩p_def)
have c: "Partial_Cost_Model.Step (rTS h0) ([x, y], h) x
= ([x,y], x#h)" by (simp add: Step_def rTS_def TS_step_d_def step_def)

show ?thesis
unfolding qs apply(safe)
apply(simp add: T_on'_append T c t)
using H by simp
qed

lemma TS_c2'': assumes
"x ≠ y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
"set qs ⊆ {x, y}"
"qs ∈ lang (seq [Atom x, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
∧ T_on_rand' (embed (rTS h0)) s qs = (length qs - 3)"
proof -
from assms(1,2) have kas: "(x0=x ∧ y0=y) ∨ (y0=x ∧ x0=y)" by(auto)
then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] ∨ (∃hs. h = [x, x] @ hs)"
apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

have l: "qs ≠ []" using assms by auto
{
fix x y qs h0
fix h:: "nat list"
assume A: "x ≠ y"
and B: "qs ∈ lang (seq[Atom x, Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
and C: "h = [] ∨ (∃hs. h = [x, x] @ hs)"

from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)

from C have C': "(∃hs. h = [x, x] @ hs) ∨ h = []" by blast

have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] ∧
T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = length qs - 3"
apply(simp only: T_on'_embed[symmetric] config'_embed)
using ts_c2'[OF A B C'] A lqs unfolding TS_inv'_det by auto
} note c2=this

show ?thesis unfolding S
using kas apply(rule disjE)
apply(simp only:)
apply(rule c2)
using assms apply(simp)
using h apply(simp)
apply(simp only:)

apply(subst TS_inv_sym[of y x x y])
using assms(1) apply(simp)
apply(blast)
defer
apply(rule c2)
using assms apply(simp)
using h apply(simp)
using last_in_set l assms(4) by blast
qed

lemma TS_c': assumes "x ≠ y" "h = [] ∨ (∃hs. h = [x, x] @ hs)"
"qs ∈ lang (seq [Plus (Atom x) rexp.One, Atom y, Atom x, Star (Times (Atom y) (Atom x)), Atom x])"
shows "T_on' (rTS h0) ([x, y], h) qs
≤ 2 * T⇩p [x, y] qs (OPT2 qs [x, y]) ∧  TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
proof -
obtain u v where uu: "u ∈ lang (Plus (Atom x) One)"
and vv: "v ∈ lang (seq[Times (Atom y) (Atom x), Star (Times (Atom y) (Atom x)), Atom x])"
and qsuv: "qs = u @ v"
using assms(3)
by (auto simp: conc_def)

from TS_xr'[OF assms(1) uu assms(2)] have
T_pre: "T_on' (rTS h0) ([x, y], h) (u@v) = T_on' (rTS h0) ([x, y], rev u @ h) v"
and fall': "(∃hs. (rev u @ h) = [x, x] @ hs) ∨ (rev u @ h) = [x] ∨ (rev u @ h)=[]"
and conf': "config' (rTS h0) ([x, y], h) (u @ v) =
config' (rTS h0) ([x, y], rev u @ h) v" by auto

with assms uu have fall: "(∃hs. (rev u @ h) = [x, x] @ hs) ∨ index (rev u @ h) y = length (rev u @ h)"
by(auto)

from ts_c'[OF assms(1) vv fall'] have
T_star: "T_on' (rTS h0) ([x, y], rev u @ h) v = (length v - 2)"
and inv1:   "config' (rTS h0) ([x, y], (rev u @ h)) v = ([x, y], rev v @ rev u @ h)"
and inv2:   "(∃hs. rev v @ rev u @ h = [x, x] @ hs)" by auto

from T_pre T_star qsuv have TS: "T_on' (rTS h0) ([x, y], h) qs = (length v - 2)" by metis

(* OPT *)

from uu have uuu: "u=[] ∨ u=[x]" by auto
from vv have vvv: "v ∈ lang (seq
[Atom y, Atom x,
Star (Times (Atom y) (Atom x)),
Atom x])" by(auto simp: conc_def)
have OPT: "T⇩p [x,y] qs (OPT2 qs [x,y]) = (length v) div 2" apply(rule OPT2_C) by(fact)+

have lqs: "last qs = x" using assms(3) by force

have conf: "config' (rTS h0) ([x, y], h) qs = ([x, y], rev qs @ h)"
then have conf: "TS_inv' (config' (rTS h0) ([x, y], h) qs) (last qs) [x,y]"
apply( subst TS_inv'_det)
using inv2 qsuv by(simp)

show ?thesis unfolding TS OPT
qed

subsubsection "xx"

lemma request_first: "x≠y ⟹ Step (rTS h) ([x, y], is) x = ([x,y],x#is)"
unfolding rTS_def Step_def by(simp add: split_def TS_step_d_def step_def)

lemma ts_d': "qs ∈ Lxx x y ⟹
x ≠ y ⟹
h = [] ∨ (∃hs. h = [x, x] @ hs) ⟹
qs ∈ lang (seq [Atom x, Atom x]) ⟹
T_on' (rTS h0) ([x, y], h) qs = 0 ∧
TS_inv' (config' (rTS h0) ([x, y], h) qs) x [x,y]"
proof -
assume xny: "x ≠ y"
assume "qs ∈ lang (seq [Atom x, Atom x])"
then have xx: "qs = [x,x]" by auto

from xny have TS: "T_on' (rTS h0) ([x, y], h) qs = 0" unfolding xx
by(auto simp add: Step_def step_def oneTS_steps rTS_def  t⇩p_def)

from xny have "config' (rTS h0) ([x, y], h) qs = ([x, y], x # x # h) "
by(auto simp add: xx Step_def rTS_def oneTS_steps step_def)

then have " TS_inv' (config' (rTS h0) ([x, y], h) qs) x [x, y]"

with TS  show ?thesis by simp
qed

lemma TS_d': assumes xny: "x ≠ y" and "h = [] ∨ (∃hs. h = [x, x] @ hs)"
and qsis: "qs ∈ lang (seq [Atom x, Atom x])"
shows "T_on' (rTS h0) ([x,y],h) qs ≤ 2 * T⇩p [x, y] qs (OPT2 qs [x, y]) "
and "TS_inv' (config' (rTS h0) ([x,y],h) qs)  (last qs) [x, y]"
and "T_on' (rTS h0) ([x,y],h) qs = 0"
proof -
from qsis have xx: "qs = [x,x]" by auto

show TS: "T_on' (rTS h0) ([x,y],h) qs = 0"
using assms(1) by (auto simp add: xx t⇩p_def rTS_def Step_def oneTS_steps step_def)
then show "T_on' (rTS h0) ([x,y],h) qs ≤ 2 * T⇩p [x, y] qs (OPT2 qs [x, y])" by simp

show "TS_inv' (config' (rTS h0) ([x,y],h) qs)  (last qs) [x, y]"
unfolding TS_inv_def
qed

lemma TS_d'': assumes
"x ≠ y" "{x, y} = {x0, y0}" "TS_inv s x [x0, y0]"
"set qs ⊆ {x, y}"
"qs ∈ lang (seq [Atom x, Atom x])"
shows "TS_inv (config'_rand (embed (rTS h0)) s qs) (last qs) [x0, y0]
∧ T_on_rand' (embed (rTS h0)) s qs = 0"
proof -
from assms(1,2) have kas: "(x0=x ∧ y0=y) ∨ (y0=x ∧ x0=y)" by(auto)
then obtain h where S: "s = return_pmf ([x,y],h)" and h: "h = [] ∨ (∃hs. h = [x, x] @ hs)"
apply(rule disjE) using assms(1,3) unfolding TS_inv_def by(auto)

have l: "qs ≠ []" using assms by auto
{
fix x y qs h0
fix h:: "nat list"
assume A: "x ≠ y"
and B: "qs ∈ lang (seq [Atom x, Atom x])"
and C: "h = [] ∨ (∃hs. h = [x, x] @ hs)"

from B have lqs: "last qs = x" using assms(5) by(auto simp add: conc_def)

have "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) qs) (last qs) [x, y] ∧
T_on_rand' (embed (rTS h0)) (return_pmf ([x, y], h)) qs = 0"
apply(simp only: T_on'_embed[symmetric] config'_embed)
using TS_d'[OF A C B ] A lqs unfolding TS_inv'_det by auto
} note d=this

show ?thesis unfolding S
using kas apply(rule disjE)
apply(simp only:)
apply(rule d)
using assms apply(simp)
using h apply(simp)
apply(simp only:)

apply(subst TS_inv_sym[of y x x y])
using assms(1) apply(simp)
apply(blast)
defer
apply(rule d)
using assms apply(simp)
using h apply(simp)
using last_in_set l assms(4) by blast
qed

subsection "Phase Partitioning"

lemma D': assumes "σ' ∈ Lxx x y" and "x ≠ y" and "TS_inv' ([x, y], h) x [x, y]"
shows  "T_on' (rTS h0) ([x, y], h) σ' ≤ 2 * T⇩p [x, y] σ' (OPT2 σ' [x, y])
∧  TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) σ') (last σ') [x, y]"
proof -

from config'_embed have " config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) σ'
= return_pmf (Partial_Cost_Model.config' (rTS h0) ([x, y], h) σ')" by blast

then have L: "TS_inv (config'_rand (embed (rTS h0)) (return_pmf ([x, y], h)) σ') (last σ') [x, y]
= TS_inv' (config' (rTS h0) ([x, y], h) σ')  (last σ') [x, y]" by auto

from assms(3) have
h: "h = [] ∨ (∃hs. h = [x, x] @ hs)"

have "T_on' (rTS h0) ([x, y], h) σ' ≤ 2 * T⇩p [x, y] σ' (OPT2 σ' [x, y])
∧  TS_inv' (config' (rTS h0) ([x, y], h) σ')  (last σ') [x, y]"
apply(rule LxxE[OF assms(1)])
using TS_d'[OF assms(2) h, of "σ'"] apply(simp)
using TS_b'[OF assms(2) h] apply(simp)
using TS_c'[OF assms(2) h] apply(simp)
using TS_a'[OF assms(2) h] apply fast
done

then show ?thesis using L by auto
qed

theorem TS_OPT2':  "(x::nat) ≠ y ⟹ set σ ⊆ {x,y}
⟹ T⇩p_on (rTS []) [x,y] σ  ≤ 2 * real (T⇩p_opt [x,y] σ) + 2"
apply(subst T_on_embed)
apply(rule Phase_partitioning_general[where P=TS_inv])
apply(simp)
apply(simp)
apply(simp)
proof (goal_cases)
case (1 a b σ' s)
from 1(6) obtain h hist' where s: "s = return_pmf ([a, b], h)"
and "h = [] ∨ h = [a,a]@hist'"
unfolding TS_inv_def apply(cases "a=hd [x,y]")
apply(simp) using 1 apply fast
apply(simp) using 1 by blast

from 1 have xyab: "TS_inv' ([a, b], h) a [x, y]
= TS_inv' ([a, b], h) a [a, b]"

with 1(6) s have inv: "TS_inv' ([a, b], h) a [a, b]" by simp

from ‹σ' ∈ Lxx a b› have "σ' ≠ []" using Lxx1 by fastforce
then have l: "last σ' ∈ {x,y}" using 1(5,7) last_in_set by blast

show ?case unfolding s T_on'_embed[symmetric]
using D'[OF 1(3,4) inv, of "[]"]
apply(safe)
apply linarith
using TS_inv_sym[OF 1(4,5)] l apply blast
done
qed

subsection "TS is pairwise"

lemma config'_distinct[simp]:
shows "distinct (fst (config' A S qs)) = distinct (fst S)"
apply (induct qs rule: rev_induct) by(simp_all add: config'_snoc Step_def split_def distinct_step)

lemma config'_set[simp]:
shows "set (fst (config' A S qs)) = set (fst S)"
apply (induct qs rule: rev_induct) by(simp_all add: config'_snoc Step_def split_def set_step)

lemma s_TS_append: "i≤length as ⟹s_TS init h (as@bs) i = s_TS init h as i"

lemma s_TS_distinct: "distinct init ⟹ i<length qs ⟹ distinct (fst (TSdet init h qs i))"

lemma othersdontinterfere: "distinct init ⟹ i < length qs ⟹ a∈set init ⟹ b∈set init
⟹ set qs ⊆ set init ⟹ qs!i∉{a,b} ⟹ a < b in s_TS init h qs i ⟹ a < b in s_TS init h qs (Suc i)"
apply(simp add: s_TS_def split_def take_Suc_conv_app_nth config_append Step_def step_def)
apply(subst x_stays_before_y_if_y_not_moved_to_front)
by(auto simp: rTS_def TS_step_d_def)

lemma  TS_mono:
fixes l::nat
assumes 1: "x < y in s_TS init h xs (length xs)"
and l_in_cs: "l ≤ length cs"
and firstocc: "∀j<l. cs ! j ≠ y"
and "x ∉ set cs"
and di: "distinct init"
and inin: "set (xs @ cs) ⊆ set init"
shows "x < y in s_TS init h (xs@cs) (length (xs)+l)"
proof -
from before_in_setD2[OF 1] have y: "y : set init" unfolding s_TS_def by(simp add: config_config_set)
from before_in_setD1[OF 1] have x: "x : set init" unfolding s_TS_def by(simp add: config_config_set)

{
fix n
assume "n≤l"
then have "x < y in s_TS init h ((xs)@cs) (length (xs)+n)"
proof(induct n)
case 0
show ?case apply (simp only: s_TS_append ) using 1 by(simp)
next
case (Suc n)
then have n_lt_l: "n<l" by auto
show ?case apply(simp)
apply(rule othersdontinterfere)
apply(rule di)
using n_lt_l l_in_cs apply(simp)
apply(fact x)
apply(fact y)
apply(fact inin)
using assms(4) n_lt_l l_in_cs apply fastforce
using firstocc n_lt_l apply blast
using Suc(1) n_lt_l by(simp)
qed
}
― ‹before the request to y, x is in front of y›
then show "x < y in s_TS init h (xs@cs) (length (xs)+l)"
by blast
qed

lemma step_no_action: "step s q (0,[]) = s"
unfolding step_def mtf2_def by simp

lemma s_TS_set: "i ≤ length qs ⟹ set (s_TS init h qs i) = set init"
apply(induct i)
by(simp add: split_def rTS_def Step_def step_def)

lemma count_notin2: "count_list xs x = 0 ⟹ x ∉ set xs"
apply (induction xs)  apply (auto del: count_notin)
apply(case_tac "a=x") by(simp_all)+

lemma count_append: "count_list (xs@ys) x = count_list xs x + count_list ys x"
apply(induct xs) by(simp_all)

lemma count_rev: "count_list (rev xs) x = count_list xs x"
apply(induct xs) by(simp_all add: count_append )

lemma mtf2_q_passes: assumes "q ∈ set xs" "distinct xs"
and "index xs q - n ≤ index xs x" "index xs x < index xs q"
shows "q < x in (mtf2 n q xs)"
proof -
from assms have "index xs q < length xs" by auto
with assms(4) have ind_x: "index xs x < length xs" by auto
then have xinxs: "x∈set xs" using index_less_size_conv by metis

have B: "index (mtf2 n q xs) q = index xs q - n"
apply(rule mtf2_q_after)
by(fact)+
also from ind_x mtf2_forward_effect3'[OF assms]
have A: "… < index (mtf2 n q xs) x" by auto
finally show ?thesis unfolding before_in_def using xinxs by force
qed

lemma twotox:
assumes "count_list bs y ≤ 1"
and "distinct init"
and "x ∈ set init"
and "y : set init"
and "x ∉ set bs"
and "x≠y"
shows "x < y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))"
proof -
have aa: "snd (TSdet init h ((as @ x # bs) @ [x]) (Suc (length as + length bs)))
= rev (take (Suc (length as + length bs)) ((as @ x # bs) @ [x])) @ h"
apply(rule sndTSdet)  by(simp)
then have aa': "snd (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))
= rev (take (Suc (length as + length bs)) ((as @ x # bs) @ [x])) @ h" by auto
have lasocc_x: "index (snd (TSdet init h ((as @ x # bs) @ [x]) (Suc (length as + length bs)))) x = length bs"
unfolding aa
then have lasocc_x': "(index (snd (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x) = length bs" by auto

let ?sincelast = "take (length bs)
(snd (TSdet init h ((as @ x # bs) @ [x])
(Suc (length as + length bs))))"
have sl: "?sincelast  = rev bs" unfolding aa by(simp)
let ?S = "{xa. xa < x in fst (TSdet init h (as @ x # bs @ [x])
(Suc (length as + length bs))) ∧
count_list ?sincelast xa ≤ 1}"

have y: "y ∈ ?S ∨ ~  y < x  in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))"
unfolding sl unfolding s_TS_def using assms(1) by(simp add: count_rev del: config'.simps)

have eklr: "length (as@[x]@bs@[x]) = Suc (length (as@[x]@bs))" by simp
have 1: "s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))
= fst (Partial_Cost_Model.Step (rTS h)
(TSdet init h (as @ [x] @ bs @ [x])
(length (as @ [x] @ bs)))
((as @ [x] @ bs @ [x]) ! length (as @ [x] @ bs)))" unfolding s_TS_def unfolding eklr apply(subst TSdet_Suc)

have brrr: "x∈ set (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))"
apply(subst s_TS_set[unfolded s_TS_def])
apply(simp) by fact
have ydrin: "y∈set (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))"
apply(subst s_TS_set[unfolded s_TS_def]) apply(simp) by fact
have dbrrr: "distinct (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs))))"
apply(subst s_TS_distinct[unfolded s_TS_def]) using assms(2) by(simp_all)

show ?thesis
proof (cases "y < x  in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))")
case True
with y have yS: "y∈?S" by auto
then have minsteps: "Min (index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) ` ?S)
≤ index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y"
by auto
let ?entf = "index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x -
Min (index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) ` ?S)"
from minsteps have br: " index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x - (?entf)
≤ index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y"
by presburger
have brr: "index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
< index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x"
using True unfolding before_in_def s_TS_def by auto

from br brr have klo: " index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x - (?entf)
≤ index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
∧ index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) y
< index (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))) x" by metis

let ?result ="(mtf2 ?entf x (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))))"

have whatsthat: "s_TS init h (as @ [x] @ bs @ [x]) (length (as @ [x] @ bs @ [x]))
= ?result"
unfolding 1 apply(simp add: split_def step_def rTS_def Step_def TS_step_d_def del: config'.simps)
using lasocc_x'[unfolded rTS_def] aa'[unfolded rTS_def]
using yS[unfolded sl rTS_def] by auto

have ydrinee: "  y ∈ set (mtf2 ?entf x (fst (TSdet init h (as @ x # bs @ [x]) (Suc (length as + length bs)))))"
apply(subst set_mtf2)
apply(subst s_TS_set[unfolded s_TS_def]) apply(simp) by fact

show ?thesis unfolding whatsthat apply(rule mtf2_q_passes) by(fact)+
next
case False
then have 2: "x < y  in s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs))"
using brrr ydrin not_before_in assms(6) unfolding s_TS_def by metis
{
fix e
have "x < y in mtf2 e x (s_TS init h (as @ x # bs @ [x]) (Suc (length as + length bs)))"
apply(rule x_stays_before_y_if_y_not_moved_to_front)
unfolding s_TS_def
apply(fact)+
using assms(6) apply(simp)
using 2 unfolding s_TS_def by simp
} note bratz=this
show ?thesis unfolding 1 apply(simp add: TSnopaid split_def Step_def s_TS_def TS_step_d_def step_def nth_append  del: config'.simps)
using bratz[unfolded s_TS_def] by simp
qed

qed

lemma count_drop: "count_list (drop n cs) x ≤ count_list cs x"
proof -
have "count_list cs x = count_list (take n cs @ drop n cs) x" by auto
also have "… = count_list (take n cs) x + count_list (drop n cs) x" by (rule count_append)
also have "… ≥ count_list (drop n cs) x" by auto
finally show ?thesis .
qed

lemma count_take_less: assumes "n≤m"
shows "count_list (take n cs) x ≤ count_list (take m cs) x"
proof -
from assms have "count_list (take n cs) x = count_list (take n (take m cs)) x" by auto
also have "… ≤ count_list (take n (take m cs) @ drop n (take m cs)) x" by (simp only: count_append)
also have "… = count_list (take m cs) x"
by(simp only: append_take_drop_id)
finally show ?thesis .
qed

lemma count_take: "count_list (take n cs) x ≤ count_list cs x"
proof -
have "count_list cs x = count_list (take n cs @ drop n cs) x" by auto
also have "… = count_list (take n cs) x + count_list (drop n cs) x" by (rule count_append)
also have "… ≥ count_list (take n cs) x" by auto
finally show ?thesis .
qed

lemma casexxy: assumes "σ=as@[x]@bs@[x]@cs"
and "x ∉ set cs"
and "set cs ⊆ set init"
and "x ∈ set init"
and "distinct init"
and "x ∉ set bs"
and "set as ⊆ set init"
and "set bs ⊆ set init"
shows "(%i. i<length cs ⟶ (∀j<i. cs!j≠cs!i) ⟶ cs!i≠x
⟶ (cs!i) ∉ set bs
⟶ x < (cs!i) in  (s_TS init h σ (length (as@[x]@bs@[x]) + i+1))) i"
proof (rule infinite_descent[where P="(%i. i<length cs ⟶ (∀j<i. cs!j≠cs!i) ⟶ cs!i≠x
⟶ (cs!i) ∉ set bs
⟶ x < (cs!i) in  (s_TS init h σ (length (as@[x]@bs@[x]) + i+1)))"], goal_cases)
case (1 i)
let ?y = "cs!i"
from 1 have i_in_cs: "i < length cs" and
firstocc: "(∀j<i. cs ! j ≠ cs ! i)"
and ynx: "cs ! i ≠ x"
and ynotinbs: "cs ! i ∉ set bs"
and y_before_x': "~x < cs ! i in s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1)" by auto

have ss: "set (s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1)) = set init" using assms(1) i_in_cs by(simp add: s_TS_set)
then have "cs ! i ∈ set (s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1))"
unfolding ss using assms(3) i_in_cs by fastforce
moreover have "x : set (s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1))"
unfolding ss using assms(4) by fastforce

― ‹after the request to y, y is in front of x›
ultimately have y_before_x_Suct3: "?y < x in s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1)"
using  y_before_x' ynx not_before_in by metis

from ynotinbs have yatmostonceinbs: "count_list bs (cs!i) ≤ 1" by simp

let ?y = "cs!i"
have yininit: "?y ∈ set init" using assms(3) i_in_cs by fastforce
{
fix y
assume "y ∈ set init"
assume "x≠y"
assume "count_list bs y ≤ 1"
then have "x < y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))"
apply(rule twotox) by(fact)+
} note xgoestofront=this
with yatmostonceinbs ynx yininit have zeitpunktt2: "x < ?y in s_TS init h (as@[x]@bs@[x]) (length (as@[x]@bs@[x]))" by blast

have "i ≤ length cs" using i_in_cs by auto
have x_before_y_t3: "x < ?y in s_TS init h ((as@[x]@bs@[x])@cs) (length (as@[x]@bs@[x])+i)"
apply(rule TS_mono)
apply(fact)+
using assms by simp
― ‹so x and y swap positions when y is requested, that means that y was inserted infront of
some elment z (which cannot be x, has only been requested at most once since last request of y
but is in front of x)›

― ‹first show that y must have been requested in as›

have "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i)) =
rev (take (length (as @ [x] @ bs @ [x]) + i) (as @ [x] @ bs @ [x] @ cs)) @ h"
apply(rule sndTSdet) using i_in_cs by simp
also have "…  = (rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" by simp
finally have fstTS_t3: "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i)) =
(rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" .
then have fstTS_t3': "(snd (TSdet init h σ (Suc (Suc (length as + length bs + i))))) =
(rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" using assms(1) by auto

let ?is = "snd (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i))"
let ?is' = "snd (config (rTS h) init (as @ [x] @ bs @ [x] @ (take i cs)))"
let ?s = "fst (TSdet init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i))"
let ?s' = "fst (config (rTS h) init (as @ [x] @ bs @ [x] @ (take i cs)))"
let ?s_Suct3="s_TS init h (as @ [x] @ bs @ [x] @ cs) (length (as @ [x] @ bs @ [x]) + i+1)"

let ?S = "{xa. (xa < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s ∧
count_list (take (index ?is ((as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i))) ?is) xa ≤ 1) }"
let ?S' = "{xa. (xa < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s' ∧
count_list (take (index ?is' ((cs!i))) ?is') xa ≤ 1) }"

have isis': "?is = ?is'" by(simp)
have ss': "?s = ?s'" by(simp)
then have SS': "?S = ?S'" using i_in_cs by(simp add: nth_append)

(* unfold TSdet once *)
have once: "TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (Suc (length as + length bs + i))))
= Step (rTS h) (config⇩p (rTS h) init (as @ x # bs @ x # take i cs)) (cs ! i)"
apply(subst TSdet_Suc)
using i_in_cs apply(simp)

have aha: "(index ?is (cs ! i) ≠ length ?is)
∧ ?S ≠ {}"
proof (rule ccontr, goal_cases)
case 1
then have "(index ?is (cs ! i) = length ?is) ∨ ?S = {}" by(simp)
then have alters: "(index ?is' (cs ! i) = length ?is') ∨ ?S' = {}"
apply(simp only: SS') by(simp only: isis')
― ‹wenn (cs ! i) noch nie requested wurde, dann kann es gar nicht nach vorne gebracht werden!
also widerspruch mit @{text y_before_x'}›
have "?s_Suct3 = fst (config (rTS h) init ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)))"
unfolding s_TS_def
apply(simp only: length_append)
apply(subst take_append)
apply(subst take_append)
apply(subst take_append)
apply(subst take_append)
by(simp)
also have "… =  fst (config (rTS h) init (((as @ [x] @ bs @ [x]) @ (take i cs)) @ [cs!i]))"
also have "… = step ?s' ?y (0, [])"
proof (cases "index ?is' (cs ! i) = length ?is'")
case True
show ?thesis
apply(subst config_append)
using i_in_cs apply(simp add: rTS_def Step_def split_def nth_append)
apply(subst TS_step_d_def)
apply(simp only: True[unfolded rTS_def,simplified])
by(simp)
next
case False
with alters have S': "?S' = {}" by simp

have 1 : "{xa. xa < cs ! i
in fst (Partial_Cost_Model.config' (λs. h, TS_step_d) (init, h)
(as @ x # bs @ x # take i cs)) ∧
count_list (take (index
(snd
(Partial_Cost_Model.config'
(λs. h, TS_step_d) (init, h)
(as @ x # bs @ x # take i cs)))
(cs ! i))
(snd
(Partial_Cost_Model.config'
(λs. h, TS_step_d) (init, h)
(as @ x # bs @ x # take i cs)))) xa ≤ 1} = {}" using S' by(simp add: rTS_def nth_append)

show ?thesis
apply(subst config_append)
using i_in_cs apply(simp add: rTS_def Step_def split_def nth_append)
apply(subst TS_step_d_def)
apply(simp only: 1 Let_def)
by(simp)
qed
finally have "?s_Suct3 = step ?s ?y (0, [])" using ss' by simp
then have e: "?s_Suct3 = ?s" by(simp only: step_no_action)
from x_before_y_t3 have "x < cs ! i in ?s_Suct3" unfolding e unfolding s_TS_def by simp
with y_before_x' show "False" unfolding assms(1) by auto
qed
then have aha': "index (snd (TSdet init h (as @ x # bs @ x # cs)  (Suc (Suc (length as + length bs + i)))))
(cs ! i) ≠
length (snd (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (length as + length bs + i)))))"
and
aha2: "?S ≠ {}" by auto

from fstTS_t3' assms(1) have is_: "?is = (rev (take i cs)) @ [x] @ (rev bs) @ [x] @ (rev as) @ h" by auto

have minlencsi: " min (length cs) i = i" using i_in_cs by linarith

let ?lastoccy="(index (rev (take i cs) @ x # rev bs @ x # rev as @ h) (cs ! i))"
have "?y ∉ set (rev (take i cs))" using firstocc by (simp add: in_set_conv_nth)
then have lastoccy: "?lastoccy ≥
i + 1 + length bs + 1" using ynx ynotinbs minlencsi by(simp add: index_append)

(* x is not in S, because it is requested at least twice since the last request to y*)
have x_nin_S: "x∉?S"
using is_ apply(simp add: split_def nth_append del: config'.simps)
proof (goal_cases)
case 1
have " count_list (take ?lastoccy (rev (take i cs))) x ≤
count_list (drop (length cs - i) (rev cs)) x" by (simp add: count_take rev_take)
also have "… ≤ count_list (rev cs) x" by(simp add: count_drop )
also have "… = 0" using assms(2) by(simp add: count_rev)
finally have " count_list (take ?lastoccy (rev (take i cs))) x = 0" by auto
have"
2 ≤
count_list ([x] @ rev bs @ [x]) x " apply(simp only: count_append) by(simp)
also have "… = count_list (take (1 + length bs + 1) (x # rev bs @ x # rev as @ h)) x" by auto
also have "… ≤ count_list (take (?lastoccy - i) (x # rev bs @ x # rev as @ h)) x"
apply(rule count_take_less)
using lastoccy by linarith
also have   "… ≤  count_list (take ?lastoccy (rev (take i cs))) x
+ count_list (take (?lastoccy - i) (x # rev bs @ x # rev as @ h)) x" by auto
also have "… = count_list (take ?lastoccy (rev (take i cs))
@ take (?lastoccy - min (length cs) i)
(x # rev bs @ x # rev as @ h)) x"
finally show ?case by presburger
qed

have "Min (index ?s ` ?S) ∈ (index ?s ` ?S)" apply(rule Min_in) using aha2 by (simp_all)
then obtain z where zminimal: "index ?s z = Min (index ?s ` ?S)"and z_in_S: "z ∈ ?S" by auto
then have bef: "z < (as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i) in ?s"
and "count_list (take (index ?is ((as @ [x] @ bs @ [x] @ cs) ! (length (as @ [x] @ bs @ [x]) + i))) ?is) z ≤ 1" by(blast)+

with zminimal have zbeforey: "z < cs ! i in ?s"
and zatmostonce: "count_list (take (index ?is (cs ! i)) ?is) z ≤ 1"
and isminimal: "index ?s z = Min (index ?s ` ?S)" by(simp_all add: nth_append)
have elemins: "z ∈ set ?s" unfolding before_in_def by (meson zbeforey before_in_setD1)
then  have zininit: "z ∈ set init"
using i_in_cs by(simp add: s_TS_set[unfolded s_TS_def] del: config'.simps)

from zbeforey have zbeforey_ind: "index ?s z < index ?s ?y" unfolding before_in_def by auto
then have el_n_y: "z ≠ ?y" by auto

have el_n_x: "z ≠ x" using x_nin_S  z_in_S by blast

(* and because it is JUST before that element, z must be before x *)
{ fix s q
have TS_step_d2: "TS_step_d s q =
(let V⇩r={x. x < q in fst s ∧ count_list (take (index (snd s) q) (snd s)) x ≤ 1}
in ((if index (snd s) q ≠ length (snd s) ∧ V⇩r ≠ {}
then index (fst s) q - Min ( (index (fst s)) ` V⇩r)
else 0,[]),q#(snd s)))"
unfolding TS_step_d_def
apply(cases "index (snd s) q < length (snd s)")
using index_le_size apply(simp split: prod.split) apply blast
by(auto simp add: index_less_size_conv split: prod.split)
} note alt_chara=this

have iF: "(index (snd (config' (λs. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) (cs ! i)
≠ length (snd (config' (λs. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) ∧
{xa. xa < cs ! i in fst (config' (λs. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs)) ∧
count_list
(take (index (snd (config' (λs. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))) (cs ! i))
(snd (Partial_Cost_Model.config' (λs. h, TS_step_d) (init, h) (as @ x # bs @ x # take i cs))))
xa
≤ 1} ≠
{}) = True" using aha[unfolded rTS_def] ss' SS' by(simp add: nth_append)

have "?s_Suct3 = fst (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (Suc (length as + length bs + i)))))"
also have "… = step ?s ?y (index ?s ?y - Min (index ?s ` ?S), [])"
apply(simp only: once[unfolded assms(1)])
apply(simp add: Step_def split_def rTS_def del: config'.simps)
apply(subst alt_chara)
apply(simp only: Let_def )
apply(simp only: iF)
finally have "?s_Suct3 = step ?s ?y (index ?s ?y - Min (index ?s ` ?S), [])" .
with isminimal have state_dannach: "?s_Suct3 = step ?s ?y (index ?s ?y - index ?s z, [])" by presburger

― ‹so y is moved in front of z, that means:›
have yinfrontofz: "?y < z in s_TS init h σ (length (as @ [x] @ bs @ [x]) + i+1)"
unfolding   assms(1) state_dannach apply(simp add: step_def del: config'.simps)
apply(rule mtf2_q_passes)
using i_in_cs assms(5) apply(simp_all add: s_TS_distinct[unfolded s_TS_def] s_TS_set[unfolded s_TS_def])
using yininit apply(simp)
using zbeforey_ind by simp

have yins: "?y ∈ set ?s"
using i_in_cs assms(3,5)  apply(simp_all add:   s_TS_set[unfolded s_TS_def] del: config'.simps)
by fastforce

have "index ?s_Suct3 ?y = index ?s z"
and "index ?s_Suct3 z = Suc (index ?s z)"
proof -
let ?xs = "(fst (TSdet init h (as @ x # bs @ x # cs) (Suc (Suc (length as + length bs + i)))))"
have setxs: "set ?xs = set init"
apply(rule  s_TS_set[unfolded s_TS_def])
using i_in_cs by auto
then have yinxs: "cs ! i ∈ set  ?xs"
using assms(3) i_in_cs by fastforce

have distinctxs: "distinct ?xs"
apply(rule  s_TS_distinct[unfolded s_TS_def])
using i_in_cs assms(5) by auto

let ?n = "(index
(fst (TSdet init h (as @ x # bs @ x # cs)
(Suc (Suc (length as + length bs + i)))))
(cs ! i) -
index
(fst (TSdet init h (as @ x # bs @ x # cs)
(Suc (Suc (length as + length bs + i)))))
z)"

have "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?xs ?y - ?n∧
index ?xs ?y - ?n = index (mtf2 ?n ?y ?xs) (?xs !  index ?xs ?y )"
apply(rule mtf2_forward_effect2)
apply(fact)
apply(fact)
by simp

then have  "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?xs ?y - ?n" by metis
also have "… = index ?s z" using zbeforey_ind by force
finally have A: "index (mtf2 ?n ?y ?xs) (?xs ! index ?xs ?y) = index ?s z" .

have aa: "index ?xs ?y - ?n ≤ index ?xs z" "index ?xs z < index ?xs ?y"
apply(simp)
using zbeforey_ind by fastforce

from mtf2_forward_effect3'[OF yinxs distinctxs aa]
have B: "index (mtf2 ?n ?y ?xs) z = Suc (index ?xs z)"
using elemins yins by(simp add: nth_append split_def del: config'.simps)

show "index ?s_Suct3 ?y = index ?s z"
unfolding state_dannach apply(simp add: step_def nth_append del: config'.simps)
using A yins by(simp add: nth_append  del: config'.simps)

show "index ?s_Suct3 z = Suc (index ?s z)"
unfolding state_dannach apply(simp add: step_def nth_append del: config'.simps)
using B yins by(simp add: nth_append  del: config'.simps)
qed

then have are: "Suc (index ?s_Suct3 ?y) = index ?s_Suct3 z" by presburger

from are before_in_def y_before_x_Suct3 el_n_x  assms(1) have z_before_x: "z < x in ?s_Suct3"
by (metis Suc_lessI not_before_in yinfrontofz)

have xSuct3: "x∈set ?s_Suct3" using assms(4) i_in_cs by(simp add: s_TS_set)
have elSuct3: "z∈set ?s_Suct3" using zininit i_in_cs by(simp add: s_TS_set)

have xt3: "x∈set ?s " apply(subst config_config_set) by fact

note elt3=elemins

have z_s: "z < x in ?s"
proof(rule ccontr, goal_cases)
case 1
then have "x < z in ?s" using not_before_in[OF xt3 elt3] el_n_x unfolding s_TS_def by blast
then have "x < z in ?s_Suct3"
apply (simp only: state_dannach)
apply (simp only: step_def)
apply(rule x_stays_before_y_if_y_not_moved_to_front)
apply(subst config_config_set) using i_in_cs assms(3) apply fastforce
apply(subst config_config_distinct) using assms(5) apply fastforce
apply(subst config_config_set) using assms(4) apply fastforce
apply(subst config_config_set) using zininit apply fastforce
using el_n_y apply(simp)
by(simp)

then show "False" using z_before_x not_before_in[OF xSuct3 elSuct3] by blast
qed

have mind: "(index ?is (cs ! i)) ≥ i + 1 + length bs + 1 " using lastoccy
using i_in_cs fstTS_t3'[unfolded assms(1)] by(simp add: split_def nth_append del: config'.simps)

have "count_list (rev (take i cs) @ [x] @ rev bs @ [x]) z=
count_list (take (i + 1 + length bs + 1) ?is) z" unfolding is_
using el_n_x by(simp add: minlencsi count_append )
also from mind have "…
≤ count_list (take (index ?is (cs ! i)) ?is) z"
by(rule count_take_less)
also have "… ≤ 1" using zatmostonce by metis
finally have aaa: "count_list (rev (take i cs) @ [x] @ rev bs @ [x]) z ≤ 1" .
with el_n_x have "count_list bs z + count_list (take i cs) z ≤ 1"
moreover have "count_list (take (Suc i) cs) z = count_list (take i cs) z"
using i_in_cs  el_n_y by(simp add: take_Suc_conv_app_nth count_append)
ultimately have aaaa: "count_list bs z + count_list (take  (Suc i) cs) z ≤ 1" by simp

have z_occurs_once_in_cs: "count_list (take (Suc i) cs) z = 1"
proof (rule ccontr, goal_cases)
case 1
with aaaa have atmost1: "count_list bs z ≤ 1" and "count_list (take (Suc i) cs) z = 0" by force+
have yeah: "z ∉ set (take (Suc i) cs)" apply(rule count_notin2) by fact

― ‹now we know that x is in front of z after 2nd request to x, and that z is not requested any more,
that means it stays behind x, which leads to a contradiction with @{text z_before_x}›

have xin123: "x ∈ set (s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1)))"
using i_in_cs assms(4) by(simp add: s_TS_set)
have zin123: "z ∈ set (s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1)))"
using i_in_cs elemins by(simp add: s_TS_set  del: config'.simps)

have "x < z in s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i + 1))"
apply(rule TS_mono)
apply(rule xgoestofront)
apply(fact) using el_n_x apply(simp) apply(fact)
using i_in_cs apply(simp)
using yeah i_in_cs length_take  nth_mem
apply (metis Suc_eq_plus1 Suc_leI min_absorb2)
using set_take_subset assms(2) apply fast
using assms i_in_cs  apply(simp_all ) using set_take_subset by fast
then have ge: "¬ z < x in s_TS init h ((as @ [x] @ bs @ [x]) @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))"
using not_before_in[OF zin123 xin123] el_n_x by blast

have " s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + (i+1))
= s_TS init h ((as @ [x] @ bs @ [x] @ (take (i+1) cs)) @ (drop (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))" by auto
also have "…
= s_TS init h (as @ [x] @ bs @ [x] @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))"
apply(rule s_TS_append)
using i_in_cs by(simp)
finally have aaa: " s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + (i+1))
= s_TS init h (as @ [x] @ bs @ [x] @ (take (i+1) cs)) (length (as @ [x] @ bs @ [x]) + (i+1))" .

from ge z_before_x show "False" unfolding assms(1) using aaa by auto
qed
from z_occurs_once_in_cs have kinSuci: "z ∈ set (take (Suc i) cs)" by (metis One_nat_def count_notin n_not_Suc_n)
then have zincs: "z∈set cs" using set_take_subset by fast
from z_occurs_once_in_cs  obtain k where k_def: "k=index (take (Suc i) cs) z" by blast

then have "k=index cs z" using kinSuci by (simp add: index_take_if_set)
then have zcsk: "z = cs!k" using zincs by simp

have era: " cs ! index (take (Suc i) cs) z = z" using kinSuci in_set_takeD index_take_if_set by fastforce
have ki: "k<i" unfolding k_def using kinSuci el_n_y
by (metis i_in_cs index_take index_take_if_set le_neq_implies_less not_less_eq_eq yes)
have zmustbebeforex: "cs!k < x in ?s"
unfolding k_def era by (fact z_s)

― ‹before the request to z, x is in front of z, analog zu oben, vllt generell machen?›

― ‹element z does not occur between t1 and position k›
have  z_notinbs: "cs ! k ∉ set bs"
proof -
from z_occurs_once_in_cs aaaa have "count_list bs z = 0" by auto
then show ?thesis using zcsk count_notin2 by metis
qed

have "count_list bs z ≤ 1" using aaaa by linarith
with xgoestofront[OF zininit el_n_x[symmetric]] have xbeforez: "x < z in s_TS init h (as @ [x] @ bs @ [x]) (length (as @ [x] @ bs @ [x]))" by auto

obtain cs1 cs2 where v: "cs1 @ cs2 = cs" and cs1: "cs1 = take (Suc k) cs" and cs2: "cs2 = drop (Suc k) cs" by auto

have z_firstocc:  "∀j<k.  cs ! j ≠ cs ! k"
and z_lastocc:  "∀j<i-k-1.  cs2 ! j ≠ cs ! k"
proof (safe, goal_cases)
case (1 j)
with ki i_in_cs have 2: "j < length (take k cs)" by auto
have un1: "(take (Suc i) cs)!k = cs!k" apply(rule nth_take) using ki by auto
have un2: "(take k cs)!j = cs!j" apply(rule nth_take) using 1(1) ki by auto

from i_in_cs ki have f1: "k < length (take (Suc i) cs)" by auto
then have "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ (take (Suc i) cs)!k # (drop (Suc k) (take (Suc i) cs))"
by(rule id_take_nth_drop)
also have "(take k (take (Suc i) cs)) = take k cs" using i_in_cs ki by (simp add: min_def)
also have "... = (take j (take k cs)) @ (take k cs)!j # (drop (Suc j) (take k cs))"
using 2 by(rule id_take_nth_drop)
finally have "take (Suc i) cs
=  (take j (take k cs)) @ [(take k cs)!j] @ (drop (Suc j) (take k cs))
@ [(take (Suc i) cs)!k] @ (drop (Suc k) (take (Suc i) cs))"
by(simp)
then have A: "take (Suc i) cs
=  (take j (take k cs)) @ [cs!j] @ (drop (Suc j) (take k cs))
@ [cs!k] @ (drop (Suc k) (take (Suc i) cs))"
unfolding un1 un2 by simp
have "count_list ((take j (take k cs)) @ [cs!j] @ (drop (Suc j) (take k cs))
@ [cs!k] @ (drop (Suc k) (take (Suc i) cs))) z ≥ 2"
using zcsk 1(2) by(simp)
with A have "count_list (take (Suc i) cs) z ≥ 2" by auto
with z_occurs_once_in_cs show "False" by auto
next
case (2 j)
then have 1: "Suc k+j < i" by auto
then have f2: "j < length (drop (Suc k) (take (Suc i) cs))" using i_in_cs by simp
have 3: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
@ (drop (Suc k) (take (Suc i) cs))! j
# drop (Suc j) (drop (Suc k) (take (Suc i) cs))"
using f2 by(rule id_take_nth_drop)
have "(drop (Suc k) (take (Suc i) cs))! j = (take (Suc i) cs) ! (Suc k+j)"
apply(rule nth_drop) using i_in_cs 1 by auto
also have "… = cs ! (Suc k+j)" apply(rule nth_take) using 1 by auto
finally have 4: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
@ cs! (Suc k +j)
# drop (Suc j) (drop (Suc k) (take (Suc i) cs))"
using 3 by auto
have 5: "cs2 ! j = cs! (Suc k +j)" unfolding cs2
apply(rule nth_drop) using i_in_cs 1 by auto

from 4 5 2(2) have 6: "(drop (Suc k) (take (Suc i) cs)) = take j (drop (Suc k) (take (Suc i) cs))
@ cs! k
# drop (Suc j) (drop (Suc k) (take (Suc i) cs))" by auto

from i_in_cs ki have 1: "k < length (take (Suc i) cs)" by auto
then have 7: "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ (take (Suc i) cs)!k # (drop (Suc k) (take (Suc i) cs))"
by(rule id_take_nth_drop)
have 9: "(take (Suc i) cs)!k = z" unfolding zcsk apply(rule nth_take) using ki by auto
from 6 7 have A: "(take (Suc i) cs) = (take k (take (Suc i) cs)) @ z # take j (drop (Suc k) (take (Suc i) cs))
@ z
# drop (Suc j) (drop (Suc k) (take (Suc i) cs))" using ki 9  by auto

have "count_list ((take k (take (Suc i) cs)) @ z # take j (drop (Suc k) (take (Suc i) cs))
@ z
# drop (Suc j) (drop (Suc k) (take (Suc i) cs))) z
≥ 2"
with A have "count_list (take (Suc i) cs) z ≥ 2" by auto
with z_occurs_once_in_cs show "False" by auto
qed

have k_in_cs: "k < length cs" using ki i_in_cs by auto
with cs1 have lenkk: "length cs1 = k+1" by auto
from k_in_cs have mincsk: "min (length cs) (Suc k) = Suc k" by auto

have "s_TS init h (((as@[x]@bs@[x])@cs1) @ cs2) (length (as@[x]@bs@[x])+k+1)
= s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x])+k+1)"
apply(rule s_TS_append)
using cs1 cs2 k_in_cs by(simp)
then have spliter: "s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x]@(cs1)))
= s_TS init h ((as@[x]@bs@[x])@cs) (length (as@[x]@bs@[x])+k+1) "

from cs2 have "length cs2 = length cs - (Suc k)" by auto

have notxbeforez: "~ x < z in s_TS init h σ (length (as @ [x] @ bs @ [x]) + k + 1)"
proof (rule ccontr, goal_cases)
case 1
then have a: "x < z in s_TS init h ((as@[x]@bs@[x])@(cs1)) (length (as@[x]@bs@[x]@(cs1)))"
unfolding spliter assms(1) by auto

have 41: "x ∈ set(s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + i))"
using i_in_cs assms(4) by(simp add: s_TS_set)
have 42: "z ∈ set(s_TS init h ((as @ [x] @ bs @ [x]) @ cs) (length (as @ [x] @ bs @ [x]) + i))"
using i_in_cs zininit by(simp add: s_TS_set)

have rewr: "s_TS init h ((as@[x]@bs@[x]@cs1)@cs2) (length (as@[x]@bs@[x]@cs1)+(i-k-1)) =
s_TS init h (as@[x]@bs@[x]@cs) (length (as@[x]@bs@[x])+i)"

have "x < z in s_TS init h ((as@[x]@bs@[x]@cs1)@cs2) (length (as@[x]@bs@[x]@cs1)+(i-k-1))"
apply(rule TS_mono)
using a apply(simp)
using cs2 i_in_cs ki v cs1 apply(simp)
using z_lastocc zcsk apply(simp)
using v assms(2) apply force
using assms by(simp_all add: cs1 cs2)

from zmustbebeforex this[unfolded rewr ] el_n_x zcsk 41 42 not_before_in show "False"
unfolding s_TS_def  by fastforce
qed

have 1: "k < length cs"
"(∀j<k. cs ! j ≠ cs ! k)"
"cs ! k ≠ x" "cs ! k ∉ set bs"
"~ x < z in s_TS init h σ (length (as @ [x] @ bs @ [x]) + k + 1)"
apply(safe)
using ki i_in_cs apply(simp)
using z_firstocc apply(simp)
using assms(2) ki i_in_cs apply(fastforce)
using z_notinbs apply(simp)
using notxbeforez by auto

show ?case apply(simp only: ex_nat_less_eq)
apply(rule bexI[where x=k])
using 1 zcsk apply(simp)
using ki by simp
qed

lemma nopaid: "snd (fst (TS_step_d s q)) = []" unfolding TS_step_d_def by simp

lemma staysuntouched:
assumes d[simp]: "distinct (fst S)"
and x: "x ∈ set (fst S)"
and y: "y ∈ set (fst S)"
shows "set qs ⊆ set (fst S) ⟹ x ∉ set qs ⟹ y ∉ set qs
⟹ x < y in fst (config' (rTS []) S qs) =  x < y in fst S"
proof(induct qs rule: rev_induct)
case (snoc q qs)
have "x < y in fst (config' (rTS []) S (qs @ [q])) =
x < y in fst (config' (rTS []) S qs)"
apply(simp add: config'_snoc Step_def split_def step_def rTS_def nopaid)
apply(rule xy_relativorder_mtf2)
using snoc by(simp_all add: x y )
also have "… = x < y in fst S"
apply(rule snoc)
using snoc by simp_all
finally show ?case .
qed simp

lemma staysuntouched':
assumes d[simp]: "distinct init"
and x: "x ∈ set init"
and y: "y ∈ set init"
and "set qs ⊆ set init"
and "x ∉ set qs" and "y ∉ set qs"
shows "x < y in fst (config (rTS []) init qs) =  x < y in init"
proof -
let ?S="(init, fst (rTS []) init)"
have "x < y in fst (config' (rTS []) ?S qs) =  x < y in fst ?S"
apply(rule staysuntouched)
using assms by(simp_all)
then show ?thesis by simp
qed

lemma projEmpty: "Lxy qs S = [] ⟹ x ∈ S ⟹ x ∉ set qs"
unfolding Lxy_def by (metis filter_empty_conv)

lemma Lxy_index_mono:
assumes "x∈S" "y∈S"
and "index xs x < index xs y"
and "index xs y < length xs"
and "x≠y"
shows "index (Lxy xs S) x < index (Lxy xs S) y"
proof -
from assms have ij: "index xs x < index xs y"
and xinxs: "index xs x < length xs"
and yinxs: "index xs y < length xs" by auto
then have inset: "x∈set xs" "y∈set xs" using index_less_size_conv by fast+
from xinxs obtain a as where dec1: "a @ [xs!index xs x] @ as = xs"
and a: "a = take (index xs x) xs" and "as = drop (Suc (index xs x)) xs"
and length_a: "length a = index xs x" and length_as: "length as = length xs - index xs x- 1"
using id_take_nth_drop by fastforce
have "index xs y≥length (a @ [xs!index xs x])" using length_a ij by auto
then have "((a @ [xs!index xs x]) @ as) ! index xs y = as ! (index xs y-length (a @ [xs ! index xs x]))" using nth_append[where xs="a @ [xs!index xs x]" and ys="as"]
by(simp)
then have xsj: "xs ! index xs y = as ! (index xs y-index xs x-1)" using dec1 length_a by auto
have las: "(index xs y-index xs x-1) < length as" using length_as yinxs ij by simp
obtain b c where dec2: "b @ [xs!index xs y] @ c = as"
and "b = take (index xs y-index xs x-1) as" "c=drop (Suc (index xs y-index xs x-1)) as"
and length_b: "length b = index xs y-index xs x-1" using id_take_nth_drop[OF las] xsj by force

have xs_dec: "a @ [xs!index xs x] @ b @ [xs!index xs y] @ c = xs" using dec1 dec2 by auto

then have "Lxy xs S = Lxy (a @ [xs!index xs x] @ b @ [xs!index xs y] @ c) S"
also have "… = Lxy a S @ Lxy [x] S @ Lxy b S @ Lxy [y] S @ Lxy c S"
by(simp add: Lxy_append Lxy_def assms inset)
finally have gr: "Lxy xs S = Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S"

have "y ∉ set (take (index xs x) xs)"
apply(rule index_take) using assms by simp
then have "y ∉  set (Lxy (take (index xs x) xs) S )"
apply(subst Lxy_set_filter) by blast
with a have ynot: "y ∉ set (Lxy a S)" by simp
have "index (Lxy xs S) y =
index (Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S) y"
also have "… ≥ length (Lxy a S) + 1"
using assms(5) ynot by(simp add: index_append)
finally have 1: "index (Lxy xs S) y ≥ length (Lxy a S) + 1" .

have "index (Lxy xs S) x = index (Lxy a S @ [x] @ Lxy b S @ [y] @ Lxy c S) x"
also have "… ≤  length (Lxy a S)"
apply(subst index_less_size_conv[symmetric]) by simp
finally have 2: "index (Lxy xs S) x ≤ length (Lxy a S)" .

from 1 2 show ?thesis by linarith
qed

lemma proj_Cons:
assumes filterd_cons: "Lxy qs S = a#as"
and a_filter: "a∈S"
obtains pre suf where "qs = pre @ [a] @ suf" and "⋀x. x ∈ S ⟹ x ∉ set pre"
and "Lxy suf S = as"
proof -
have "set (Lxy qs S) ⊆ set qs" using Lxy_set_filter by fast
with filterd_cons have a_inq: "a ∈ set qs" by simp
then have "index qs a < length qs" by(simp)
{ fix e
assume eS:"e∈S"
assume "e≠a"
have "index qs a ≤ index qs e"
proof (rule ccontr)
assume "¬ index qs a ≤ index qs e"
then have 1: "index qs e < index qs a" by simp
have 0: "index (Lxy qs S) a = 0" unfolding filterd_cons by simp
have 2: "index (Lxy qs S) e < index (Lxy qs S) a"
apply(rule Lxy_index_mono)
by(fact)+
from 0 2 show "False" by linarith
qed
} note atfront=this

let ?lastInd="index qs a"
have "qs = take ?lastInd qs @ qs!?lastInd # drop (Suc ?lastInd) qs"
apply(rule id_take_nth_drop)
using a_inq by simp
also have "… = take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs"
using a_inq by simp
finally have split: "qs = take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs" .

have nothingin: "⋀s. s∈S ⟹ s ∉ set (take ?lastInd qs)"
apply(rule index_take)
apply(case_tac "a=s")
apply(simp)
by (rule atfront) simp_all
then have "set (Lxy (take ?lastInd qs) S) = {}"
apply(subst Lxy_set_filter) by blast
then have emptyPre: "Lxy (take ?lastInd qs) S = []" by blast

have "a#as = Lxy qs S"
using filterd_cons by simp
also have "… = Lxy (take ?lastInd qs @ [a] @ drop (Suc ?lastInd) qs) S"
using split by simp
also have "… = Lxy (take ?lastInd qs) S @ (Lxy [a] S) @ Lxy (drop (Suc ?lastInd) qs) S"
also have "… = a#Lxy (drop (Suc ?lastInd) qs) S"
unfolding emptyPre by(simp add: Lxy_def a_filter)
finally have suf: "Lxy (drop (Suc ?lastInd) qs) S = as" by simp

from split nothingin suf show ?thesis ..
qed

lemma Lxy_rev: "rev (Lxy qs S) = Lxy (rev qs) S"
apply(induct qs)

lemma proj_Snoc:
assumes filterd_cons: "Lxy qs S = as@[a]"
and a_filter: "a∈S"
obtains pre suf where "qs = pre @ [a] @ suf" and "⋀x. x ∈ S ⟹ x ∉ set suf"
and "Lxy pre S = as"
proof -
have "Lxy (rev qs) S = rev (Lxy qs S)" by(simp add: Lxy_rev)
also have "… = a#(rev as)" unfolding filterd_cons by simp
finally have "Lxy (rev qs) S = a # (rev as)" .
with a_filter
obtain pre' suf' where 1: "rev qs = pre' @[a] @ suf'"
and 2: "⋀x. x ∈ S ⟹ x ∉ set pre'"
and 3: "Lxy suf' S = rev as"
using proj_Cons by metis
have "qs = rev (rev qs)" by simp
also have "… = rev suf' @ [a] @ rev pre'" using 1 by simp
finally have a1: "qs = rev suf' @ [a] @ rev pre'" .

have "Lxy (rev suf') S = rev (Lxy suf' S)" by(simp add: Lxy_rev)
also have "… = as" using 3 by simp
finally have a3: "Lxy (rev suf') S = as" .

have a2: "⋀x. x ∈ S ⟹ x ∉ set (rev pre')" using 2 by simp

from a1 a2 a3 show ?thesis ..
qed

lemma sndTSconfig': "snd (config' (rTS initH) (init,[]) qs) = rev qs @ []"
apply(induct qs rule: rev_induct)
by(simp add: split_def TS_step_d_def config'_snoc Step_def rTS_def)

lemma projxx:
fixes e a bs
assumes axy: "a∈{x,y}"
assumes ane: "a≠e"
assumes exy: "e∈{x,y}"
assumes bsaxy: "set (bs @ [a] @ f) ⊆ {x,y}"
assumes Lxyinitxy: "Lxy init {x, y} ∈ {[x,y],[y,x]}"
shows "a < e in fst (config⇩p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ f) @ [a]))"
proof -
have aexy: "{a,e}={x,y}" using exy axy ane by blast

let ?h="snd (Partial_Cost_Model.config' (λs. [], TS_step_d)
(Lxy init {x, y}, []) (bs @ a # f))"
have history: "?h = (rev f)@a#(rev bs)"
using sndTSdet[of "length (bs@a#f)" "bs@a#f", unfolded rTS_def] by(simp)

{ fix xs s
assume sinit: "s:{[a,e],[e,a]}"
assume "set xs ⊆ {a,e}"
then have "fst (config' (λs. [], TS_step_d) (s, []) xs) ∈ {[a,e], [e,a]}"
apply (induct xs rule: rev_induct)
using sinit apply(simp)
apply(subst config'_append2)
apply(simp only: Step_def config'.simps Let_def split_def fst_conv)
apply(rule stepxy) by simp_all
} note staysae=this

have opt: "fst (config' (λs. [], TS_step_d)
(Lxy init {x, y}, []) (bs @ [a] @ f)) ∈ {[a,e], [e,a]}"
apply(rule staysae)
using Lxyinitxy exy axy ane apply fast
unfolding aexy by(fact bsaxy)

have contr: " (∀x. 0 < (if e = x then 0 else index [a] x + 1)) = False"
proof (rule ccontr, goal_cases)
case 1
then have "⋀x. 0 < (if e = x then 0 else index [a] x + 1)" by simp
then have "0 < (if e = e then 0 else index [a] e + 1)" by blast
then have "0<0" by simp
then show "False" by auto
qed

show "a < e in fst (config⇩p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ f) @ [a]))"
apply(subst config_append)
apply(subst TS_step_d_def)
apply(simp only: history)
apply(auto simp: step_def)
apply (metis One_nat_def add_is_1 count_list.simps(1) le_Suc_eq)
qed

lemma oneposs:
assumes "set xs = {x,y}"
assumes "x≠y"
assumes "distinct xs"
assumes True: "x<y in xs"
shows "xs = [x,y]"
proof -
from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
from True have "index xs x < index xs y" "index xs y < length xs" unfolding before_in_def using assms
by simp_all
then have f: "index xs x = 0 ∧ index xs y = 1" using len2 by linarith
have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
apply(rule id_take_nth_drop) using len2 by simp
also have "… = take 1 xs @ [xs!1]" using len2 by simp
also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
apply(rule id_take_nth_drop) using len2 by simp
also have "… = [xs!0]" by(simp)
finally have "xs = [xs!0, xs!1]" by simp
also have "… = [xs!(index xs x), xs!index xs y]" using f by simp
also have "… = [x,y]" using assms by(simp)
finally show "xs = [x,y]" .
qed

lemma twoposs:
assumes "set xs = {x,y}"
assumes "x≠y"
assumes "distinct xs"
shows "xs ∈ {[x,y], [y,x]}"
proof (cases "x<y in xs")
case True
from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
from True have "index xs x < index xs y" "index xs y < length xs" unfolding before_in_def using assms
by simp_all
then have f: "index xs x = 0 ∧ index xs y = 1" using len2 by linarith
have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
apply(rule id_take_nth_drop) using len2 by simp
also have "… = take 1 xs @ [xs!1]" using len2 by simp
also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
apply(rule id_take_nth_drop) using len2 by simp
also have "… = [xs!0]" by(simp)
finally have "xs = [xs!0, xs!1]" by simp
also have "… = [xs!(index xs x), xs!index xs y]" using f by simp
also have "… = [x,y]" using assms by(simp)
finally have "xs = [x,y]" .
then show ?thesis by simp
next
case False
from assms have len2: "length xs = 2" using distinct_card[OF assms(3)] by fastforce
from False have "y<x in xs" using not_before_in assms(1,2) by fastforce
then have "index xs y < index xs x" "index xs x < length xs" unfolding before_in_def using assms
by simp_all
then have f: "index xs y = 0 ∧ index xs x = 1" using len2 by linarith
have "xs = take 1 xs @ xs!1 # drop (Suc 1) xs"
apply(rule id_take_nth_drop) using len2 by simp
also have "… = take 1 xs @ [xs!1]" using len2 by simp
also have "take 1 xs = take 0 (take 1 xs) @ (take 1 xs)!0 # drop (Suc 0) (take 1 xs)"
apply(rule id_take_nth_drop) using len2 by simp
also have "… = [xs!0]" by(simp)
finally have "xs = [xs!0, xs!1]" by simp
also have "… = [xs!(index xs y), xs!index xs x]" using f by simp
also have "… = [y,x]" using assms by(simp)
finally have "xs = [y,x]" .
then show ?thesis by simp
qed

lemma TS_pairwise': assumes "qs ∈ {xs. set xs ⊆ set init}"
"(x, y) ∈ {(x, y). x ∈ set init ∧ y ∈ set init ∧ x ≠ y}"
"x ≠ y" "distinct init"
shows "Pbefore_in x y (embed (rTS [])) qs init =
Pbefore_in x y (embed (rTS [])) (Lxy qs {x, y}) (Lxy init {x, y})"
proof -
from assms have xyininit: "{x, y} ⊆ set init"
and qsininit: "set qs ⊆ set init" by auto
note dinit=assms(4)
from assms have xny: "x≠y" by simp
have Lxyinitxy: "Lxy init {x, y} ∈ {[x, y], [y, x]}"
apply(rule twoposs)
apply(subst Lxy_set_filter) using xyininit apply fast
using xny Lxy_distinct[OF dinit] by simp_all

have lq_s: "set (Lxy qs {x, y}) ⊆ {x,y}" by (simp add: Lxy_set_filter)

(* projected history *)
let ?pH = "snd (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
have "?pH =snd (TSdet (Lxy init {x, y}) [] (Lxy qs {x, y}) (length (Lxy qs {x, y})))"
by(simp)
also have "… = rev (take (length (Lxy qs {x, y})) (Lxy qs {x, y})) @ []"
apply(rule sndTSdet) by simp
finally have pH: "?pH = rev (Lxy qs {x, y})" by simp

let ?pQs = "(Lxy qs {x, y})"

have A: " x < y in fst (config⇩p (rTS []) init qs)
=   x < y in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
proof(cases "?pQs" rule: rev_cases)
case Nil
then have xqs: "x ∉ set qs" and yqs: "y ∉ set qs" by(simp_all add: projEmpty)
have " x < y in fst (config⇩p (rTS []) init qs)
=  x < y in init" apply(rule staysuntouched') using assms xqs yqs by(simp_all)
also have "… = x < y in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
unfolding Nil apply(simp) apply(rule Lxy_mono) using xyininit dinit by(simp_all)
finally show ?thesis .
next
case (snoc as a)
then have "a∈set (Lxy qs {x, y})" by (simp)
then have axy: "a∈{x,y}" by(simp add: Lxy_set_filter)
with xyininit have ainit: "a∈set init" by auto
note a=snoc
from a axy obtain pre suf  where qs: "qs = pre @ [a] @ suf"
and nosuf: "⋀e. e ∈ {x,y} ⟹ e ∉ set suf"
and pre: "Lxy pre {x,y} = as"
using proj_Snoc by metis
show ?thesis
proof (cases "as" rule: rev_cases)
case Nil
from pre Nil have xqs: "x ∉ set pre" and yqs: "y ∉ set pre" by(simp_all add: projEmpty)
from xqs yqs axy have "a ∉ set pre" by blast
then have noocc: "index (rev pre) a = length (rev pre)" by simp
have " x < y in fst (config⇩p (rTS []) init qs)
=  x < y in fst (config⇩p (rTS []) init ((pre @ [a]) @ suf))" by(simp add: qs)
also have "… = x < y in fst (config⇩p (rTS []) init (pre @ [a]))"
apply(subst config_append)
apply(rule staysuntouched) using assms xqs yqs qs nosuf by(simp_all)
also have "… = x < y in fst (config⇩p (rTS []) init pre)"
apply(subst config_append)
apply(simp only: TS_step_d_def)
apply(simp only: sndTSconfig'[unfolded rTS_def])
also have "… = x < y in init"
apply(rule staysuntouched') using assms xqs yqs qs by(simp_all)
also have "… = x < y in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
unfolding a Nil apply(simp add: Step_def split_def rTS_def TS_step_d_def step_def)
apply(rule Lxy_mono) using xyininit dinit by(simp_all)
finally show ?thesis .
next
case (snoc bs b)
note b=this
with a have "b∈set (Lxy qs {x, y})" by (simp)
then have bxy: "b∈{x,y}" by(simp add: Lxy_set_filter)
with xyininit have binit: "b∈set init" by auto
from b pre have "Lxy pre {x,y} = bs @ [b]" by simp
with bxy obtain pre2 suf2  where bs: "pre = pre2 @ [b] @ suf2"
and nosuf2: "⋀e. e ∈ {x,y} ⟹ e ∉ set suf2"
and pre2: "Lxy pre2 {x,y} = bs"
using proj_Snoc by metis

from bs qs have qs2: "qs = pre2 @ [b] @ suf2 @ [a] @ suf" by simp

show ?thesis
proof (cases "a=b")
case True
note ab=this

let ?qs ="(pre2 @ [a] @ suf2 @ [a]) @ suf"
{
fix e
assume ane: "a≠e"
assume exy: "e∈{x,y}"
have "a < e in fst (config⇩p (rTS []) init qs)
= a < e in fst (config⇩p (rTS []) init ?qs)" using True qs2 by(simp)
also have "… = a < e in fst  (config⇩p (rTS []) init (pre2 @ [a] @ suf2 @ [a]))"
apply(subst config_append)
apply(rule staysuntouched) using assms qs nosuf apply(simp_all)
using  exy xyininit apply fast
using nosuf axy apply(simp)
using nosuf exy by simp
also have "…"
apply(simp)
apply(rule twotox[unfolded s_TS_def, simplified])
using nosuf2 exy apply(simp)
using assms  apply(simp_all)
using axy xyininit  apply fast
using exy xyininit  apply fast
using nosuf2 axy apply(simp)
using ane by simp
finally have "a < e in fst (config⇩p (rTS []) init qs)" by simp
} note full=this

have "set (bs @ [a]) ⊆ set (Lxy qs {x, y})" using a b  by auto
also have "… = {x,y} ∩ set qs" by (rule Lxy_set_filter)
also have "… ⊆ {x,y}" by simp
finally have bsaxy: "set (bs @ [a]) ⊆ {x,y}" .

with xny show ?thesis
proof(cases "x=a")
case True
have 1: "a < y in fst (config⇩p (rTS []) init qs)"
apply(rule full)
using True xny apply blast
by simp

have "a < y in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
= a < y in fst (config⇩p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ []) @ [a]))"
using a b ab by simp
also have "…"
apply(rule projxx[where bs=bs and f="[]"])
using True apply blast
using a b True ab xny Lxyinitxy bsaxy by(simp_all)
finally show ?thesis using True 1 by simp
next
case False
with axy have ay: "a=y" by blast
have 1: "a < x in fst (config⇩p (rTS []) init qs)"
apply(rule full)
using False xny apply blast
by simp
have "a < x in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
= a < x in fst (config⇩p (rTS []) (Lxy init {x, y}) ((bs @ [a] @ []) @ [a]))"
using a b ab by simp
also have "…"
apply(rule projxx[where bs=bs and f="[]"])
using True axy apply blast
using a b True ab xny Lxyinitxy ay bsaxy by(simp_all)
finally have 2: "a < x in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .

have "x < y in fst (config⇩p (rTS []) init qs) =
(¬ y < x in fst (config⇩p (rTS []) init qs))"
apply(subst not_before_in)
using assms by(simp_all)
also have "… = False" using  1 ay by simp
also have "… = (¬ y < x in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
using 2 ay by simp
also have "… = x < y in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
apply(subst not_before_in)
finally show ?thesis .
qed
next
case False
note ab=this

show ?thesis
proof (cases "bs" rule: rev_cases)
case Nil
with a b have "Lxy qs {x, y} = [b,a]" by simp
from pre2 Nil have xqs: "x ∉ set pre2" and yqs: "y ∉ set pre2" by(simp_all add: projEmpty)
from xqs yqs bxy have "b ∉ set pre2" by blast
then have noocc2: "index (rev pre2) b = length (rev pre2)" by simp
from axy nosuf2 have "a ∉ set suf2" by blast
with xqs yqs axy False have "a ∉ set ((pre2 @ b # suf2))" by(auto)
then have noocc: "index (rev (pre2 @ b # suf2) @ []) a = length (rev (pre2 @ b # suf2))" by simp
have " x < y in fst (config⇩p (rTS []) init qs)
=  x < y in fst (config⇩p (rTS []) init ((((pre2 @ [b]) @ suf2) @ [a]) @ suf))" by(simp add: qs2)
also have "… = x < y in fst (config⇩p (rTS []) init (((pre2 @ [b]) @ suf2) @ [a]))"
apply(subst config_append)
apply(rule staysuntouched) using assms xqs yqs qs nosuf by(simp_all)
also have "… = x < y in fst (config⇩p (rTS []) init ((pre2 @ [b]) @ suf2))"
apply(subst config_append)
apply(simp only: TS_step_d_def)
apply(simp only: sndTSconfig'[unfolded rTS_def])
apply(simp only: noocc) by (simp add: step_def)
also have "… = x < y in fst (config⇩p (rTS []) init (pre2 @ [b]))"
apply(subst config_append)
apply(rule staysuntouched) using assms xqs yqs qs2 nosuf2 by(simp_all)
also have "… = x < y in fst (config⇩p (rTS []) init (pre2))"
apply(subst config_append)
apply(simp only: TS_step_d_def)
apply(simp only: sndTSconfig'[unfolded rTS_def])
also have "… = x < y in init"
apply(rule staysuntouched') using assms xqs yqs qs2 by(simp_all)
also have "… = x < y in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
unfolding a b Nil
using False
apply(simp add: Step_def split_def rTS_def TS_step_d_def step_def)
apply(rule Lxy_mono) using xyininit dinit by(simp_all)
finally show ?thesis .
next
case (snoc cs c)
note c=this
with a b have "c∈set (Lxy qs {x, y})" by (simp)
then have cxy: "c∈{x,y}" by(simp add: Lxy_set_filter)
from c pre2 have "Lxy pre2 {x,y} = cs @ [c]" by simp
with cxy obtain pre3 suf3  where cs: "pre2 = pre3 @ [c] @ suf3"
and nosuf3: "⋀e. e ∈ {x,y} ⟹ e ∉ set suf3"
and pre3: "Lxy pre3 {x,y} = cs"
using proj_Snoc by metis

let ?qs=" pre3 @ [c] @ suf3 @ [b] @ suf2 @ [a] @ suf"
from bs cs qs have qs2: "qs = ?qs" by simp

show ?thesis
proof(cases "c=a")
case True (* aba *)
note ca=this

have "a < b in fst (config⇩p (rTS []) init qs)
= a < b in fst (config⇩p (rTS []) init ((pre3 @ a # (suf3 @ [b] @ suf2) @ [a]) @ suf))"
using qs2 True by simp
also have "… = a < b in fst (config⇩p (rTS []) init (pre3 @ a # (suf3 @ [b] @ suf2) @ [a]))"
apply(subst config_append)
apply(rule staysuntouched) using assms qs nosuf apply(simp_all)
using bxy xyininit apply(fast)
using nosuf axy bxy by(simp_all)
also have "..."
apply(rule twotox[unfolded s_TS_def, simplified])
using nosuf2 nosuf3 bxy apply(simp add: count_append)
using assms apply(simp_all)
using axy xyininit apply(fast)
using bxy xyininit apply(fast)
using ab nosuf2 nosuf3 axy apply(simp)
using ab by simp
finally have full: "a < b in fst (config⇩p (rTS []) init qs)" by simp

have "set (cs @ [a] @ [b]) ⊆ set (Lxy qs {x, y})" using a b c  by auto
also have "… = {x,y} ∩ set qs" by (rule Lxy_set_filter)
also have "… ⊆ {x,y}" by simp
finally have csabxy: "set (cs @ [a] @ [b]) ⊆ {x,y}" .

with xny show ?thesis
proof(cases "x=a")
case True
with xny ab bxy have bisy: "b=y" by blast
have 1: "x < y in fst (config⇩p (rTS []) init qs)"
using full True bisy by simp

have "a < y in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
= a < y in fst (config⇩p (rTS []) (Lxy init {x, y}) ((cs @ [a] @ [b]) @ [a]))"
using a b c ca ab by simp
also have "…"
apply(rule projxx)
using True apply blast
using a b True ab xny Lxyinitxy csabxy by(simp_all)
finally show ?thesis using 1 True by simp
next
case False
with axy have ay: "a=y" by blast
with xny ab bxy have bisx: "b=x" by blast
have 1: "y < x in fst (config⇩p (rTS []) init qs)"
using full ay bisx by simp

have "a < x in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
= a < x in fst (config⇩p (rTS []) (Lxy init {x, y}) ((cs @ [a] @ [b]) @ [a]))"
using a b c ca ab by simp
also have "…"
apply(rule projxx)
using a b True ab xny Lxyinitxy csabxy False by(simp_all)
finally have 2: "a < x in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .

have "x < y in fst (config⇩p (rTS []) init qs) =
(¬ y < x in fst (config⇩p (rTS []) init qs))"
apply(subst not_before_in)
using assms by(simp_all)
also have "… = False" using  1 ay by simp
also have "… = (¬ y < x in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
using 2 ay by simp
also have "… = x < y in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
apply(subst not_before_in)
finally show ?thesis .
qed
next
case False  (* bba *)
then have cb: "c=b" using bxy cxy axy ab by blast

let ?cs = "suf2 @ [a] @ suf"
let ?i = "index ?cs a"

have aed: "(∀j<index (suf2 @ a # suf) a. (suf2 @ a # suf) ! j ≠ a)"
by (metis add.right_neutral axy index_Cons index_append nosuf2 nth_append nth_mem)

have "?i < length ?cs
⟶ (∀j<?i. ?cs ! j ≠ ?cs ! ?i) ⟶ ?cs ! ?i ≠ b
⟶ ?cs ! ?i ∉ set suf3
⟶ b < ?cs ! ?i in s_TS init [] qs (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
apply(rule casexxy)
using cb qs2 apply(simp)
using bxy ab nosuf2 nosuf apply(simp)
using bs qs qsininit apply(simp)
using bxy xyininit apply(blast)
apply(fact)
using nosuf3 bxy apply(simp)
using cs bs qs qsininit by(simp_all)

then have inner: "b < a in s_TS init [] qs (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
using ab nosuf3 axy bxy aed
by(simp)
let ?n = "(length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1)"
let ?inner="(config⇩p (rTS []) init (take (length (pre3 @ [b] @ suf3 @ [b]) + ?i + 1) ?qs))"

have "b < a in fst (config⇩p (rTS []) init qs)
= b < a in fst (config⇩p (rTS []) init (take ?n ?qs @ drop ?n ?qs))" using qs2 by simp
also have "… = b < a in fst (config' (rTS []) ?inner suf)" apply(simp only: config_append drop_append)
using nosuf2 axy by(simp add: index_append config_append)
also have "… = b < a in fst ?inner"
apply(rule staysuntouched) using assms bxy xyininit  qs nosuf apply(simp_all)
using bxy xyininit apply(blast)
using axy xyininit by (blast)
also have "… = True" using inner by(simp add: s_TS_def qs2)
finally have full: "b < a in fst (config⇩p (rTS []) init qs)" by simp

have "set (cs @ [b] @ []) ⊆ set (Lxy qs {x, y})" using a b c  by auto
also have "… = {x,y} ∩ set qs" by (rule Lxy_set_filter)
also have "… ⊆ {x,y}" by simp
finally have csbxy: "set (cs @ [b] @ []) ⊆ {x,y}" .

have "set (Lxy init {x, y}) = {x,y} ∩ set init"
by(rule Lxy_set_filter)
also have "… = {x,y}" using xyininit by fast
also have "… = {b,a}" using axy bxy ab by fast
finally have r: "set (Lxy init {x, y}) = {b, a}" .

let ?confbef="(config⇩p (rTS []) (Lxy init {x, y}) ((cs @ [b] @ []) @ [b]))"
have f1: "b < a in fst ?confbef"
apply(rule projxx)
using bxy ab axy a b c csbxy Lxyinitxy by(simp_all)
have 1: "fst ?confbef = [b,a]"
apply(rule oneposs)
using ab axy bxy xyininit Lxy_distinct[OF dinit] f1 r by(simp_all)
have 2: "snd (Partial_Cost_Model.config'
(λs. [], TS_step_d)
(Lxy init {x, y}, [])
(cs @ [b, b])) = [b,b]@(rev cs)"
using sndTSdet[of "length (cs @ [b, b])" "(cs @ [b, b])", unfolded rTS_def] by(simp)
have "b < a in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))
= b < a in fst (config⇩p (rTS []) (Lxy init {x, y}) (((cs @ [b] @ []) @ [b])@[a]))"
using a b c cb by(simp)
also have "…"
apply(subst config_append)
using 1 2 ab apply(simp add: step_def Step_def split_def rTS_def TS_step_d_def)
finally have projected: "b < a in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))" .

have 1: "{x,y} = {a,b}" using ab axy bxy by fast
with xny show ?thesis
proof(cases "x=a")
case True
with 1 xny have y: "y=b" by fast
have "a < b in fst (config⇩p (rTS []) init qs) =
(¬ b < a in fst (config⇩p (rTS []) init qs))"
apply(subst not_before_in)
using binit ainit ab by(simp_all)
also have "… = False" using  full by simp
also have "… = (¬ b < a in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y})))"
using projected by simp
also have "… = a < b in fst (config⇩p (rTS []) (Lxy init {x, y}) (Lxy qs {x, y}))"
apply(subst not_before_in)
using binit ainit ab axy bxy  by(simp_all add: Lxy_set_filter)
finally show ?thesis using True y by simp
next
case False
with 1 xny have y: "y=a" "x=b" by fast+
with full projected show ?thesis by fast
qed
qed (* end of (c=a) *)
qed (* end of snoc cs c *)
qed (* end of (a=b) *)
qed (* end snoc bs b *)
qed (* end snoc as a *)

show ?thesis unfolding Pbefore_in_def
apply(subst config_embed)
apply(subst config_embed)
apply(simp) by (rule A)
qed

theorem TS_pairwise: "pairwise (embed (rTS []))"
apply(rule pairwise_property_lemma)
apply(rule TS_pairwise') by (simp_all add: rTS_def TS_step_d_def)

subsection "TS is 2-compet"

lemma TS_compet':   "pairwise (embed (rTS [])) ⟹
∀s0∈{init::(nat list). distinct init ∧ init≠[]}. ∃b≥0. ∀qs∈{x. set x ⊆ set s0}. T⇩p_on_rand (embed (rTS [])) s0 qs ≤ (2::real) *  T⇩p_opt s0 qs + b"
unfolding rTS_def
proof (rule factoringlemma_withconstant, goal_cases)
case 5
show ?case
proof (safe, goal_cases)
case (1 init)
note out=this
show ?case
apply(rule exI[where x=2])
apply(simp)
proof (safe, goal_cases)
case (1 qs a b)
then have a: "a≠b" by simp
have twist: "{a,b}={b, a}" by auto
have b1: "set (Lxy qs {a, b}) ⊆ {a, b}" unfolding Lxy_def by auto
with this[unfolded twist] have b2: "set (Lxy qs {b, a}) ⊆ {b, a}" by(auto)

have "set (Lxy init {a, b}) = {a,b} ∩ (set init)" apply(induct init)
unfolding Lxy_def by(auto)
with 1 have A: "set (Lxy init {a, b}) = {a,b}" by auto
have "finite {a,b}" by auto
from out have B: "distinct (Lxy init {a, b})" unfolding Lxy_def by auto
have C: "length (Lxy init {a, b}) = 2"
using distinct_card[OF B, unfolded A] using a by auto

have "{xs. set xs = {a,b} ∧ distinct xs ∧ length xs =(2::nat)}
= { [a,b], [b,a] }"
apply(auto simp: a a[symmetric])
proof (goal_cases)
case (1 xs)
from 1(4) obtain x xs' where r:"xs=x#xs'" by (metis Suc_length_conv add_2_eq_Suc' append_Nil length_append)
with 1(4) have "length xs' = 1" by auto
then obtain y where s: "[y] = xs'" by (metis One_nat_def length_0_conv length_Suc_conv)
from r s have t: "[x,y] = xs" by auto
moreover from t 1(1) have "x=b" using doubleton_eq_iff 1(2) by fastforce
moreover from t 1(1) have "y=a" using doubleton_eq_iff 1(2) by fastforce
ultimately show ?case by auto
qed

with A B C have pos: "(Lxy init {a, b}) = [a,b]
∨ (Lxy init {a, b}) = [b,a]" by auto

{ fix a::nat
fix b::nat
fix qs
assume as: "a ≠ b" "set qs ⊆ {a, b}"
have "T_on_rand' (embed (rTS [])) (fst (embed (rTS [])) [a,b] ⤜ (λis. return_pmf ([a,b], is))) qs
= T⇩p_on (rTS []) [a, b] qs" by (rule  T_on_embed[symmetric])
also from as have "… ≤ 2 * T⇩p_opt [a, b] qs + 2" using TS_OPT2' by fastforce
finally have "T_on_rand' (embed (rTS [])) (fst (embed (rTS [])) [a,b] ⤜ (λis. return_pmf ([a,b], is))) qs
≤ 2 * T⇩p_opt [a, b] qs + 2"  .
} note ye=this

show ?case
apply(cases "(Lxy init {a, b}) = [a,b]")
using ye[OF a b1, unfolded rTS_def] apply(simp)
using pos ye[OF a[symmetric] b2, unfolded rTS_def] by(simp add: twist)
qed
qed
next
case 6
show ?case unfolding TS_step_d_def by (simp add: split_def TS_step_d_def)
next
case (7 init qs x)
then show ?case
apply(induct x)
by (simp_all add: rTS_def split_def take_Suc_conv_app_nth config'_rand_snoc )
next
case 4 then show ?case by simp
qed (simp_all)

lemma TS_compet: "compet_rand (embed (rTS [])) 2 {init. distinct init ∧ init ≠ []}"
unfolding compet_rand_def static_def
using TS_compet'[OF TS_pairwise] by simp

end
```