(*  Title:       Analysis of OPT2
    Author:      Max Haslbeck
*)

section "OPT2"

theory OPT2
imports
Partial_Cost_Model
RExp_Var
begin

lemma "(N::nat set) \<noteq> {} \<Longrightarrow> Inf N : N"
unfolding Inf_nat_def using LeastI[of "%x. x : N"] by force

lemma nn_contains_Inf:
  fixes S :: "nat set"
  assumes nn: "S \<noteq> {}"
  shows "Inf S \<in> S"
using assms Inf_nat_def LeastI by force

subsection "Definition"

fun OPT2 :: "'a list \<Rightarrow> 'a list \<Rightarrow> (nat * nat list) list" where
  "OPT2 [] [x,y] = []"
| "OPT2 [a] [x,y] = [(0,[])]"
| "OPT2 (a#b#\<sigma>') [x,y] =  (if a=x then (0,[]) # (OPT2 (b#\<sigma>') [x,y])
                                  else (if b=x then (0,[])# (OPT2 (b#\<sigma>') [x,y])
                                               else (1,[])# (OPT2 (b#\<sigma>') [y,x])))"

lemma OPT2_length: "length (OPT2 \<sigma> [x, y]) = length \<sigma>"
apply(induct \<sigma> arbitrary: x y)
  apply(simp)
  apply(case_tac \<sigma>) by(auto)

lemma OPT2x: "OPT2 (x#\<sigma>') [x,y] = (0,[])#(OPT2 \<sigma>' [x,y])"
apply(cases \<sigma>') by (simp_all)

lemma swapOpt: "T\<^sub>p_opt [x,y] \<sigma> \<le> 1 + T\<^sub>p_opt [y,x] \<sigma>"
proof -
  show ?thesis
  proof (cases "length \<sigma> > 0")
    case True

    have "T\<^sub>p_opt [y,x] \<sigma> \<in> {T\<^sub>p [y, x] \<sigma> as |as. length as = length \<sigma>}"
    unfolding T_opt_def
      apply(rule nn_contains_Inf)
      apply(auto) by (rule Ex_list_of_length)

    then obtain asyx where costyx: "T\<^sub>p [y,x] \<sigma> asyx = T\<^sub>p_opt [y,x] \<sigma>"
                       and lenyx: "length asyx = length \<sigma>"
              unfolding T_opt_def by auto

    from True lenyx have "length asyx > 0" by auto
    then obtain A asyx' where aa: "asyx = A # asyx'" using list.exhaust by blast
    then obtain m1 a1 where AA: "A = (m1,a1)" by fastforce

    let ?asxy = "(m1,a1@[0]) # asyx'"

    from True obtain q \<sigma>' where qq: "\<sigma> = q # \<sigma>'" using list.exhaust by blast

    have t: "t\<^sub>p [x, y] q (m1, a1@[0]) = Suc (t\<^sub>p [y, x] q (m1, a1))"
    unfolding t\<^sub>p_def
    apply(simp) unfolding swap_def by (simp)

    have s: "step [x, y] q (m1, a1 @ [0]) = step [y, x] q (m1, a1)"
    unfolding step_def mtf2_def by(simp add: swap_def)

    have T: "T\<^sub>p [x,y] \<sigma> ?asxy = 1 + T\<^sub>p [y,x] \<sigma> asyx" unfolding qq aa AA by(auto simp add: s t)

    have l: "1 + T\<^sub>p_opt [y,x] \<sigma> = T\<^sub>p [x, y] \<sigma> ?asxy" using T costyx by simp
    have "length ?asxy = length \<sigma>" using lenyx aa by auto
    then have inside: "?asxy \<in> {as. size as = size \<sigma>}" by force
    then have b: "T\<^sub>p [x, y] \<sigma> ?asxy \<in> {T\<^sub>p [x, y] \<sigma> as | as. size as = size \<sigma>}" by auto

    then show ?thesis unfolding l unfolding T_opt_def
      apply(rule cInf_lower) by simp
  qed (simp add: T_opt_def)
qed

lemma tt: "a \<in> {x,y} \<Longrightarrow> OPT2 (rest1) (step [x,y] a (hd (OPT2 (a # rest1) [x, y])))
       = tl (OPT2 (a # rest1) [x, y])"
apply(cases rest1) by(auto simp add: step_def mtf2_def swap_def)

lemma splitqsallg: "Strat \<noteq> [] \<Longrightarrow> a \<in> {x,y} \<Longrightarrow>
         t\<^sub>p [x, y] a (hd (Strat)) +
          (let L=step [x,y] a (hd (Strat))
              in T\<^sub>p L (rest1) (tl Strat)) =  T\<^sub>p [x, y] (a # rest1) Strat"
proof -
  assume ne: "Strat \<noteq> []"
  assume axy: "a \<in> {x,y}" (* not needed *)
  have "T\<^sub>p [x, y] (a # rest1) (Strat)
        = T\<^sub>p [x, y] (a # rest1) ((hd (Strat)) # (tl (Strat)))"
        by(simp only: List.list.collapse[OF ne])
  then show ?thesis by auto
qed

lemma splitqs: "a \<in> {x,y} \<Longrightarrow> T\<^sub>p [x, y] (a # rest1) (OPT2 (a # rest1) [x, y])
        =  t\<^sub>p [x, y] a (hd (OPT2 (a # rest1) [x, y])) +
          (let L=step [x,y] a (hd (OPT2 (a # rest1) [x, y]))
              in T\<^sub>p L (rest1) (OPT2 (rest1) L))"
proof -
  assume axy: "a \<in> {x,y}"
  have ne: "OPT2 (a # rest1) [x, y] \<noteq> []" apply(cases rest1) by(simp_all)
  have "T\<^sub>p [x, y] (a # rest1) (OPT2 (a # rest1) [x, y])
        = T\<^sub>p [x, y] (a # rest1) ((hd (OPT2 (a # rest1) [x, y])) # (tl (OPT2 (a # rest1) [x, y])))"
        by(simp only: List.list.collapse[OF ne])
  also have "\<dots> = T\<^sub>p [x, y] (a # rest1) ((hd (OPT2 (a # rest1) [x, y])) # (OPT2 (rest1) (step [x,y] a (hd (OPT2 (a # rest1) [x, y])))))"
      by(simp only: tt[OF axy])
  also have "\<dots> =   t\<^sub>p [x, y] a (hd (OPT2 (a # rest1) [x, y])) +
          (let L=step [x,y] a (hd (OPT2 (a # rest1) [x, y]))
              in T\<^sub>p L (rest1) (OPT2 (rest1) L))" by(simp)
  finally show ?thesis .
qed

lemma tpx: "t\<^sub>p [x, y] x (hd (OPT2 (x # rest1) [x, y])) = 0"
by (simp add: OPT2x t\<^sub>p_def)

lemma yup: "T\<^sub>p [x, y] (x # rest1) (OPT2 (x # rest1) [x, y])
        = (let L=step [x,y] x (hd (OPT2 (x # rest1) [x, y]))
              in T\<^sub>p L (rest1) (OPT2 (rest1) L))"
by (simp add: splitqs tpx)

lemma swapsxy: "A \<in> { [x,y], [y,x]} \<Longrightarrow> swaps sws A \<in> { [x,y], [y,x]}"
apply(induct sws)
  apply(simp)
  apply(simp) unfolding swap_def by auto

lemma mtf2xy: "A \<in> { [x,y], [y,x]} \<Longrightarrow> r\<in>{x,y} \<Longrightarrow> mtf2 a r A \<in> { [x,y], [y,x]}"
by (metis mtf2_def swapsxy)

lemma stepxy: assumes "q \<in> {x,y}" "A \<in> { [x,y], [y,x]}"
    shows "step A q a \<in> { [x,y], [y,x]}"
unfolding step_def apply(simp only: split_def Let_def)
apply(rule mtf2xy)
  apply(rule swapsxy) by fact+

subsection "Proof of Optimality"

lemma OPT2_is_lb: "set \<sigma> \<subseteq> {x,y} \<Longrightarrow> x\<noteq>y \<Longrightarrow> T\<^sub>p [x,y] \<sigma> (OPT2 \<sigma> [x,y]) \<le> T\<^sub>p_opt [x,y] \<sigma>"
proof (induct "length \<sigma>" arbitrary: x y \<sigma> rule: less_induct)
  case (less)
  show ?case
  proof (cases \<sigma>)
    case (Cons a \<sigma>')
    note Cons1=Cons
    show ?thesis unfolding Cons
      proof(cases "a=x") (* case that the element in front is requested *)
        case True
        from True Cons have qsform: "\<sigma> = x#\<sigma>'" by auto
        have up: "T\<^sub>p [x, y] (x # \<sigma>') (OPT2 (x # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (x # \<sigma>')"
          unfolding True
          unfolding T_opt_def apply(rule cInf_greatest)
            apply(simp add: Ex_list_of_length)
            proof -
              fix el
              assume "el \<in> {T\<^sub>p [x, y] (x # \<sigma>') as |as. length as = length (x # \<sigma>')}"
              then obtain Strat where lStrat: "length Strat = length (x # \<sigma>')"
                        and el: "T\<^sub>p [x, y] (x # \<sigma>') Strat = el" by auto
              then have ne: "Strat \<noteq> []" by auto
              let ?LA="step [x,y] x (hd (OPT2 (x # \<sigma>') [x, y]))"

              have  E0:  "T\<^sub>p [x, y] (x # \<sigma>') (OPT2 (x # \<sigma>') [x, y])
                            =T\<^sub>p ?LA (\<sigma>') (OPT2 (\<sigma>') ?LA)" using yup by auto
              also have E1: "\<dots> = T\<^sub>p [x,y] (\<sigma>') (OPT2 (\<sigma>') [x,y])" by (simp add: OPT2x step_def)
              also have E2: "\<dots> \<le>  T\<^sub>p_opt [x,y] \<sigma>'" apply(rule less(1)) using Cons less(2,3) by auto
              also have "\<dots> \<le> T\<^sub>p [x, y] (x # \<sigma>') Strat"
                   proof (cases "(step [x, y] x (hd Strat)) = [x,y]")
                      case True
                      have aha: "T\<^sub>p_opt [x, y] \<sigma>' \<le> T\<^sub>p [x, y] \<sigma>' (tl Strat)"
                        unfolding T_opt_def apply(rule cInf_lower)
                          apply(auto) apply(rule exI[where x="tl Strat"]) using lStrat by auto

                      also have E4: "\<dots> \<le> t\<^sub>p [x, y] x (hd Strat) + T\<^sub>p (step [x, y] x (hd Strat)) \<sigma>' (tl Strat)"
                        unfolding True by(simp)
                      also have E5: "\<dots> = T\<^sub>p [x, y] (x # \<sigma>') Strat" using splitqsallg[of Strat x x y \<sigma>', OF ne, simplified]
                        by (auto)
                      finally show ?thesis by auto
                   next
                      case False
                      have tp1: "t\<^sub>p [x, y] x (hd Strat) \<ge> 1"
                      proof (rule ccontr)
                        let ?a = "hd Strat"
                        assume "\<not> 1 \<le> t\<^sub>p [x, y] x ?a"
                        then have tp0: "t\<^sub>p [x, y] x ?a = 0" by auto
                        then have "size (snd ?a) = 0" unfolding t\<^sub>p_def by(simp add: split_def)
                        then have nopaid: "(snd ?a) = []" by auto
                        have "step [x, y] x ?a = [x, y]"
                          unfolding step_def apply(simp add: split_def nopaid)
                          unfolding mtf2_def by(simp)
                        then show "False" using False by auto
                      qed

                      from False have yx: "step [x, y] x (hd Strat) = [y, x]"
                        using stepxy[where x=x and y=y and a="hd Strat"] by auto

                      have E3: "T\<^sub>p_opt [x, y] \<sigma>' \<le> 1 + T\<^sub>p_opt [y, x] \<sigma>'" using swapOpt by auto
                      also have E4: "\<dots> \<le> 1 + T\<^sub>p [y, x] \<sigma>' (tl Strat)"
                        apply(simp) unfolding T_opt_def apply(rule cInf_lower)
                          apply(auto) apply(rule exI[where x="tl Strat"]) using lStrat by auto
                      also have E5: "\<dots> = 1 + T\<^sub>p (step [x, y] x (hd Strat)) \<sigma>' (tl Strat)" using yx by auto
                      also have E6: "\<dots> \<le> t\<^sub>p [x, y] x (hd Strat) + T\<^sub>p (step [x, y] x (hd Strat)) \<sigma>' (tl Strat)" using tp1 by auto

                      also have E7: "\<dots> = T\<^sub>p [x, y] (x # \<sigma>') Strat" using splitqsallg[of Strat x x y \<sigma>', OF ne, simplified]
                         by (auto)
                      finally show ?thesis by auto
                   qed
              also have "\<dots> = el" using True el by simp
              finally show "T\<^sub>p [x, y] (x # \<sigma>') (OPT2 (x # \<sigma>') [x, y]) \<le> el" by auto
            qed
         then show "T\<^sub>p [x, y] (a # \<sigma>') (OPT2 (a # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (a # \<sigma>')"
         using True by simp
      next

        case False (* case 2: element at back is requested first *)
        with less Cons have ay: "a=y" by auto
        show "T\<^sub>p [x, y] (a # \<sigma>') (OPT2 (a # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (a # \<sigma>')" unfolding ay
        proof(cases \<sigma>')
          case Nil
          have up: "T\<^sub>p_opt [x, y] [y] \<ge> 1"
            unfolding T_opt_def apply(rule cInf_greatest)
            apply(simp add: Ex_list_of_length)
            proof -
              fix el
              assume "el \<in> {T\<^sub>p [x, y] [y] as |as. length as = length [y]}"
              then obtain Strat where Strat: "length Strat = length [y]" and
                            el: "el = T\<^sub>p [x, y] [y] Strat " by auto
              from Strat obtain a where a: "Strat = [a]" by (metis Suc_length_conv length_0_conv)
              show "1 \<le> el" unfolding el a apply(simp) unfolding t\<^sub>p_def apply(simp add: split_def)
                apply(cases "snd a")
                  apply(simp add: less(3))
                  by(simp)
            qed

          show "T\<^sub>p [x, y] (y # \<sigma>') (OPT2 (y # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (y # \<sigma>')" unfolding Nil
            apply(simp add: t\<^sub>p_def) using less(3) apply(simp)
            using up by(simp)
        next
          case (Cons b rest2)

          show up: "T\<^sub>p [x, y] (y # \<sigma>') (OPT2 (y # \<sigma>') [x, y]) \<le> T\<^sub>p_opt [x, y] (y # \<sigma>')"
            unfolding Cons
          proof (cases "b=x")
            case True

            show "T\<^sub>p [x, y] (y # b # rest2) (OPT2 (y # b # rest2) [x, y]) \<le> T\<^sub>p_opt [x, y] (y # b # rest2)"
              unfolding True
              unfolding T_opt_def apply(rule cInf_greatest)
                apply(simp add: Ex_list_of_length)
                proof -
                  fix el
                  assume "el \<in> {T\<^sub>p [x, y] (y # x # rest2) as |as. length as = length (y # x # rest2)}"
                  then obtain Strat where lenStrat: "length Strat = length (y # x # rest2)" and
                               Strat: "el = T\<^sub>p [x, y] (y # x # rest2) Strat" by auto
                  have v: " set rest2 \<subseteq> {x, y}" using less(2)[unfolded Cons1 Cons] by auto

                  let ?L1 = "(step [x, y] y (hd Strat))"
                  let ?L2 = "(step ?L1 x (hd (tl Strat)))"

                  (* lets work on how Strat can look like: *)
                  let ?a1 = "hd Strat"
                  let ?a2 = "hd (tl Strat)"
                  let ?r = "tl (tl Strat)"

                  have "Strat = ?a1 # ?a2 # ?r" by (metis Nitpick.size_list_simp(2) Suc_length_conv lenStrat list.collapse list.discI list.inject)

                  have 1: "T\<^sub>p [x, y] (y # x # rest2) Strat
                        = t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
                            + T\<^sub>p ?L2 rest2 (tl (tl Strat))"
                    proof -
                      have a: "Strat \<noteq> []" using lenStrat by auto
                      have b: "(tl Strat) \<noteq> []" using lenStrat by (metis Nitpick.size_list_simp(2) Suc_length_conv list.discI list.inject)

                      have 1: "T\<^sub>p [x, y] (y # x # rest2) Strat
                                = t\<^sub>p [x, y] y (hd Strat) + T\<^sub>p ?L1 (x # rest2) (tl Strat)"
                                  using splitqsallg[OF a, where a=y and x=x and y=y, simplified] by (simp)
                      have tt: "step [x, y] y (hd Strat) \<noteq> [x, y] \<Longrightarrow> step [x, y] y (hd Strat) = [y,x]"
                        using stepxy[where A="[x,y]"] by blast

                      have 2: "T\<^sub>p ?L1 (x # rest2) (tl Strat) = t\<^sub>p ?L1 x (hd (tl Strat)) +  T\<^sub>p ?L2 (rest2) (tl (tl Strat))"
                                  apply(cases "?L1=[x,y]")
                                    using splitqsallg[OF b, where a=x and x=x and y=y, simplified] apply(auto)
                                    using tt splitqsallg[OF b, where a=x and x=y and y=x, simplified] by auto
                      from 1 2 show ?thesis by auto
                    qed

                  have " T\<^sub>p [x, y] (y # x # rest2) (OPT2 (y # x # rest2) [x, y])
                    =  1 +  T\<^sub>p [x, y] (rest2) (OPT2 (rest2) [x, y])"
                    unfolding True
                    using less(3) by(simp add: t\<^sub>p_def step_def OPT2x)
                  also have "\<dots> \<le> 1 +  T\<^sub>p_opt [x, y] (rest2)" apply(simp)
                    apply(rule less(1))
                      apply(simp add: less(2) Cons1 Cons)
                      apply(fact) by fact
                  also

                  have "\<dots> \<le> T\<^sub>p [x, y] (y # x # rest2) Strat"
                  proof (cases "?L2 = [x,y]")
                    case True
                    have 2: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
                            + T\<^sub>p [x,y] rest2 (tl (tl Strat)) \<ge> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
                            + T\<^sub>p_opt [x,y] rest2" apply(simp)
                            unfolding T_opt_def apply(rule cInf_lower)
                            apply(simp) apply(rule exI[where x="tl (tl Strat)"]) by (auto simp: lenStrat)
                    have 3: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))
                            + T\<^sub>p_opt [x,y] rest2 \<ge> 1 + T\<^sub>p_opt [x,y] rest2" apply(simp)
                            proof -
                              have "t\<^sub>p [x, y] y (hd Strat) \<ge> 1"
                              unfolding t\<^sub>p_def apply(simp add: split_def)
                              apply(cases "snd (hd Strat)") by (simp_all add: less(3))
                              then show "Suc 0 \<le> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat))" by auto
                            qed
                    from 1 2 3 True show ?thesis by auto
                  next
                    case False
                    note L2F=this
                    have L1: "?L1 \<in> {[x, y], [y, x]}" apply(rule stepxy) by simp_all
                    have "?L2 \<in> {[x, y], [y, x]}" apply(rule stepxy) using L1 by simp_all
                    with False have 2: "?L2 = [y,x]" by auto

                    have k: "T\<^sub>p [x, y] (y # x # rest2) Strat
                        =   t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat)) +
                            T\<^sub>p [y,x] rest2 (tl (tl Strat))" using 1 2 by auto

                    have l: "t\<^sub>p [x, y] y (hd Strat) > 0"
                        using less(3) unfolding t\<^sub>p_def apply(cases "snd (hd Strat) = []")
                          by (simp_all add: split_def)

                    have r: "T\<^sub>p [x, y] (y # x # rest2) Strat \<ge> 2 + T\<^sub>p [y,x] rest2 (tl (tl Strat))"
                    proof (cases "?L1 = [x,y]")
                      case True
                      note T=this
                      then have "t\<^sub>p ?L1 x (hd (tl Strat)) > 0" unfolding True
                        proof(cases "snd (hd (tl Strat)) = []")
                          case True
                          have "?L2 = [x,y]" unfolding T  apply(simp add: split_def step_def)
                          unfolding True mtf2_def by(simp)
                          with L2F have "False" by auto
                          then show "0 < t\<^sub>p [x, y] x (hd (tl Strat))" ..
                        next
                          case False
                          then show "0 < t\<^sub>p [x, y] x (hd (tl Strat))"
                            unfolding t\<^sub>p_def by(simp add: split_def)
                        qed
                      with l have " t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 x (hd (tl Strat)) \<ge> 2" by auto
                      with k show ?thesis by auto
                    next
                      case False
                      from L1 False have 2: "?L1 = [y,x]" by auto
                      { fix k sws T
                        have "T\<in>{[x,y],[y,x]} \<Longrightarrow> mtf2 k x T = [y,x] \<Longrightarrow> T = [y,x]"
                          apply(rule ccontr) by (simp add: less(3) mtf2_def)
                      }
                      have t1: "t\<^sub>p [x, y] y (hd Strat) \<ge> 1" unfolding t\<^sub>p_def apply(simp add: split_def)
                        apply(cases "(snd (hd Strat))") using \<open>x \<noteq> y\<close> by auto
                      have t2: "t\<^sub>p [y,x] x (hd (tl Strat)) \<ge> 1" unfolding t\<^sub>p_def apply(simp add: split_def)
                        apply(cases "(snd (hd (tl Strat)))") using \<open>x \<noteq> y\<close> by auto
                      have "T\<^sub>p [x, y] (y # x # rest2) Strat
                          = t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p (step [x, y] y (hd Strat)) x (hd (tl Strat)) + T\<^sub>p [y, x] rest2 (tl (tl Strat))"
                            by(rule k)
                      with t1 t2 2 show ?thesis by auto
                    qed
                    have t: "T\<^sub>p [y, x] rest2 (tl (tl Strat)) \<ge> T\<^sub>p_opt [y, x] rest2"
                      unfolding T_opt_def apply(rule cInf_lower)
                      apply(auto) apply(rule exI[where x="(tl (tl Strat))"]) by(simp add: lenStrat)
                    show ?thesis
                    proof -
                      have "1 + T\<^sub>p_opt [x, y] rest2 \<le> 2 + T\<^sub>p_opt [y, x] rest2"
                      using  swapOpt by auto
                      also have "\<dots> \<le> 2 + T\<^sub>p [y, x] rest2 (tl (tl Strat))" using t by auto
                      also have "\<dots> \<le> T\<^sub>p [x, y] (y # x # rest2) Strat" using r by auto
                      finally show ?thesis .
                    qed

                  qed
                  also have "\<dots> = el" using Strat by auto
                  finally show "T\<^sub>p [x, y] (y # x # rest2) (OPT2 (y # x # rest2) [x, y]) \<le> el" .
                qed

          next
            case False
            with Cons1 Cons less(2) have bisy: "b=y" by auto
            with less(3) have "OPT2 (y # b # rest2) [x, y] = (1,[])# (OPT2 (b#rest2) [y,x])" by simp
            show "T\<^sub>p [x, y] (y # b # rest2) (OPT2 (y # b # rest2) [x, y]) \<le> T\<^sub>p_opt [x, y] (y # b # rest2)"
              unfolding bisy
              unfolding T_opt_def apply(rule cInf_greatest)
                apply(simp add: Ex_list_of_length)
                proof -
                  fix el
                  assume "el \<in> {T\<^sub>p [x, y] (y # y # rest2) as |as. length as = length (y # y # rest2)}"
                  then obtain Strat where lenStrat: "length Strat = length (y # y # rest2)" and
                               Strat: "el = T\<^sub>p [x, y] (y # y # rest2) Strat" by auto
                  have v: " set rest2 \<subseteq> {x, y}" using less(2)[unfolded Cons1 Cons] by auto

                  let ?L1 = "(step [x, y] y (hd Strat))"
                  let ?L2 = "(step ?L1 y (hd (tl Strat)))"

                  (* lets work on how Strat can look like: *)
                  let ?a1 = "hd Strat"
                  let ?a2 = "hd (tl Strat)"
                  let ?r = "tl (tl Strat)"

                  have "Strat = ?a1 # ?a2 # ?r" by (metis Nitpick.size_list_simp(2) Suc_length_conv lenStrat list.collapse list.discI list.inject)

                  have 1: "T\<^sub>p [x, y] (y # y # rest2) Strat
                        = t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
                            + T\<^sub>p ?L2 rest2 (tl (tl Strat))"
                    proof -
                      have a: "Strat \<noteq> []" using lenStrat by auto
                      have b: "(tl Strat) \<noteq> []" using lenStrat by (metis Nitpick.size_list_simp(2) Suc_length_conv list.discI list.inject)

                      have 1: "T\<^sub>p [x, y] (y # y # rest2) Strat
                                = t\<^sub>p [x, y] y (hd Strat) + T\<^sub>p ?L1 (y # rest2) (tl Strat)"
                                  using splitqsallg[OF a, where a=y and x=x and y=y, simplified] by (simp)
                      have tt: "step [x, y] y (hd Strat) \<noteq> [x, y] \<Longrightarrow> step [x, y] y (hd Strat) = [y,x]"
                        using stepxy[where A="[x,y]"] by blast

                      have 2: "T\<^sub>p ?L1 (y # rest2) (tl Strat) = t\<^sub>p ?L1 y (hd (tl Strat)) +  T\<^sub>p ?L2 (rest2) (tl (tl Strat))"
                                  apply(cases "?L1=[x,y]")
                                    using splitqsallg[OF b, where a=y and x=x and y=y, simplified] apply(auto)
                                    using tt splitqsallg[OF b, where a=y and x=y and y=x, simplified] by auto
                      from 1 2 show ?thesis by auto
                    qed

                  have " T\<^sub>p [x, y] (y # y # rest2) (OPT2 (y # y # rest2) [x, y])
                    =  1 +  T\<^sub>p [y, x] (rest2) (OPT2 (rest2) [y, x])"
                    using less(3) by(simp add: t\<^sub>p_def step_def mtf2_def swap_def OPT2x)
                  also have "\<dots> \<le> 1 +  T\<^sub>p_opt [y, x] (rest2)" apply(simp)
                    apply(rule less(1))
                      apply(simp add: less(2) Cons1 Cons)
                      using v less(3) by(auto)
                  also

                  have "\<dots> \<le> T\<^sub>p [x, y] (y # y # rest2) Strat"
                  proof (cases "?L2 = [y,x]")
                    case True
                    have 2: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
                            + T\<^sub>p [y,x] rest2 (tl (tl Strat)) \<ge> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
                            + T\<^sub>p_opt [y,x] rest2" apply(simp)
                            unfolding T_opt_def apply(rule cInf_lower)
                            apply(simp) apply(rule exI[where x="tl (tl Strat)"]) by (auto simp: lenStrat)
                    have 3: "t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))
                            + T\<^sub>p_opt [y,x] rest2 \<ge> 1 + T\<^sub>p_opt [y,x] rest2" apply(simp)
                            proof -
                              have "t\<^sub>p [x, y] y (hd Strat) \<ge> 1"
                              unfolding t\<^sub>p_def apply(simp add: split_def)
                              apply(cases "snd (hd Strat)") by (simp_all add: less(3))
                              then show "Suc 0 \<le> t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat))" by auto
                            qed
                    from 1 2 3 True show ?thesis by auto
                  next
                    case False
                    note L2F=this
                    have L1: "?L1 \<in> {[x, y], [y, x]}" apply(rule stepxy) by simp_all
                    have "?L2 \<in> {[x, y], [y, x]}" apply(rule stepxy) using L1 by simp_all
                    with False have 2: "?L2 = [x,y]" by auto

                    have k: "T\<^sub>p [x, y] (y # y # rest2) Strat
                        =   t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat)) +
                            T\<^sub>p [x,y] rest2 (tl (tl Strat))" using 1 2 by auto

                    have l: "t\<^sub>p [x, y] y (hd Strat) > 0"
                        using less(3) unfolding t\<^sub>p_def apply(cases "snd (hd Strat) = []")
                          by (simp_all add: split_def)

                    have r: "T\<^sub>p [x, y] (y # y # rest2) Strat \<ge> 2 + T\<^sub>p [x,y] rest2 (tl (tl Strat))"
                    proof (cases "?L1 = [y,x]")
                      case False
                      from L1 False have "?L1 = [x,y]" by auto
                      note T=this
                      then have "t\<^sub>p ?L1 y (hd (tl Strat)) > 0" unfolding T
                      unfolding t\<^sub>p_def apply(simp add: split_def)
                        apply(cases "snd (hd (tl Strat)) = []")
                          using \<open>x \<noteq> y\<close> by auto
                      with l k show ?thesis by auto
                    next

                      case True
                      note T=this

                        have "t\<^sub>p ?L1 y (hd (tl Strat)) > 0" unfolding T
                        proof(cases "snd (hd (tl Strat)) = []")
                          case True
                          have "?L2 = [y,x]" unfolding T  apply(simp add: split_def step_def)
                          unfolding True mtf2_def by(simp)
                          with L2F have "False" by auto
                          then show "0 < t\<^sub>p [y, x] y (hd (tl Strat))" ..
                        next
                          case False
                          then show "0 < t\<^sub>p [y, x] y (hd (tl Strat))"
                            unfolding t\<^sub>p_def by(simp add: split_def)
                        qed
                      with l have " t\<^sub>p [x, y] y (hd Strat) + t\<^sub>p ?L1 y (hd (tl Strat)) \<ge> 2" by auto
                      with k show ?thesis by auto

                    qed
                    have t: "T\<^sub>p [x, y] rest2 (tl (tl Strat)) \<ge> T\<^sub>p_opt [x, y] rest2"
                      unfolding T_opt_def apply(rule cInf_lower)
                      apply(auto) apply(rule exI[where x="(tl (tl Strat))"]) by(simp add: lenStrat)
                    show ?thesis
                    proof -
                      have "1 + T\<^sub>p_opt [y, x] rest2 \<le> 2 + T\<^sub>p_opt [x, y] rest2"
                      using  swapOpt by auto
                      also have "\<dots> \<le> 2 + T\<^sub>p [x, y] rest2 (tl (tl Strat))" using t by auto
                      also have "\<dots> \<le> T\<^sub>p [x, y] (y # y # rest2) Strat" using r by auto
                      finally show ?thesis .
                    qed

                  qed
                  also have "\<dots> = el" using Strat by auto
                  finally show "T\<^sub>p [x, y] (y # y # rest2) (OPT2 (y # y # rest2) [x, y]) \<le> el" .
                qed
          qed
        qed
     qed
  qed (simp add: T_opt_def)
qed

lemma OPT2_is_ub: "set qs \<subseteq> {x,y} \<Longrightarrow> x\<noteq>y \<Longrightarrow> T\<^sub>p [x,y] qs (OPT2 qs [x,y]) \<ge> T\<^sub>p_opt [x,y] qs"
  unfolding T_opt_def apply(rule cInf_lower)
            apply(simp) apply(rule exI[where x="(OPT2 qs [x, y])"])
            by (auto simp add: OPT2_length)

lemma OPT2_is_opt: "set qs \<subseteq> {x,y} \<Longrightarrow> x\<noteq>y \<Longrightarrow> T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = T\<^sub>p_opt [x,y] qs"
by (simp add: OPT2_is_lb OPT2_is_ub antisym)

subsection "Performance on the four phase forms"

lemma OPT2_A: assumes "x \<noteq> y" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
  shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = 1"
proof -
  from assms(2) obtain u v where qs: "qs=u@v" and u: "u=[x] \<or> u=[]" and v: "v = [y,y]" by (auto simp: conc_def)
  from u have pref1: "T\<^sub>p [x,y] (u@v) (OPT2 (u@v) [x,y]) = T\<^sub>p [x,y] v (OPT2 v [x,y])"
    apply(cases "u=[]")
      apply(simp)
      by(simp add: OPT2x t\<^sub>p_def step_def)

  have ende: "T\<^sub>p [x,y] v (OPT2 v [x,y]) = 1" unfolding v using assms(1) by(simp add: mtf2_def swap_def t\<^sub>p_def step_def)

  from pref1 ende qs show ?thesis by auto
qed

lemma OPT2_A': assumes "x \<noteq> y" "qs \<in> lang (seq [Plus (Atom x) One, Atom y, Atom y])"
  shows "real (T\<^sub>p [x,y] qs (OPT2 qs [x,y])) = 1"
using OPT2_A[OF assms] by simp

lemma OPT2_B: assumes "x \<noteq> y" "qs=u@v" "u=[] \<or> u=[x]" "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
  shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v div 2)"
proof -
  from assms(3) have pref1: "T\<^sub>p [x,y] (u@v) (OPT2 (u@v) [x,y]) = T\<^sub>p [x,y] v (OPT2 v [x,y])"
    apply(cases "u=[]")
      apply(simp)
      by(simp add: OPT2x t\<^sub>p_def step_def)

  from assms(4) obtain a w where v: "v=a@w" and "a\<in>lang (Times (Atom y) (Atom x))" and w: "w\<in>lang (seq[Star(Times (Atom y) (Atom x)), Atom y, Atom y])" by(auto)
  from this(2) have aa: "a=[y,x]" by(simp add: conc_def)

  from assms(1) this v have pref2: "T\<^sub>p [x,y] v (OPT2 v [x,y]) = 1 + T\<^sub>p [x,y] w (OPT2 w [x,y])"
   by(simp add: t\<^sub>p_def step_def OPT2x)

  from w obtain c d where w2: "w=c@d" and c: "c \<in> lang (Star (Times (Atom y) (Atom x)))" and d: "d \<in> lang (Times (Atom y) (Atom y))" by auto
  then have dd: "d=[y,y]" by auto

  from c[simplified] have star: "T\<^sub>p [x,y] (c@d) (OPT2 (c@d) [x,y]) = (length c div 2) +  T\<^sub>p [x,y] d (OPT2 d [x,y])"
    proof(induct c rule: star_induct)
      case (append r s)
      then have r: "r=[y,x]" by auto
      then have "T\<^sub>p [x, y] ((r @ s) @ d) (OPT2 ((r @ s) @ d) [x, y]) = T\<^sub>p [x, y] ([y,x] @ (s @ d)) (OPT2 ([y,x] @ (s @ d)) [x, y])" by simp
      also have "\<dots> = 1 + T\<^sub>p [x, y] (s @ d) (OPT2 (s @ d) [x, y])"
        using assms(1) by(simp add: t\<^sub>p_def step_def OPT2x)
      also have "\<dots> =  1 + length s div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using append by simp
      also have "\<dots> =  length (r @ s) div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using r by auto
      finally show ?case .
    qed simp

  have ende: "T\<^sub>p [x,y] d (OPT2 d [x,y]) = 1" unfolding dd using assms(1) by(simp add: mtf2_def swap_def t\<^sub>p_def step_def)

  have vv: "v = [y,x]@c@[y,y]" using w2 dd v aa by auto

  from pref1 pref2 star w2 ende have
    "T\<^sub>p [x, y] qs (OPT2 qs [x, y]) = 1 + length c div 2 + 1" unfolding assms(2) by auto
  also have "\<dots> = (length v div 2)" using vv by auto
  finally show ?thesis .
qed

lemma OPT2_B1: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
  shows "real (T\<^sub>p [x,y] qs (OPT2 qs [x,y])) = length qs / 2"
proof -
  from assms(2) have qs: "qs \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
    by(simp add: conc_assoc)
  have "(length qs) mod 2 = 0"
  proof -
    from assms(2) have "qs \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "qs=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[y]} @@ {[y]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[y,y]" by auto
    with pqr have a: "length qs = 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 OPT2_B[where u="[]", OF assms(1) _ _ qs] show ?thesis by auto
qed

lemma OPT2_B2: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom y, Atom y])"
  shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = ((length qs - 1) / 2)"
proof -
  from assms(2) obtain v where
      qsv: "qs = [x]@v" and vv: "v \<in> lang (seq[Times (Atom y) (Atom x), Star(Times (Atom y) (Atom x)), Atom y, Atom y])" by (auto simp add: conc_def)
  have "(length v) mod 2 = 0"
  proof -
    from vv have "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[y]} @@ {[y]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[y]} @@ {[y]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[y,y]" by(auto simp add: conc_def)
    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 OPT2_B[where u="[x]", OF assms(1) qsv _ vv] qsv show ?thesis by(auto)
qed

lemma OPT2_C: assumes "x \<noteq> y" "qs=u@v" "u=[] \<or> u=[x]"
  and "v \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
  shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = (length v div 2)"
proof -
  from assms(3) have pref1: "T\<^sub>p [x,y] (u@v) (OPT2 (u@v) [x,y]) = T\<^sub>p [x,y] v (OPT2 v [x,y])"
    apply(cases "u=[]")
      apply(simp)
      by(simp add: OPT2x t\<^sub>p_def step_def)

  from assms(4) obtain a w where v: "v=a@w" and aa: "a=[y,x]" and w: "w\<in>lang (seq[Star(Times (Atom y) (Atom x)), Atom x])" by(auto simp: conc_def)

  from assms(1) this v have pref2: "T\<^sub>p [x,y] v (OPT2 v [x,y]) = 1 + T\<^sub>p [x,y] w (OPT2 w [x,y])"
   by(simp add: t\<^sub>p_def step_def OPT2x)

  from w obtain c d where w2: "w=c@d" and c: "c \<in> lang (Star (Times (Atom y) (Atom x)))" and d: "d \<in> lang (Atom x)" by auto
  then have dd: "d=[x]" by auto

  from c[simplified] have star: "T\<^sub>p [x,y] (c@d) (OPT2 (c@d) [x,y]) = (length c div 2) +  T\<^sub>p [x,y] d (OPT2 d [x,y]) \<and> (length c) mod 2 = 0"
    proof(induct c rule: star_induct)
      case (append r s)
      from append have mod: "length s mod 2 = 0" by simp
      from append have r: "r=[y,x]" by auto
      then have "T\<^sub>p [x, y] ((r @ s) @ d) (OPT2 ((r @ s) @ d) [x, y]) = T\<^sub>p [x, y] ([y,x] @ (s @ d)) (OPT2 ([y,x] @ (s @ d)) [x, y])" by simp
      also have "\<dots> = 1 + T\<^sub>p [x, y] (s @ d) (OPT2 (s @ d) [x, y])"
        using assms(1) by(simp add: t\<^sub>p_def step_def OPT2x)
      also have "\<dots> =  1 + length s div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using append by simp
      also have "\<dots> =  length (r @ s) div 2 + T\<^sub>p [x, y] d (OPT2 d [x, y])" using r by auto
      finally show ?case by(simp add: mod r)
    qed simp

  have ende: "T\<^sub>p [x,y] d (OPT2 d [x,y]) = 0" unfolding dd using assms(1) by(simp add: mtf2_def swap_def t\<^sub>p_def step_def)

  have vv: "v = [y,x]@c@[x]" using w2 dd v aa by auto

  from pref1 pref2 star w2 ende have
    "T\<^sub>p [x, y] qs (OPT2 qs [x, y]) = 1 + length c div 2" unfolding assms(2) by auto
  also have "\<dots> = (length v div 2)" using vv star by auto
  finally show ?thesis .
qed

lemma OPT2_C1: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
  shows "real (T\<^sub>p [x,y] qs (OPT2 qs [x,y])) = (length qs - 1) / 2"
proof -
  from assms(2) have qs: "qs \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
    by(simp add: conc_assoc)
  have "(length qs) mod 2 = 1"
  proof -
    from assms(2) have "qs \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "qs=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[x]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[x]" by auto
    with pqr have a: "length qs = 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 ?thesis by auto
  qed
  with OPT2_C[where u="[]", OF assms(1) _ _ qs] show ?thesis apply auto
      by (metis minus_mod_eq_div_mult [symmetric] of_nat_mult of_nat_numeral)
qed

lemma OPT2_C2: assumes "x \<noteq> y" "qs \<in> lang (seq[Atom x, Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])"
  shows "T\<^sub>p [x,y] qs (OPT2 qs [x,y]) = ((length qs - 2) / 2)"
proof -
  from assms(2) obtain v where
      qsv: "qs = [x]@v" and vv: "v \<in> lang (seq[Atom y, Atom x, Star(Times (Atom y) (Atom x)), Atom x])" by (auto simp add: conc_def)
  have "(length v) mod 2 = 1"
  proof -
    from vv have "v \<in> ({[y]} @@ {[x]}) @@ star({[y]} @@ {[x]}) @@ {[x]}" by (simp add: conc_assoc)
    then obtain p q r where pqr: "v=p@q@r" and "p\<in>({[y]} @@ {[x]})"
              and q: "q \<in> star ({[y]} @@ {[x]})" and "r \<in>{[x]}" by (metis concE)
    then have rr: "p = [y,x]" "r=[x]" by(auto simp add: conc_def)
    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 ?thesis by auto
  qed
  with OPT2_C[where u="[x]", OF assms(1) qsv _ vv] qsv show ?thesis apply(auto)
      by (metis minus_mod_eq_div_mult [symmetric] of_nat_mult of_nat_numeral)
qed

lemma OPT2_ub: "set qs \<subseteq> {x,y} \<Longrightarrow> T\<^sub>p [x,y] qs (OPT2 qs [x,y]) \<le> length qs"
proof(induct qs arbitrary: x y)
  case (Cons q qs)
  then have "set qs \<subseteq> {x,y}" "q\<in>{x,y}" by auto
  note Cons1=Cons this
  show ?case
  proof (cases qs)
    case Nil
    with Cons1 show "T\<^sub>p [x,y] (q # qs) (OPT2 (q # qs) [x,y]) \<le> length (q # qs)"
        apply(simp add: t\<^sub>p_def) by blast
  next
    case (Cons q' qs')
    with Cons1 have "q'\<in>{x,y}" by auto
    note Cons=Cons this

    from Cons1 Cons have T: "T\<^sub>p [x, y] qs (OPT2 qs [x, y]) \<le> length qs"
                            "T\<^sub>p [y, x] qs (OPT2 qs [y, x]) \<le> length qs" by auto
    show "T\<^sub>p [x,y] (q # qs) (OPT2 (q # qs) [x,y]) \<le> length (q # qs)"
          unfolding Cons apply(simp only: OPT2.simps)
          apply(split if_splits(1))
            apply(safe)
            proof (goal_cases)
              case 1
              have "T\<^sub>p [x, y] (x # q' # qs') ((0, []) # OPT2 (q' # qs') [x, y])
                      = t\<^sub>p [x, y] x (0,[]) + T\<^sub>p [x, y] qs (OPT2 qs [x, y])"
                        by(simp add: step_def Cons)
              also have "\<dots> \<le> t\<^sub>p [x, y] x (0,[]) + length qs" using T by auto
              also have "\<dots> \<le> length (x # q' # qs')" using Cons by(simp add: t\<^sub>p_def)
              finally show ?case .
            next
              case 2
              with Cons1 Cons show ?case
                apply(split if_splits(1))
                apply(safe)
                proof (goal_cases)
                  case 1
                  then have "T\<^sub>p [x, y] (y # x # qs') ((0, []) # OPT2 (x # qs') [x, y])
                          = t\<^sub>p [x, y] y (0,[]) + T\<^sub>p [x, y] qs (OPT2 qs [x, y])"
                            by(simp add: step_def)
                  also have "\<dots> \<le> t\<^sub>p [x, y] y (0,[]) + length qs" using T by auto
                  also have "\<dots> \<le> length (y # x # qs')" using Cons by(simp add: t\<^sub>p_def)
                  finally show ?case .
                next
                  case 2
                  then have "T\<^sub>p [x, y] (y # y # qs') ((1, []) # OPT2 (y # qs') [y, x])
                          = t\<^sub>p [x, y] y (1,[]) + T\<^sub>p [y, x] qs (OPT2 qs [y, x])"
                            by(simp add: step_def mtf2_def swap_def)
                  also have "\<dots> \<le> t\<^sub>p [x, y] y (1,[]) + length qs" using T by auto
                  also have "\<dots> \<le> length (y # y # qs')" using Cons by(simp add: t\<^sub>p_def)
                  finally show ?case .
                qed
           qed
  qed
qed simp

lemma OPT2_padded: "R\<in>{[x,y],[y,x]} \<Longrightarrow> set qs \<subseteq> {x,y}
      \<Longrightarrow>  T\<^sub>p R (qs@[x,x]) (OPT2 (qs@[x,x]) R)
              \<le> T\<^sub>p R (qs@[x]) (OPT2 (qs@[x]) R) + 1"
apply(induct qs arbitrary: R)
  apply(simp)
    apply(case_tac "R=[x,y]")
      apply(simp add: step_def t\<^sub>p_def )
      apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
  proof (goal_cases)
    case (1 a qs R)
    then have a: "a \<in> {x,y}" by auto
    with 1 show ?case
      apply(cases qs)
        apply(cases "a=x")
          apply(cases "R=[x,y]")
            apply(simp add: step_def t\<^sub>p_def)
            apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
          apply(cases "R=[x,y]")
            apply(simp add: step_def t\<^sub>p_def)
            apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
      proof (goal_cases)
        case (1 p ps)
        show ?case
          apply(cases "a=x")
            apply(cases "R=[x,y]")
              apply(simp add: OPT2x step_def) using 1 apply(simp)
              using 1(2) apply(simp)
                apply(cases qs)
                  apply(simp add: step_def mtf2_def swap_def t\<^sub>p_def)
                  using 1 by(auto simp add: swap_def mtf2_def step_def)
       qed
qed

lemma  OPT2_split11:
  assumes xy: "x\<noteq>y"
  shows "R\<in>{[x,y],[y,x]} \<Longrightarrow> set xs \<subseteq> {x,y} \<Longrightarrow> set ys \<subseteq> {x,y} \<Longrightarrow> OPT2 (xs@[x,x]@ys) R = OPT2 (xs@[x,x]) R @ OPT2 ys [x,y]"
proof (induct xs arbitrary: R)
  case Nil
  then show ?case
  apply(simp)
  apply(cases ys)
    apply(simp)
    apply(cases "R=[x,y]")
      apply(simp)
      by(simp)
next
  case (Cons a as)
  note iH=this
  then have AS: "set as \<subseteq> {x,y}" and A: "a \<in> {x,y}" by auto
  note iH=Cons(1)[where R="[y,x]", simplified, OF AS Cons(4)]
  note iH'=Cons(1)[where R="[x,y]", simplified, OF AS Cons(4)]
  show ?case
  proof (cases "R=[x,y]")
    case True
    note R=this
    from iH iH' show ?thesis
    apply(cases "a=x")
      apply(simp add: R OPT2x)
      using A apply(simp)
      apply(cases as)
        apply(simp add: R)
        using AS apply(simp)
        apply(case_tac "aa=x")
          by(simp_all add: R)
  next
    case False
    with Cons(2) have R: "R=[y,x]" by auto
    from iH iH' show ?thesis
    apply(cases "a=y")
      apply(simp add: R OPT2x)
      using A apply(simp)
      apply(cases as)
        apply(simp add: R)
        apply(case_tac "aa=y")
          by (simp_all add: R)
   qed
qed

subsection "The function steps"

lemma steps_append: "length qs = length as \<Longrightarrow> steps s (qs@[q]) (as@[a]) = step (steps s qs as) q a"
apply(induct qs as arbitrary: s rule: list_induct2) by simp_all

end


theory Mikes_attempt
imports Main HOL.List
begin

datatype PCW =
  A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8
| OK "nat\<times>nat"  | idleW | OOM | FinishedW

datatype PCR =
  R1 "nat\<times>nat"
  | idleR

datatype Thread = W | R
datatype Pointer = Head | Tail
datatype F0 = Arr\<^sub>W | Arr\<^sub>R | W | R | Q
datatype F1 = B | W | Q | R
datatype F2 = W | Q | R
consts n :: nat   (*size of buffer, input*)
consts N :: nat   (*number of Arr\<^sub>W entries*)

definition "con_assms \<equiv>   0 < N \<and> 0<n"

(*Recorded variables*)
record rb_state =
  H :: nat
  T :: nat
  hW ::  nat               (*local copy of W*)
  tW ::  nat               (*local copy of W*)
  count :: nat
  temp :: nat         (*local copy of word by W*)
  pcW :: PCW           (*records program counter of W*)
  pcR :: PCR           (*records program counter of W*)
  own0 :: "nat \<Rightarrow> F0"
  own1 :: "nat \<Rightarrow> F1"
  own2 :: "Pointer \<Rightarrow> F2"
  RFlag :: "nat \<Rightarrow> bool"
  WFlag :: "nat \<Rightarrow> bool"
  arrayW:: "nat  \<Rightarrow> nat"     (*returns a word arrayW_i*)
  arrayR:: "nat  \<Rightarrow> nat"     (*returns a word arrayR_i*)

definition push_H :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`H := _" [200])
  where
  "push_H v \<equiv> \<lambda>s. s \<lparr>H := v\<rparr>"

definition push_T :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`T := _" [200])
  where
  "push_T v \<equiv> \<lambda>s. s \<lparr>T := v\<rparr>"

definition set_WFlag :: "nat \<Rightarrow> bool \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`WFlag _ := _" [200])  where
  "set_WFlag ord v  \<equiv> \<lambda>s. s \<lparr> WFlag  := ((WFlag s) (ord := v))\<rparr>"

definition set_RFlag :: "nat \<Rightarrow> bool \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`RFlag _ := _" [200])  where
  "set_RFlag ord v  \<equiv> \<lambda>s. s \<lparr> RFlag  := ((RFlag s) (ord := v))\<rparr>"

definition set_own0 :: "nat \<Rightarrow> F0 \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`own0 _ := _" [200])  where
  "set_own0 ord v  \<equiv> \<lambda>s. s \<lparr> own0  := ((own0 s) (ord := v))\<rparr>"

definition set_own1 :: "nat \<Rightarrow> F1 \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`own1 _ := _" [200])  where
  "set_own1 ord v  \<equiv> \<lambda>s. s \<lparr> own1  := ((own1 s) (ord := v))\<rparr>"

definition set_own2 :: "Pointer \<Rightarrow> F2 \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`own2 _ := _" [200])  where
  "set_own2 ord v  \<equiv> \<lambda>s. s \<lparr> own2  := ((own2 s) (ord := v))\<rparr>"

definition set_hW :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`hW := _" [200])  where
  "set_hW v  \<equiv> \<lambda>s. s \<lparr> hW  := v\<rparr>"

definition set_tW :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`tW := _" [200])  where
  "set_tW v  \<equiv> \<lambda>s. s \<lparr> tW  := v\<rparr>"

definition update_count :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`count := _" [200]) where
  "update_count v\<equiv> \<lambda>s. s \<lparr> count := v\<rparr>"

definition set_temp :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`temp := _" [200]) where
  "set_temp v \<equiv> \<lambda>s. s \<lparr> temp := v\<rparr>"

definition update_pcW :: "PCW \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`pcW := _" [200]) where
  "update_pcW v \<equiv> \<lambda>s. s \<lparr> pcW := v\<rparr>"

definition update_pcR :: "PCR \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`pcR := _" [200]) where
  "update_pcR v \<equiv> \<lambda>s. s \<lparr> pcR := v\<rparr>"

definition set_arrayR :: "nat \<Rightarrow> nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`arrayR _ := _" [200])  where
  "set_arrayR ord v  \<equiv> \<lambda>s. s \<lparr> arrayR  := ((arrayR s) (ord := v))\<rparr>"

abbreviation update_b_err :: "rb_state \<Rightarrow> rb_state" ("ERROOM") where
  "update_b_err \<equiv> \<lambda>s. s \<lparr> pcW := OOM \<rparr>"

lemmas functs  = push_H_def push_T_def set_hW_def set_tW_def
                        update_count_def set_temp_def
                        update_pcW_def update_pcR_def set_arrayR_def
                        set_WFlag_def set_RFlag_def

record c_state =
  q :: "(nat \<times> nat) list"
  rb :: rb_state

abbreviation update_q :: "(nat \<times> nat) list \<Rightarrow> c_state \<Rightarrow> c_state" ("`q := _" [200])
  where
  "update_q v  \<equiv> \<lambda>s. s \<lparr>q := v\<rparr>"
(***********************************************************************)

(* Define the states threads can find themselves in *)

definition "ACQ_PCW \<equiv> {A2, A3, A4, A5, A6, A7, A8, A1} \<union> {v. (\<exists> l k. v = OK (l, k))}"
definition "EXT_PCW \<equiv> {OOM, idleW, FinishedW} \<union> {v. (\<exists> l k. v = OK (l, k))}"
definition "ACQ_PCR \<equiv> {v. (\<exists> i. v = R1 i)}"
definition "EXT_PCR \<equiv> {idleR}"
(***********************************************************************)

(*  Define the if statement "guards"  *)

definition "off bo \<equiv> fst bo"
definition "len bo \<equiv> snd bo"
definition "grd1 s \<equiv> (tW s = hW s) \<and> (temp s \<le> N)"
definition "grd2 s \<equiv> (tW s > hW s) \<and> (temp s \<le> (tW s - hW s))"
definition "grd3 s \<equiv> tW s < hW s"
definition "grd4 s \<equiv> temp s \<le> N - hW s"
definition "grd5 s \<equiv> temp s < tW s"
lemmas grd_simps [simp] = off_def len_def grd1_def grd2_def grd3_def grd4_def grd5_def
(***********************************************************************)

(*  Initial State  *)

definition "init s \<equiv> (H (rb s) = 0) \<and> (T (rb s) = 0) \<and> q s = []
                        \<and> ( pcW (rb s) = idleW)
                        \<and> ( pcR (rb s) = idleR)
                        \<and> (\<forall>l. (l<n) \<longrightarrow>  arrayW (rb s) l > 0) \<and> (\<forall>l. arrayW (rb s) l < N)
                        \<and> (\<forall>l. (l<n) \<longrightarrow>  arrayR (rb s) l = 0)
                        \<and> (\<forall>p. (p<n) \<longrightarrow>\<not>WFlag (rb s) p) \<and> (\<forall>q. (q<n) \<longrightarrow>\<not>RFlag (rb s) q)
                        \<and> (\<forall>i. (i<n) \<longrightarrow>  own0 (rb s) i = Arr\<^sub>W) \<and> (\<forall>j. (j<N) \<longrightarrow>  own1 (rb s) j = B)
                        \<and> (own2 (rb s) Head = W) \<and> (own2 (rb s) Tail = Q) \<and> (count (rb s) = 0)"
(***********************************************************************)

(*Writer Thread Behaviour*)

fun rbW_step :: "PCW \<Rightarrow> rb_state \<Rightarrow> rb_state" where
  "rbW_step A1 s = ((`temp := (arrayW s (count s))) \<circ> (`hW := (H s)) \<circ> (`tW := (T s)) \<circ> (`pcW := A2)) s "
| "rbW_step A2 s = (if grd1 s then (`pcW := A3)
                     else if grd2 s then (`pcW := A4)
                     else if grd3 s then (`pcW := A5)
                     else (`pcW :=A8)) s"
| "rbW_step A3 s = ((`T := 0) \<circ> (`H := (temp s))  \<circ> (`pcW := (OK (0,temp s)))) s"
| "rbW_step A4 s = ((`H := ((hW s) + (temp s)))  \<circ> (`pcW := (OK(hW s, temp s)))) s"
| "rbW_step A5 s = (if grd4 s then (`pcW := A6)
                     else if grd5 s then (`pcW := A7)
                     else (`pcW := A8)) s"
| "rbW_step A6 s = (`H := ((hW s) + (temp s)) \<circ> `pcW := (OK(hW s, temp s))) s"
| "rbW_step A7 s = ((`H := (temp s)) \<circ> `pcW := (OK(0, temp s))) s"
| "rbW_step A8 s = (if ((temp s)>N) then (ERROOM)
                        else `pcW := idleW) s"

definition "acq s s' \<equiv> ((pcW (rb s) \<in> {idleW})
                            \<and> (arrayW (rb s) (count (rb s))) > 0
                            \<and> (rb s') = (`pcW := A1) (rb s))
                            \<and> count (rb s) < n
                            \<and> (q s' = q s)"

definition cW_step :: "PCW \<Rightarrow> c_state \<Rightarrow> c_state \<Rightarrow> bool" where
 "cW_step pcw s s' \<equiv>
    case pcw of
        OK v \<Rightarrow>  q s' = (append (q s) [v])
                \<and> rb s'= (`temp:=0) (rb s)
                \<and> rb s' = (`pcW := idleW) (rb s)
                \<and> rb s' = (`count := (count (rb s) + 1)) (rb s)
      | idleW \<Rightarrow> if (count (rb s) < n)
                      then acq s s'
                 else (rb s') = (`pcW := FinishedW) (rb s) \<and> (q s' = q s)
      | OOM  \<Rightarrow> s = s'
      | FinishedW \<Rightarrow> s = s'
      | _  \<Rightarrow>  q s' = q s \<and> (rb s') = rbW_step pcw (rb s) "
(***********************************************************************)

(*Reader Thread Behaviour*)

fun rbR_step :: "PCR \<Rightarrow> rb_state \<Rightarrow> rb_state" where
   "rbR_step (R1 k) s = (`T := (off k + len k) \<circ> (`pcR := idleR)) s"

definition "read s s' \<equiv> (pcR (rb s) \<in> {idleR})
                              \<and> (let q_hd = hd (q s) ;
                                     q_tl = tl (q s)
                                 in q s' =  q_tl
                                 \<and> rb s' = (`pcR := (R1 q_hd)) (rb s))"

definition cR_step :: "PCR \<Rightarrow> c_state \<Rightarrow> c_state \<Rightarrow> bool" where
 "cR_step pcr s s' \<equiv>
    case pcr of
        idleR \<Rightarrow> if (q s=[]) then (s=s') else (read s s')
      | R1 k  \<Rightarrow>  q s' = q s \<and> (rb s') = rbR_step (R1 k) (rb s)"
(***********************************************************************)

definition "inRange v \<equiv> 0 \<le> v \<and> v \<le> N"

definition "inRangeHT s \<equiv> inRange (H s) \<and> inRange (T s)"

definition "H0_T0 s \<equiv> H s = 0 \<longrightarrow> T s = 0"

definition "inRangeht s \<equiv> inRange (hW s) \<and> inRange (tW s)"

definition inv :: "PCW \<Rightarrow> PCR \<Rightarrow> c_state \<Rightarrow> bool " where
"inv pcw pcr c \<equiv>
   (let s = rb c in
    inRangeHT s \<and> H0_T0 s
    \<and> (\<forall> qb \<in> set (q c) . inRange (off qb + len qb))
    \<and> (pcw \<in> ACQ_PCW \<longrightarrow> (temp s > 0) \<or> (pcW s = A1))
    \<and>
    (case pcw of
           A1     \<Rightarrow> arrayW s (count s) > 0
         | A2     \<Rightarrow> H s = hW s \<and> inRangeht s
         | A3     \<Rightarrow> H s = hW s \<and> temp s \<le> N
         | A4     \<Rightarrow> H s = hW s \<and> hW s + temp s \<le> N \<and> hW s + temp s > 0
         | A5     \<Rightarrow> H s = hW s \<and> tW s < hW s \<and> inRangeht s
         | A6     \<Rightarrow> H s = hW s \<and> inRangeht s \<and> hW s + temp s \<le> N \<and> hW s + temp s > 0
         | A7     \<Rightarrow> H s = hW s \<and> inRangeht s \<and> temp s < tW s
         | A8     \<Rightarrow> H s = hW s

         | OK rv  \<Rightarrow> inRange (off rv + len rv) \<and> 0 < H s

         | idleW  \<Rightarrow> (q c \<noteq> [] \<longrightarrow> 0 < H s)
         | OOM    \<Rightarrow> True
         | FinishedW \<Rightarrow> count s = n)
    \<and>
    (case pcr of
           R1 v  \<Rightarrow> inRange (off v + len v) \<and> (0 < H s)
         | idleR  \<Rightarrow> (q c \<noteq> [] \<longrightarrow> (0 < H s)))
  )"

lemmas inv_simps [simp] = H0_T0_def inv_def inRangeHT_def inRange_def inRangeht_def
                    cW_step_def cR_step_def init_def

lemmas ACQ_EXT [simp] = ACQ_PCR_def ACQ_PCW_def EXT_PCW_def EXT_PCR_def

lemma inv_init:
  assumes "init s"
    and "pcw = (pcW (rb s))"
    and "pcr = (pcR (rb s))"
  shows "inv pcw pcr s"
  using assms  by (simp)

lemma R_doesnt_move_H:
  assumes "con_assms"
  and "pcr = pcR (rb s)"
  and "inv (pcW (rb s)) pcr s"
  and "cR_step pcr s s'"
  and "pcW (rb s') = pcW (rb s)"
shows "H (rb s') = H (rb s)"
  using assms
  apply auto
  apply(unfold read_def)
  apply(unfold functs)
  apply (cases "pcW (rb s)", simp_all add: Let_def)
             apply(case_tac[!] "pcR (rb s)", simp_all add: functs)
             apply(case_tac[!] "q s=[]", simp_all)
  done

lemmas moves = R_doesnt_move_H

lemma inv_local_W_int:
  assumes "con_assms"
  and "pcw = pcW (rb s)"
  and "inv pcw (pcR (rb s)) s"
  and "cW_step pcw s s'"
  and "count (rb s) \<le>n"
  and "pcw \<noteq> pcW (rb s')"
  and "\<forall>l. ArrW (rb s) l < N"
shows "inv (pcW (rb s')) (pcR (rb s')) s'"
  using assms
  apply(auto)
  apply(unfold functs)
  apply(unfold acq_def)
  apply (case_tac[!] "pcW (rb s)", simp_all add: functs)
          apply (case_tac[!] "pcR (rb s)", simp_all add: functs)
          apply (case_tac[!]  "pcW (rb s')", simp_all add: functs)
               apply (case_tac[!] "tW (rb s) = hW (rb s) \<and> temp (rb s) \<le> N", simp_all add: Let_def)
               apply (case_tac[!] " hW (rb s) < tW (rb s) \<and> temp (rb s) \<le> tW (rb s) - hW (rb s)", simp_all)
               apply (case_tac[!] "temp (rb s) \<le> N - hW (rb s)", simp_all add:functs)
               apply (case_tac[!] "N < temp (rb s)", simp_all add:functs)
                      apply(case_tac[!] "tW (rb s) < hW (rb s)", simp_all add:functs, meson)
                      apply(case_tac[!] "count (rb s) < n", simp_all add:functs)
  apply(linarith+)
  done

lemma inv_local_R_int:
  assumes "con_assms"
  and "pcr = pcR (rb s)"
  and "pcw = pcW (rb s)"
  and "inv pcw pcr s"
  and "pcW (rb s) = pcW (rb s')"
  and "cR_step pcr s s'"
shows "inv pcw (pcR (rb s')) s'"
   using assms
  apply auto
  apply (case_tac[!] "pcW (rb s')",  simp_all add: Let_def)
             apply(case_tac[!] "pcR (rb s)", simp_all add: functs)
             apply(case_tac[!] "q s=[]", simp_all add:read_def functs)
                      apply (simp_all add: list.set_sel(2))
  done

lemma inv_global_W_int:
  assumes "con_assms"
  and "pcr = pcR (rb s)"
  and "pcw = pcW (rb s)"
  and "inv pcw pcr s"
  and "cR_step pcr s s'"
shows "inv (pcW (rb s')) (pcR (rb s')) s'"
  using assms
  apply(case_tac[!] "pcW (rb s)", simp_all add:Let_def)
             apply(case_tac[!] "pcR (rb s)", simp_all add:functs)
             apply(case_tac[!] "pcW (rb s')", simp_all)
                      apply(case_tac[!] "pcR (rb s')", simp_all)
                      apply(case_tac[!] "q s=[]", simp_all)
                      apply(case_tac[!] "read s s'",simp_all add:read_def functs)
  apply((meson list.set_sel(1) list.set_sel(2))+)
  done

lemma inv_global_R_int:
  assumes "con_assms"
  and "pcr = pcR (rb s)"
  and "pcw = pcW (rb s)"
  and "inv pcw pcr s"
  and "cW_step pcw s s'"
  and "pcR (rb s') = pcr"
  and "pcw\<notin>{idleW}\<longrightarrow>pcW (rb s')\<noteq>pcw"
  and "count (rb s) \<le>n"
shows "inv (pcW (rb s')) (pcR (rb s')) s'"
  using assms
  apply(simp_all add:Let_def)
  apply(case_tac[!] "pcW (rb s)", simp_all add:functs)
           apply(case_tac[!] "pcW (rb s')", simp_all add:functs)
             apply(case_tac[!] "pcR (rb s)", simp_all)
             apply(case_tac[!] "pcR (rb s)", simp_all)
             apply(case_tac[!] "tW (rb s) = hW (rb s) \<and> temp (rb s) \<le> N", simp_all add:functs)
             apply(case_tac[!] "hW (rb s) < tW (rb s) \<and> temp (rb s) \<le> tW (rb s) - hW (rb s)", simp_all add:functs)
             apply(case_tac[!] "tW (rb s) < hW (rb s)", simp_all add:functs)
             apply(case_tac[!] "N < temp (rb s)", simp_all add:functs)
                      apply(case_tac[!] "count (rb s)<n",simp_all)
                      apply(case_tac[!] "\<not> WFlag (rb s) (count (rb s))", simp_all)
                      apply(unfold acq_def)
                      apply(unfold functs)
                      apply(simp_all+)
                      apply linarith+
  done

lemma pcR_stable_ext:
  "con_assms \<Longrightarrow> cW_step pcw s s' \<Longrightarrow> pcR (rb s)= pcR (rb s')"
  apply(cases "pcw", simp_all add:functs)
  apply(cases "count (rb s)", simp_all add:functs)
   apply(cases "0<n", simp_all)
    apply(cases "s=s'", simp_all add:acq_def functs)
  apply(cases "count (rb s)<n", simp_all)
   apply(cases "s=s'", simp_all add:acq_def functs)
  done

lemma pcW_stable_ext:
  "con_assms \<Longrightarrow> cR_step pcr s s' \<Longrightarrow> pcW (rb s)= pcW (rb s')"
  apply(cases "pcr", simp_all add:functs)
  apply(cases "q s =[]", simp_all add:read_def functs)
  done

lemma W_doesnt_move_T:
  assumes "H (rb s)\<noteq> T (rb s)"
  and "H (rb s)\<noteq>0"
  and "cW_step pcw s s'"
  and "pcw\<noteq>A3"
shows "T (rb s) = T (rb s')"
  using assms
  apply(auto)
  apply(cases "pcw", simp_all add:functs)
  apply(cases "count(rb s)<n", simp_all add:functs acq_def)
  done


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                   July 2005  (modified)   |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                  March 2007  (modified)   |
            |                 August 2007  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory CSP_T_continuous
imports CSP_T_traces Domain_T_cpo CPO_prod
begin

(*****************************************************************

         1. continuous traces
         2. continuous [[ ]]Tfun

 *****************************************************************)

(*--------------------------------*
 |        STOP,SKIP,DIV           |
 *--------------------------------*)

(*** Constant_continuous ***)

lemma continuous_Constant: "continuous (%p. C)"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (insert complete_cpo_lm)
apply (drule_tac x="X" in spec, simp)
apply (simp add: hasLUB_def)
apply (elim exE)
apply (simp add: image_def isLUB_def isUB_def)
apply (intro allI impI)
apply (elim conjE exE)
apply (drule mp)
apply (simp add: directed_def)
apply (auto)
done

lemma continuous_traces_STOP: "continuous (traces (STOP))"
by (simp add: traces_iff continuous_Constant)

lemma continuous_traces_SKIP: "continuous (traces (SKIP))"
by (simp add: traces_iff continuous_Constant)

lemma continuous_traces_DIV: "continuous (traces (DIV))"
by (simp add: traces_iff continuous_Constant)

(*--------------------------------*
 |          Act_prefix            |
 *--------------------------------*)

lemma continuous_traces_Act_prefix:
 "continuous (traces P) ==> continuous (traces (a -> P))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)

(* <= *)
apply (rule)
apply (simp add: in_traces)
apply (erule disjE, fast)
apply (elim conjE exE)
apply (simp)

(* => *)
apply (rule)
apply (simp)
apply (erule bexE)
apply (simp add: in_traces)
apply (erule disjE, simp)
apply (elim conjE exE)
apply (rule disjI2)
apply (rule_tac x="s" in exI, simp)
apply (rule_tac x="xa" in bexI)
apply (simp_all)

by (simp add: directed_def)

(*--------------------------------*
 |        Ext_pre_choice          |
 *--------------------------------*)

lemma continuous_traces_Ext_pre_choice:
 "ALL a. continuous (traces (Pf a))
  ==> continuous (traces (? a:X -> (Pf a)))"
apply (simp add: continuous_iff)
apply (intro allI impI)

apply (subgoal_tac "Xa ~= {}")
apply (erule exchange_forall_orderE)
apply (drule_tac x="Xa" in spec)
apply (simp add: isLUB_UnionT)

apply (rule_tac x="LUB Xa" in exI)
apply (rule conjI)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (erule disjE, fast)
 apply (elim conjE exE)
 apply (simp)
 apply (drule_tac x="a" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB Xa = x", simp)
 apply (simp add: isLUB_LUB)

(* => *)
 apply (rule)
 apply (simp)
 apply (erule bexE)
 apply (simp add: in_traces)
 apply (erule disjE, simp)
 apply (elim conjE exE)
 apply (rule disjI2)
 apply (rule_tac x="a" in exI)
 apply (rule_tac x="s" in exI, simp)

 apply (drule_tac x="a" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB Xa = xa", simp)
 apply (rule_tac x="x" in bexI)
 apply (simp)
 apply (simp)
 apply (simp add: isLUB_LUB)

 apply (drule_tac x="a" in spec)
 apply (elim conjE exE)
 apply (simp add: isLUB_LUB)

by (simp add: directed_def)

(*--------------------------------*
 |          Ext_choice            |
 *--------------------------------*)

lemma continuous_traces_Ext_choice:
 "[| continuous (traces P) ; continuous (traces Q) |]
  ==> continuous (traces (P [+] Q))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)
 apply (rule, simp add: in_traces, fast)
 apply (rule, simp add: in_traces, fast)
apply (simp add: directed_def)
by (rule LUB_unique, simp_all)

(*--------------------------------*
 |          Int_choice            |
 *--------------------------------*)

lemma continuous_traces_Int_choice:
 "[| continuous (traces P) ; continuous (traces Q) |]
  ==> continuous (traces (P |~| Q))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)
 apply (rule, simp add: in_traces, fast)
 apply (rule, simp add: in_traces, fast)
apply (simp add: directed_def)
by (rule LUB_unique, simp_all)

(*--------------------------------*
 |        Rep_int_choice          |
 *--------------------------------*)

lemma continuous_traces_Rep_int_choice:
 "ALL c. continuous (traces(Pf c))
  ==> continuous (traces (!! :C .. Pf))"
apply (simp add: continuous_iff)
apply (intro allI impI)

apply (subgoal_tac "X ~= {}")
apply (erule exchange_forall_orderE)
apply (drule_tac x="X" in spec)
apply (simp add: isLUB_UnionT)

apply (rule_tac x="LUB X" in exI)
apply (rule conjI)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (erule disjE, fast)
 apply (elim conjE bexE)
 apply (drule_tac x="c" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB X = x", simp)
 apply (elim bexE)
 apply (rule_tac x="xa" in bexI)
 apply (fast)
 apply (simp)
 apply (simp add: isLUB_LUB)

(* => *)
 apply (rule)
 apply (simp)
 apply (erule bexE)
 apply (simp add: in_traces)
 apply (erule disjE, simp)
 apply (elim conjE bexE)
 apply (rule disjI2)
 apply (rule_tac x="c" in bexI)

 apply (drule_tac x="c" in spec)
 apply (elim conjE exE)
 apply (subgoal_tac "LUB X = xa", simp)
 apply (rule_tac x="x" in bexI)
 apply (simp)
 apply (simp)
 apply (simp add: isLUB_LUB)
 apply (simp)

 apply (drule_tac x="c" in spec)
 apply (elim conjE exE)
 apply (simp add: isLUB_LUB)

by (simp add: directed_def)

(*--------------------------------*
 |                IF              |
 *--------------------------------*)

lemma continuous_traces_IF:
 "[| continuous (traces P) ; continuous (traces Q) |]
  ==> continuous (traces (IF b THEN P ELSE Q))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)
apply (case_tac "b")
 apply (rule_tac x="x" in exI, simp)
 apply (simp add: traces_iff)
 apply (rule_tac x="xa" in exI, simp)
 apply (simp add: traces_iff)
done

(*--------------------------------*
 |           Parallel             |
 *--------------------------------*)

lemma continuous_traces_Parallel:
 "[| continuous (traces P) ; continuous (traces Q) |]
  ==> continuous (traces (P |[X]| Q))"
apply (subgoal_tac "mono (traces P) & mono (traces Q)")

apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="Xa" in spec, simp)
apply (drule_tac x="Xa" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "Xa ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim exE bexE conjE)

 apply (simp add: directed_def)
 apply (drule_tac x="xb" in spec)
 apply (drule_tac x="xc" in spec)
 apply (simp, elim conjE exE)
 apply (rule_tac x="z" in bexI)
 apply (rule_tac x="s" in exI)
 apply (rule_tac x="ta" in exI)
 apply (simp)
 apply (rule conjI)
 apply (rule memT_subdomT, simp)
 apply (simp add: mono_def)
 apply (rotate_tac -4)
 apply (rule memT_subdomT, simp)
 apply (simp add: mono_def)
 apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (fast)

apply (simp add: directed_def)
apply (simp add: LUB_unique)

by (simp add: continuous_mono)

(*--------------------------------*
 |            Hiding              |
 *--------------------------------*)

lemma continuous_traces_Hiding:
 "continuous (traces P)
  ==> continuous (traces (P -- X))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="Xa" in spec, simp)
apply (elim conjE exE)

apply (rule_tac x="x" in exI, simp)
apply (subgoal_tac "Xa ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (fast)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (fast)

by (simp add: directed_def)

(*--------------------------------*
 |           Renaming             |
 *--------------------------------*)

lemma continuous_traces_Renaming:
 "continuous (traces P)
  ==> continuous (traces (P [[r]]))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (rule_tac x="x" in exI, simp)
apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)
 apply (rule, simp add: in_traces, fast)
 apply (rule, simp add: in_traces, fast)
by (simp add: directed_def)

(*--------------------------------*
 |           Seq_compo            |
 *--------------------------------*)

lemma continuous_traces_Seq_compo:
 "[| continuous (traces P) ; continuous (traces Q) |]
  ==> continuous (traces (P ;; Q))"
apply (subgoal_tac "mono (traces P) & mono (traces Q)")
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (subgoal_tac "xa = x")
apply (rule_tac x="x" in exI, simp)

apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)

(* <= *)
 apply (rule)
 apply (simp add: in_traces)
 apply (elim bexE exE conjE disjE)
 apply (rule_tac x="xb" in bexI)
 apply (fast)
 apply (simp)

 apply (simp add: directed_def)
 apply (drule_tac x="xb" in spec)
 apply (drule_tac x="xc" in spec)
 apply (simp, elim conjE exE)
 apply (rule_tac x="z" in bexI)
 apply (rule disjI2)
 apply (rule_tac x="s" in exI)
 apply (rule_tac x="ta" in exI)
 apply (simp)
 apply (rule conjI)
 apply (rule memT_subdomT, simp)
 apply (simp add: mono_def)
 apply (rotate_tac -4)
 apply (rule memT_subdomT, simp)
 apply (simp add: mono_def)
 apply (simp)

(* => *)
 apply (rule)
 apply (simp add: in_traces)
 apply (fast)

apply (simp add: directed_def)
apply (simp add: LUB_unique)

by (simp add: continuous_mono)

(*--------------------------------*
 |          Depth_rest            |
 *--------------------------------*)

lemma continuous_traces_Depth_rest:
 "continuous (traces P)
  ==> continuous (traces (P |. n))"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (drule_tac x="X" in spec, simp)
apply (elim conjE exE)

apply (rule_tac x="x" in exI, simp)
apply (subgoal_tac "X ~= {}")
apply (simp add: isLUB_UnionT)
apply (rule order_antisym)
 apply (rule, simp add: in_traces)
 apply (rule, simp add: in_traces)
by (simp add: directed_def)

(*--------------------------------*
 |            variable            |
 *--------------------------------*)

lemma continuous_traces_variable:
   "continuous (traces ($p))"
apply (simp add: traces_iff)
apply (simp add: continuous_prod_variable)
done

(*--------------------------------*
 |            Procfun             |
 *--------------------------------*)

lemma continuous_traces:
  "continuous (traces P)"
apply (induct_tac P)
apply (simp add: continuous_traces_STOP)
apply (simp add: continuous_traces_SKIP)
apply (simp add: continuous_traces_DIV)
apply (simp add: continuous_traces_Act_prefix)
apply (simp add: continuous_traces_Ext_pre_choice)
apply (simp add: continuous_traces_Ext_choice)
apply (simp add: continuous_traces_Int_choice)
apply (simp add: continuous_traces_Rep_int_choice)
apply (simp add: continuous_traces_IF)
apply (simp add: continuous_traces_Parallel)
apply (simp add: continuous_traces_Hiding)
apply (simp add: continuous_traces_Renaming)
apply (simp add: continuous_traces_Seq_compo)
apply (simp add: continuous_traces_Depth_rest)
apply (simp add: continuous_traces_variable)
done

(*=============================================================*
 |                          [[P]]Tf                            |
 *=============================================================*)

lemma continuous_semTf:
  "continuous [[P]]Tf"
apply (simp add: semTf_def)
apply (simp add: continuous_traces)
done

(*=============================================================*
 |                         [[P]]Tfun                           |
 *=============================================================*)

lemma continuous_semTfun: "continuous [[Pf]]Tfun"
apply (simp add: prod_continuous)
apply (simp add: semTfun_def)
apply (simp add: proj_fun_def)
apply (simp add: comp_def)
apply (simp add: continuous_semTf)
done

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)
(*<*)
theory EgTop2
imports GenFilter2System
begin

(* A component may receive on a given channel *)
fun
  receives_on :: "channel \<Rightarrow> component \<Rightarrow> bool"
where
   "receives_on c (Response f) = (\<exists>q s. \<exists>a \<in> f q s. a_channel (snd a) = c)"
 | "receives_on c (a ;; b) = (receives_on c a \<or> receives_on c b)"
 | "receives_on c (IF cond THEN a ELSE b) = (\<forall>s. cond s \<and> receives_on c a \<or> \<not> cond s \<and> receives_on c b)"
 | "receives_on c (WHILE cond DO a) = (\<forall>s. cond s \<and> receives_on c a \<or> \<not> cond s)"
 | "receives_on c (a \<squnion> b) = (receives_on c a \<or> receives_on c b)"
 | "receives_on _ _ = False"

(* Whether a component ever sends a question in a given set. *)
fun
  sends :: "component \<Rightarrow> channel question set \<Rightarrow> bool"
where
   "sends (Request f _) qs = (\<exists>s. \<exists>q \<in> f s. q \<in> qs)"
 | "sends (a ;; b) qs = (sends a qs \<or> sends b qs)"
 | "sends (IF cond THEN a ELSE b) qs = (\<forall>s. cond s \<and> sends a qs \<or> \<not> cond s \<and> sends b qs)"
 | "sends (WHILE cond DO a) qs = (\<forall>s. cond s \<and> sends a qs \<or> \<not> cond s)"
 | "sends (a \<squnion> b) qs = (sends a qs \<or> sends b qs)"
 | "sends _ _ = False"
(*>*)

text \<open>
  Now it's possible to state and prove the desired property of the system; that
  @{term client} never receives the secret ``baz''.
\<close>

lemma "\<forall>p. \<exists>e s. gs\<^sub>0 p = Some (e, s) \<and>
  (e = client_untrusted \<or>
  \<not>(\<exists>c. sends e {x. q_channel x = c \<and> q_data x = Return [String ''baz'']} \<and>
  receives_on c client_untrusted))"
  unfolding gs\<^sub>0_def trusted_def apply clarsimp
  apply (case_tac p, clarsimp)
    unfolding store_untrusted_def Store_untrusted_def apply clarsimp
    unfolding UserStep_def ArbitraryRequest_def ArbitraryResponse_def
    apply clarsimp
    unfolding client_untrusted_def Client_untrusted_def apply clarsimp
    unfolding UserStep_def ArbitraryRequest_def ArbitraryResponse_def
    apply clarsimp
   apply clarsimp
  apply clarsimp
  unfolding filter_trusted_def UserStep_def ArbitraryRequest_def
            ArbitraryResponse_def apply clarsimp
  unfolding filter_responses_def apply clarsimp
  done

(*<*)
end
(* > *)


theory Ports
imports
  "HOL-Word.Word"
  "../Common/WordInterval_Lists"
  L4_Protocol_Flags
begin

section\<open>Ports (layer 4)\<close>
text\<open>E.g. source and destination ports for TCP/UDP\<close>

text\<open>list of (start, end) port ranges\<close>
type_synonym raw_ports = "(16 word \<times> 16 word) list"

fun ports_to_set :: "raw_ports \<Rightarrow> (16 word) set" where
  "ports_to_set [] = {}" |
  "ports_to_set ((s,e)#ps) = {s..e} \<union> ports_to_set ps"

lemma ports_to_set: "ports_to_set pts = \<Union> {{s..e} | s e . (s,e) \<in> set pts}"
  proof(induction pts)
  case Nil thus ?case by simp
  next
  case (Cons p pts) thus ?case by(cases p, simp, blast)
  qed

text\<open>We can reuse the wordinterval theory to reason about ports\<close>
lemma ports_to_set_wordinterval: "ports_to_set ps = wordinterval_to_set (l2wi ps)"
  by(induction ps rule: l2wi.induct) (auto)

text\<open>inverting a raw listing of ports\<close>
definition "raw_ports_invert" :: "raw_ports \<Rightarrow> raw_ports" where
  "raw_ports_invert ps = wi2l (wordinterval_invert (l2wi ps))"

lemma raw_ports_invert: "ports_to_set (raw_ports_invert ps) = - ports_to_set ps"
  by(auto simp add: raw_ports_invert_def l2wi_wi2l ports_to_set_wordinterval)

text\<open>A port always belongs to a protocol! We must not lose this information.
 You should never use @{typ raw_ports} directly\<close>
datatype ipt_l4_ports = L4Ports primitive_protocol raw_ports

end


theory DerivationTrees_Ambiguity
  imports  "OperatorAmbiguity" "DerivationTrees1" "LocalLexing2.Ladder"  "LocalLexing2.TheoremD6"
begin
context OperatorAmbiguity
begin
(*termination measure on subtrees? e.g. induction*)
(*rotation via insert?*)
function insert_left::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree" where
"insert_left (Leaf a) _ = (Leaf a)" |
"insert_left (Inner a) (DT r b) = (if (fst r = a) then (DT r b) else (Inner a))"|
"insert_left  (Inner a ) _ = (Inner a)"|
"insert_left (DT r b) (DT r' b') = (DT r ((insert_left (hd b) (DT r' b'))#(tl b)))"|
"insert_left (DT r b) _ = (DT r b)"
  sorry
termination sorry
(* (DT r b, DT r' b') ~> (last b, DT r' b')*)
function insert_right::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree" where
"insert_right (Leaf a) _ = (Leaf a)" |
"insert_right (Inner a) (DT r b) = (if (fst r = a) then (DT r b) else (Inner a))"|
"insert_right  (Inner a ) _ = (Inner a)"|
"insert_right (DT r b) (DT r' b') = (DT r ((butlast b)@[insert_right (last b) (DT r' b')]))"|
"insert_right (DT r b) _ = (DT r b)"
  apply(auto) sorry
termination sorry

lemma root_symbol:"DeriveFromTree (DT r b) = (s', a') \<Longrightarrow> fst r = s'"
  by auto
(*how to use assumptions in induction*)
lemma insertion_left_effect:
  shows "DeriveFromTree t = (s, a) \<Longrightarrow> DeriveFromTree (DT r b) = (s', a') \<Longrightarrow> hd a = s' \<Longrightarrow>DeriveFromTree (insert_left t (DT r b)) = (s, a'@(tl a))"
proof(induct t arbitrary: s a rule: derivtree.induct)
  case (Leaf x)(*does not hold by contradiction*)
  then show ?case sorry
next
  case (Inner x)
  then  have eq:"s = x"  "a = [x]" by auto
  then  have ins:"insert_left (Inner x) (DT r b) = (DT r b)" sorry
  from Inner.prems(1) have tl:"tl a = []" by auto
  have eq1:"s = s'" using Inner.prems by auto
  have "fst r = s'" using root_symbol Inner.prems(2) by blast
  then have "fst r = x" using eq eq1 by blast
  then show ?case using ins by simp
next
  case (DT r' b')
  from DT.prems(1) have root:"fst r' = s" by simp
  obtain left where "left = hd b'" by blast
  obtain tree where nodedef:"tree = insert_left (DT r' b') (DT r b)" by blast
  then have node:"tree =  (DT r' ((insert_left (hd b') (DT r b))#(tl b')))" sorry
  obtain x' where hd:"x' = hd b'"  by blast
  then have xset:"x' \<in> set b'" (*need to have b' nonempty*) sorry
  obtain s'' a'' where hd1:"DeriveFromTree x' = (s'', a'')" by fastforce
  then have hd2:"a'' = snd (DeriveFromTree x')" by auto
  obtain tl_deriv where tl_deriv:"tl_deriv = map (\<lambda>s . (snd (DeriveFromTree s))) (tl b')" by blast
  obtain l'' where tl_concat:" l''= concat(tl_deriv)" by blast
  with hd2 DT.prems(1) hd have  concat:"a''@l'' = a" apply(auto)  sorry
  have "a'' \<noteq> []" using hd1 sorry(*wf lemma*)
  with concat have tl:"tl a = (tl a'')@l''" by force
  have "hd a'' = s'" sorry (*need lemmas*)
  with DT(1) xset hd1 DT.prems(2) have "DeriveFromTree (insert_left x' (DT r b)) = (s'', a' @ tl a'')" by blast
  then have " a' @ tl a'' = snd (DeriveFromTree (insert_left x' (DT r b)))" by simp
  with tl_deriv hd have map:"(a'@tl a'')#tl_deriv=
      map (\<lambda>s . (snd (DeriveFromTree s))) ((insert_left (hd b') (DT r b))#(tl b'))" using Cons_eq_map_conv by force
  with tl_concat tl have "concat ((a'@tl a'')#tl_deriv) = (a'@tl a)" by simp
  with map node root have "DeriveFromTree tree = (s, a'@(tl a))" by simp
  with nodedef show ?case by blast
qed

lemma insertion_right_effect:
  shows "DeriveFromTree t = (s, a) \<Longrightarrow> DeriveFromTree (DT r b) = (s', a') \<Longrightarrow> last a = s' \<Longrightarrow>DeriveFromTree (insert_right t (DT r b)) = (s, (butlast a)@a')"
proof(induct t arbitrary: s a rule: derivtree.induct)
  case (Leaf x)(*does not hold by contradiction*)
  then show ?case sorry
next
  case (Inner x)
  then  have eq:"s = x"  "a = [x]" by auto
  then  have ins:"insert_right (Inner x) (DT r b) = (DT r b)" sorry
  from Inner.prems(1) have tl:"tl a = []" by auto
  have eq1:"s = s'" using Inner.prems by auto
  have "fst r = s'" using root_symbol Inner.prems(2) by blast
  then have "fst r = x" using eq eq1 by blast
  then show ?case using ins by simp
next
  case (DT r' b')
  from DT.prems(1) have root:"fst r' = s" by simp
  obtain left where "left = hd b'" by blast
  obtain tree where nodedef:"tree = insert_right (DT r' b') (DT r b)" by blast
  then have node:"tree =  (DT r' ((butlast b')@[(insert_right (last b') (DT r b))]))" sorry
  obtain x' where last:"x' = last b'"  by blast
  then have xset:"x' \<in> set b'" (*need to have b' nonempty*) sorry
  obtain s'' a'' where last1:"DeriveFromTree x' = (s'', a'')" by fastforce
  then have last2:"a'' = snd (DeriveFromTree x')" by auto
  obtain butlast_deriv where butlast:"butlast_deriv = map (\<lambda>s . (snd (DeriveFromTree s))) (butlast b')" by blast
  obtain l'' where bl_concat:" l''= concat(butlast_deriv)" by blast
  with last2 DT.prems(1) last have  concat:"l''@a'' = a" apply(auto)  sorry
  have "a'' \<noteq> []" using last1 sorry(*wf lemma*)
  with concat have tl:"butlast a = l''@(butlast a'')"  using butlast_append by metis
  have "last a'' = s'" sorry (*need lemmas over derive*)
  with DT(1) xset last1 DT.prems(2) have "DeriveFromTree (insert_right x' (DT r b)) = (s'', (butlast a'')@a')" by blast
  then have "(butlast a'')@a' = snd (DeriveFromTree (insert_right x' (DT r b)))" by simp
  with butlast last have map:"butlast_deriv@[(butlast a'')@a']=
      map (\<lambda>s . (snd (DeriveFromTree s))) (butlast b'@[(insert_right (last b') (DT r b))])" by simp
  with bl_concat tl have "concat (butlast_deriv@[(butlast a'')@a']) = ((butlast a)@a')" by simp
  with map node root have "DeriveFromTree tree = (s, (butlast a)@a')" by simp
  with nodedef show ?case by blast
qed
(*derivation append?*)

(*define trees to be wellformed*)
section "Rightspine / Leftspine"
fun children::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree list" where
"children (DT a b) = (DT a b)#(concat (map children b))"|
"children a = [a]"

(*for now only include actual rule applications*)
fun leftmost_children::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree list" where
"leftmost_children (DT a []) = [(Inner (fst a))]"|
"leftmost_children (DT a b) = (DT a b)#(leftmost_children (hd b))"|
"leftmost_children a = []"

 (*nontermination because b is not nonempty*)

fun rightmost_children::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree list" where
"rightmost_children (DT a []) = [(Inner (fst a))]"|
"rightmost_children (DT a b) = (DT a b)#(leftmost_children (last b))"|
"rightmost_children a = []"

fun leftspine1::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree list" where
"leftspine1 (DT a b)= (case (hd b) of (DT a' b') \<Rightarrow> rightmost_children (hd b) | a \<Rightarrow> [])"|
"leftspine1 _ = []"

fun rightspine1::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree list" where
"rightspine1 (DT a b)= (case (last b) of (DT a' b') \<Rightarrow> leftmost_children (last b) | a \<Rightarrow> [])"|
"rightspine1 _ = []"

fun leftmost_item::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree" where
"leftmost_item (DT a []) = (DT a [])"|
"leftmost_item (DT a b) = (case (hd b) of (DT a' b') \<Rightarrow> leftmost_item (hd b) | a \<Rightarrow> a)"|
"leftmost_item a = a"

function rightmost_item::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree" where
"rightmost_item (DT a []) = (DT a [])"|
"rightmost_item (DT a (b#B)) = (case (last (b#B)) of (DT a' b') \<Rightarrow> rightmost_item (last (b#B)) | a \<Rightarrow> a)"|
"rightmost_item a = a"
  apply(auto) sorry
termination sorry

lemma rotation:
  assumes "DeriveFromTree (DT r t) = (s, a)" " DeriveFromTree (DT r' t') = (s, b)"
  "(s = last a) \<and> (s = hd b) " "a \<noteq> []" "b \<noteq> []"
  shows "DeriveFromTree (insert_right (DT r t)  (DT r' t')) = DeriveFromTree (insert_left  (DT r' t') (DT r t))"
proof -
  from assms insertion_right_effect have deriv1:"DeriveFromTree (insert_right  (DT r t)  (DT r' t')) = (s, (butlast a)@b)" by fast
  from assms insertion_left_effect have deriv2:"DeriveFromTree (insert_left  (DT r' t')  (DT r t)) = (s, a@(tl b))"  by metis
  from assms have eq1:"(butlast a)@b =  (butlast a)@[s]@(tl b)" by fastforce
  from assms have eq2:"a@(tl b) = (butlast a)@[s]@(tl b)" by simp
  show ?thesis using deriv1 deriv2 eq1 eq2 by simp
qed

lemma rotation':
  assumes \<alpha>E:"DeriveFromTree (DT r t) = (s, a)"  and E\<beta>:"DeriveFromTree (DT r' t') = (s, b)" and E3:"DeriveFromTree (DT r'' t'') = (s, c)"
  and nonterms:"(s = last a) \<and> (s = hd b) " "a \<noteq> []" "b \<noteq> []"
shows "DeriveFromTree (insert_right (DT r t)  (insert_left (DT r' t') (DT r'' t'' ))) =
      DeriveFromTree (insert_left  (DT r' t') (insert_right (DT r t) (DT r'' t'')))"
proof -

  from assms insertion_right_effect have "DeriveFromTree (insert_right  (DT r t)  (DT r'' t'')) = (s, (butlast a)@c)" by fast
  with E\<beta> nonterms have deriv1: "DeriveFromTree (insert_left  (DT r' t') (insert_right (DT r t) (DT r'' t''))) = (s, (butlast a)@c@(tl b))"
    using insertion_left_effect by fastforce
  from assms insertion_left_effect have "DeriveFromTree (insert_left  (DT r' t')  (DT r'' t'')) = (s, c@(tl b))"  by metis
  with \<alpha>E nonterms have deriv2:"DeriveFromTree (insert_right (DT r t)  (insert_left (DT r' t') (DT r'' t'' ))) = (s, (butlast a)@c@(tl b))"
    using insertion_right_effect by fastforce
  show ?thesis using deriv1 deriv2  by simp
qed

(*proof insertion via all left/right subtrees?*)
(*define conflict between to trees a certain leftmost and rightmost element*)

(*parent and leftspine child \<Rightarrow> certain conflicts*)
fun leftconflictfree::"('a, 'b) rule \<Rightarrow> ('a, 'b) derivtree \<Rightarrow> bool" where
"leftconflictfree r  T  = (case T of (DT r' _) \<Rightarrow> ((r, r') \<notin> Priority \<and> (r, r') \<notin> Left) | _ \<Rightarrow> True)"

fun rightconflictfree::"('a, 'b) rule \<Rightarrow> ('a, 'b) derivtree \<Rightarrow> bool" where
"rightconflictfree r  (DT r' _) = ((r, r') \<notin> Priority \<and> (r, r') \<notin> Right)" |
"rightconflictfree _ _ = True"

fun conflictfree_root::"('a,'b) derivtree \<Rightarrow> bool" where
"conflictfree_root (DT r b) = ((\<forall> s \<in> set (leftspine1 (DT r b)) .  (leftconflictfree r s)) \<and>
      (\<forall>s \<in> set (rightspine1 (DT r b)) . (rightconflictfree r s)))"|
"conflictfree_root _ = True"
fun conflict_free::"('a, 'b) derivtree \<Rightarrow> bool" where
"conflict_free (DT r b) = (conflictfree_root (DT r b) \<and> list_all conflict_free b)"|
"conflict_free _ = True"

fun conflict_free'::"('a, 'b) derivtree \<Rightarrow> bool" where
"conflict_free' (DT r b) = (rightconflictfree r (last b) \<and> leftconflictfree r (hd b) \<and> list_all conflict_free' b)"|
"conflict_free' _ = True"
(*iteration function with predecessor tree and current subtree \<Rightarrow> helps proving that all derive the same*)

(*how to prove atomicity?*)
fun rotate_left_sub::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree\<Rightarrow> ('a, 'b) derivtree" where
"rotate_left_sub \<mu>E E\<gamma> E b= undefined"

(*lets define it if there exists a conflict on the root of this tree it rotates else unchanged*)
fun rotate_left::"('a, 'b) derivtree \<Rightarrow>  ('a, 'b) derivtree" where
"rotate_left T= undefined"
(*or how to do this?*)

lemma rotate_left_preserves:"(DeriveFromTree (rotate_left T)) = (DeriveFromTree T)"
  sorry

fun rotate_right::"('a, 'b) derivtree \<Rightarrow>  ('a, 'b) derivtree" where
"rotate_right T= undefined"
(*or how to do this?*)

lemma rotate_right_preserves:"(DeriveFromTree (rotate_right T)) = (DeriveFromTree T)"
  sorry

fun measure::"('a , 'b) derivtree \<Rightarrow> ('a, 'b) derivtree \<Rightarrow> bool" where
"measure T T1 = undefined"
(*rotate only reduces distance measure etc \<Longrightarrow> lexicographically or something*)
lemma rotate_monotonic:"measure T (rotate_right T)"
  sorry

lemma conflict_case:"rotate_left T = T \<Longrightarrow> is_conflict_free T"
  sorry
(*one atomic case of rotation \<Longrightarrow> for each node find conflict, else go through tree in preorder*)

(*what to do with multiple conflicts on same depth*)

fun rotatetree::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree option" where
"rotatetree T = undefined"

(*to prove termination, then for one \<Longrightarrow> safety of rotation and *)

(*main lemma, rotation doesn't change relative position to subtree (middle Tree*)
(*this probably can be used for the termination metric*)
(*termination because depth of potential conflicts only gets reduced?*)
function tree_order::"('a, 'b) derivtree \<Rightarrow> ('a, 'b) derivtree" where
"tree_order T = (case (rotatetree T) of None \<Rightarrow> T | (Some T') \<Rightarrow>tree_order T')"
  by auto
termination sorry

(*output of tree rotations is conflict free & valid tree*)
theorem tree_safety:"conflict_free (tree_order T)"
  sorry

(*alternative proof \<Longrightarrow> new conflicts being resolved won't reintroduce old ones

\<Longrightarrow> because it's now in the subtree of E (third tree not being relatively swapped*)
end
end