theory Mikes_attempt_1
imports Main HOL.List
begin
(*ensure hW,tW are not changed - not aux*)

datatype PCW =
  A1 | A2 | A3 | A4 | A5 | A6 | A7 | A8
| OK  | idleW | OOM | FinishedW

datatype PCR =
  R1
  | 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*)

(*Recorded variables*)
record rb_state =
  H :: nat
  T :: nat
  hW ::  nat               (*local copy of W*)
  tW ::  nat               (*local copy of W*)
  count :: nat
  countR :: nat
  temp :: nat         (*local copy of word by W*)
  tempR :: "nat\<times>nat"        (*local copy of word by R*)
  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"
  arrayW:: "nat  \<Rightarrow> nat"     (*returns a word arrayW_i*)
  arrayR:: "nat  \<Rightarrow> nat"     (*returns a word arrayR_i*)

definition "con_assms s \<equiv>   0 < N \<and> 0<n \<and> count (s)\<le>n \<and> countR (s)\<le>n
                            \<and> (\<forall>l. (l<n) \<longrightarrow>  (arrayW (s) l > 0) \<longrightarrow>  (arrayW (s) l < N)) "

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_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 update_countR :: "nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`countR := _" [200]) where
  "update_countR v\<equiv> \<lambda>s. s \<lparr> countR := 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 set_tempR :: "nat\<times>nat \<Rightarrow> rb_state \<Rightarrow> rb_state" ("`tempR := _" [200]) where
  "set_tempR v \<equiv> \<lambda>s. s \<lparr> tempR := 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 update_countR_def set_temp_def set_tempR_def
                        update_pcW_def update_pcR_def set_arrayR_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, OK}"
definition "EXT_PCW \<equiv> {OK, OOM, idleW, FinishedW}"
definition "ACQ_PCR \<equiv> {R1}"
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> (temp (rb s) = 0)
                        \<and> (tempR (rb s) = (0,0))
                        \<and> (hW (rb s) =0) \<and> (tW (rb s) =0)
                        \<and> (\<forall>l. (l<n) \<longrightarrow>  arrayR (rb s) l = 0)
                        \<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)\<and> (countR (rb s) = 0)"
(***********************************************************************)

definition "bounds_of_rb_state s \<equiv> (H (rb s) \<le> N) \<and> (T (rb s) \<le> 0)
                        \<and> (temp (rb s) \<le> N) \<and> (temp (rb s) \<ge> 0)
                        \<and> (len((tempR (rb s)))-off(tempR (rb s)) \<ge> 0) \<and> (len((tempR (rb s)))-off(tempR (rb s)) \<le> N)
                        \<and> (hW (rb s) \<le>N) \<and> (tW (rb s) \<le>N)
                        \<and> (hW (rb s) \<ge>0) \<and> (tW (rb s) \<ge>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> (`hW := (temp s)) \<circ> (`tW := 0) \<circ> (`pcW := OK )) s"
| "rbW_step A4 s = ((`H := ((hW s) + (temp s)))  \<circ> (`pcW := OK)) 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> (`hW := ((hW s) + (temp s))) \<circ> `pcW := OK) s"
| "rbW_step A7 s = ((`H := (temp s)) \<circ> (`hW := (temp s)) \<circ> `pcW := OK) 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 \<Rightarrow>  q s' = (append (q s) [(hW (rb s),hW (rb s)+temp (rb s))])
                \<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 s = (`T := (len (tempR s))
                        \<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' = (`tempR := q_hd) (rb s)
                                 \<and> rb s' = (`pcR := R1) (rb s))
                                 \<and> rb s' = (`countR := ((countR (rb s)) +1)) (rb s)
                                 \<and> rb s' = (`arrayR (countR (rb s)):= (len (tempR (rb s)) - off (tempR (rb s)))) (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  \<Rightarrow>  q s' = q s \<and> (rb s') = rbR_step R1 (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)"

(*The following describes what arrayR should look like wrt arrayW, and process ordering
using count and countR *)
definition "countR_count_relationship s \<equiv> countR s \<le> count s"

definition "arrayW_is_arrayR s \<equiv> (countR s)>0 \<longrightarrow>( \<forall>i.(i<countR s)\<longrightarrow> arrayW s i = arrayR s i)"

(*The following describes all possible combinations of items in q, which is to be preserved
if the ring buffer is to have the property of FIFO *)
definition "q_ith_is_from_arrayW s \<equiv> \<forall>i. i<(length (q s)) \<longrightarrow> (len((q s ! i) )-off((q s ! i)) = arrayW (rb s) (i+countR (rb s)) )"

definition "q_ith_follows_the_one_before s\<equiv> (length (q s)>1) \<longrightarrow> (\<forall>i.(i<(length (q s))-1) \<longrightarrow> (off(q s ! (i+1)) = len(q s ! i)) \<or>
                                  ((off(q s ! (i+1)) = 0) \<and> off(q s ! 0)>len(q s ! (i+1))))"

definition "only_one_zero_as_offset s \<equiv> (\<forall>i.(i<length(q s))\<longrightarrow>(\<forall>j.(j<length(q s)) \<longrightarrow> (j\<noteq>i) \<longrightarrow> (off(q s ! i) =0) \<longrightarrow> (off(q s ! j) \<noteq>0)))"

definition "all_q_entries_fit s \<equiv> (\<forall>i.(i<length(q s))\<longrightarrow>(off(q s ! i)<len(q s ! i))\<longrightarrow>(len(q s ! i)<N))"

definition "size_q_less_than_n s \<equiv> (length(q s)\<le>n)"

definition "tempR_is_first_in_q s \<equiv> tempR s\<noteq>(0,0) \<longrightarrow> countR s\<le>n \<longrightarrow> len(tempR s)-off(tempR s) = arrayW s ((countR s)-1)"

definition "if_q_has_ith_then_count s\<equiv> True"

definition "sizeq_wrt_counters s \<equiv> length(q s) = (count (rb s) - countR  (rb s))"

definition "sizeq_bounds s \<equiv> length(q s) \<ge>0 \<longrightarrow> length(q s)\<le>n"

definition "tempR_is_from_array s\<equiv> (countR s)>0 \<longrightarrow> ((len(tempR s)-off(tempR s)) = arrayW s ((countR s) -1))"

definition "H_always_equal_to_hW s \<equiv> H s=hW s"

definition "T_always_located_at s \<equiv> (T (rb s)=len(tempR (rb s))\<and>(pcR (rb s)=R1))\<or>(((T (rb s)=off(tempR (rb s)))\<or>((T (rb s) =0) \<and> q s=[]))\<and>(pcR (rb s)=idleR))"

definition "H_always_located_at_givenR1 s \<equiv> ((q s=[]\<and>pcR (rb s) =R1) \<longrightarrow> ((H (rb s) =len(tempR (rb s)))
                                                    \<or>(H (rb s) =temp (rb s)+len(tempR (rb s)))
                                                    \<or>(H (rb s) =temp (rb s))))\<and>

((q s\<noteq>[]\<and>pcR (rb s) =R1) \<longrightarrow> (((H (rb s) = len(q s ! (length(q s)-1)))\<and>(pcW (rb s)\<noteq>OK)) \<or>
                               ((H (rb s) = len(q s ! (length(q s)-1))+ temp(rb s))\<and>(pcW (rb s) =OK))))"

definition "H_always_located_at_givenidleR s \<equiv> (q s=[]\<and>pcR (rb s) =R1)\<longrightarrow> True"

lemmas inv_simps [simp] = H0_T0_def inv_def inRangeHT_def inRange_def inRangeht_def
                    cW_step_def cR_step_def init_def countR_count_relationship_def
                    arrayW_is_arrayR_def con_assms_def bounds_of_rb_state_def
                    q_ith_is_from_arrayW_def
                    q_ith_follows_the_one_before_def
                    only_one_zero_as_offset_def
                    all_q_entries_fit_def
                    size_q_less_than_n_def
                    tempR_is_first_in_q_def
                    sizeq_wrt_counters_def
                    sizeq_bounds_def
                    tempR_is_from_array_def
                    H_always_equal_to_hW_def
                    T_always_located_at_def

lemmas ACQ_EXT [simp] = ACQ_PCR_def ACQ_PCW_def EXT_PCW_def EXT_PCR_def

(*********************************************************)
                    (**New Attempt**)
(*********************************************************)

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 = (arrayW s (count s))) \<or> (pcW s = A1))
    \<and> (countR_count_relationship s \<and> (pcr\<in>{R1} \<longrightarrow> countR s\<noteq>count s))
    \<and> arrayW_is_arrayR s
    \<and> q_ith_is_from_arrayW c
    \<and> q_ith_follows_the_one_before c
    \<and> only_one_zero_as_offset c
    \<and> all_q_entries_fit c
    \<and> size_q_less_than_n c
    \<and> inRangeht s
    \<and> temp s \<le> N
    \<and> bounds_of_rb_state c
    \<and> tempR_is_first_in_q s
    \<and> size_of_q_is_sizeq c
    \<and> sizeq_wrt_counters s
    \<and> sizeq_bounds s
    \<and> tempR_is_from_array s
    \<and> H_always_equal_to_hW s
    \<and> T_always_located_at c
    \<and>
    (case pcw of
           A1     \<Rightarrow> arrayW s (count s) > 0 \<and> count s<n
         | A2     \<Rightarrow> count s<n
         | A3     \<Rightarrow> count s<n \<and> grd1 s
         | A4     \<Rightarrow> count s<n \<and> grd2 s \<and> \<not> grd1 s
         | A5     \<Rightarrow> count s<n \<and> grd3 s \<and> \<not> grd1 s \<and> \<not> grd2 s
         | A6     \<Rightarrow> count s<n \<and> grd4 s \<and> \<not> grd1 s \<and> \<not> grd2 s \<and> \<not> grd3 s
         | A7     \<Rightarrow> count s<n \<and> grd5 s \<and> \<not> grd1 s \<and> \<not> grd2 s \<and> \<not> grd3 s \<and> \<not> grd4 s
         | A8     \<Rightarrow> count s<n

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

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

lemmas new_inv [simp] = inv_def

lemma inv_init:
  assumes "con_assms (rb s)"
  and "init s"
  and "pcw = (pcW (rb s))"
  and "pcr = (pcR (rb s))"
  shows "inv pcw pcr s"
    using assms
    apply auto
    done

lemma R_doesnt_move_H2:
  assumes "con_assms (rb s)"
  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

lemma inv_local_W_int:
  assumes "con_assms (rb s)"
  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')"
shows "inv (pcW (rb s')) (pcR (rb s)) s'"
  using assms
  apply(auto)
  apply(case_tac[!] "pcW (rb s)", simp_all add:functs)
          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)
                      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 meson+
                      apply (meson less_imp_le)
                      apply (meson less_imp_le)
  apply (meson less_imp_le)
  apply (smt less_imp_le)
  apply (meson less_imp_le)
  apply (meson less_imp_le)
  apply (smt less_imp_le)
                      apply meson
                      apply(case_tac[!] "tW (rb s) < hW (rb s)", simp_all)
                      apply meson+
                      apply(simp_all add:Let_def)
                  apply(case_tac[!] "pcR (rb s')", simp_all)
                      apply meson+

  apply meson

  done

lemma inv_local_R_int2:
  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'"
  and "count(rb s)<n"
  and "countR (rb s)< count (rb s)"
  and "countR (rb s)>0"
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(case_tac[!] "n \<le> countR (rb s)", simp_all add:read_def functs)
                       apply (simp_all add: list.set_sel(2))
                       apply meson
   apply simp_all

  done

lemma inv_global_W_int2:
  assumes "con_assms"
  and "pcr = pcR (rb s)"
  and "pcw = pcW (rb s)"
  and "inv pcw pcr s"
  and "cR_step pcr s s'"
  and "count (rb s)\<le>n"
  and "countR (rb s)<count (rb s)"
shows "inv pcw (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)
  apply(cases "countR(rb s) =n", 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


subsection "Collecting Semantics Examples"

theory Collecting_Examples
imports Collecting Vars
begin

subsubsection "Pretty printing state sets"

text\<open>Tweak code generation to work with sets of non-equality types:\<close>
declare insert_code[code del] union_coset_filter[code del]
lemma insert_code [code]:  "insert x (set xs) = set (x#xs)"
by simp

text\<open>Compensate for the fact that sets may now have duplicates:\<close>
definition compact :: "'a set \<Rightarrow> 'a set" where
"compact X = X"

definition "vars_acom = compact o vars o strip"

text\<open>In order to display commands annotated with state sets, states must be
translated into a printable format as sets of variable-state pairs, for the
variables in the command:\<close>

definition show_acom :: "state set acom \<Rightarrow> (vname*val)set set acom" where
"show_acom C =
   annotate (\<lambda>p. (\<lambda>s. (\<lambda>x. (x, s x)) ` (vars_acom C)) ` anno C p) (strip C)"

subsubsection "Examples"

definition "c0 = WHILE Less (V ''x'') (N 3)
                DO ''x'' ::= Plus (V ''x'') (N 2)"

definition C0 :: "state set acom" where "C0 = annotate (\<lambda>p. {}) c0"

text\<open>Collecting semantics:\<close>

value "show_acom (((step {<>}) ^^ 0) C0)"
value "show_acom (((step {<>}) ^^ 1) C0)"
value "show_acom (((step {<>}) ^^ 2) C0)"
value "show_acom (((step {<>}) ^^ 3) C0)"
value "show_acom (((step {<>}) ^^ 4) C0)"
value "show_acom (((step {<>}) ^^ 5) C0)"
value "show_acom (((step {<>}) ^^ 6) C0)"
value "show_acom (((step {<>}) ^^ 7) C0)"
value "show_acom (((step {<>}) ^^ 8) C0)"

text\<open>Small-step semantics:\<close>
value "show_acom (((step {}) ^^ 0) (step {<>} C0))"
value "show_acom (((step {}) ^^ 1) (step {<>} C0))"
value "show_acom (((step {}) ^^ 2) (step {<>} C0))"
value "show_acom (((step {}) ^^ 3) (step {<>} C0))"
value "show_acom (((step {}) ^^ 4) (step {<>} C0))"
value "show_acom (((step {}) ^^ 5) (step {<>} C0))"
value "show_acom (((step {}) ^^ 6) (step {<>} C0))"
value "show_acom (((step {}) ^^ 7) (step {<>} C0))"
value "show_acom (((step {}) ^^ 8) (step {<>} C0))"

end


section \<open>Combining Turing machines\label{s:tm-combining}\<close>

theory Combinations
  imports Basics "HOL-Eisbach.Eisbach"
begin

text \<open>
This section describes how we can combine Turing machines in the way of
traditional control structures found in structured programming, namely
sequences, branching, and iterating. This allows us to build complex Turing
machines from simpler ones and analyze their behavior and running time.  Thanks
to some syntactic sugar the result may even look like a programming language,
but it is really more like a ``construction kit'' than a ``true'' programming
language with small and big step semantics or Hoare rules. Instead we will
merely have some lemmas for proving @{const transforms} statements for the
combined machines.

The remaining sections of this chapter will provide us with concrete Turing
machines to combine.
\<close>

subsection \<open>Relocated machines\<close>

text \<open>
If we use a Turing machine $M$ as part of another TM and there are $q$ commands
before $M$, then $M$'s target states will be off by $q$. This can be fixed by
adding $q$ to all target states of all commands in $M$, an operation we call
\emph{relocation}.
\<close>

definition relocate_cmd :: "nat \<Rightarrow> command \<Rightarrow> command" where
  "relocate_cmd q cmd rs \<equiv> (fst (cmd rs) + q, snd (cmd rs))"

lemma relocate_cmd_head: "relocate_cmd q cmd rs [~] j = cmd rs [~] j"
  using relocate_cmd_def by simp

lemma sem_relocate_cmd: "sem (relocate_cmd q cmd) cfg = (sem cmd cfg) <+=> q"
proof-
  let ?cmd' = "relocate_cmd q cmd"
  let ?rs = "read (snd cfg)"
  have "?cmd' ?rs = (fst (cmd ?rs) + q, snd (cmd ?rs))"
    by (simp add: relocate_cmd_def)
  then show ?thesis
    using sem by (metis (no_types, lifting) fst_conv snd_conv)
qed

definition relocate :: "nat \<Rightarrow> machine \<Rightarrow> machine" where
  "relocate q M \<equiv> map (relocate_cmd q) M"

lemma relocate:
  assumes "M' = relocate q M" and "i < length M"
  shows "(M' ! i) r = (fst ((M ! i) r) + q, snd ((M ! i) r))"
  using assms relocate_def relocate_cmd_def by simp

lemma sem_relocate:
  assumes "M' = relocate q M" and "i < length M"
  shows "sem (M' ! i) cfg = sem (M ! i) cfg <+=> q"
  using assms relocate_def sem_relocate_cmd by simp

lemma turing_command_relocate_cmd:
  assumes "turing_command k Q G cmd"
  shows "turing_command k (Q + q) G (relocate_cmd q cmd)"
  using assms relocate_cmd_def turing_commandD by auto

lemma turing_command_relocate:
  assumes "M' = relocate q M" and "turing_machine k G M" and "i < length M"
  shows "turing_command k (length M + q) G (M' ! i)"
proof
  fix gs :: "symbol list"
  assume gs: "length gs = k"
  have tc: "turing_command k (length M) G (M ! i)"
    using turing_machine_def assms(2,3) by simp
  show "length ([!!] (M' ! i) gs) = length gs"
    using gs turing_commandD(1)[OF tc] assms(1,3) relocate by simp
  show "(M' ! i) gs [.] 0 = gs ! 0" if "k > 0"
    using gs turing_commandD(3)[OF tc] assms(1,3) relocate that by simp
  show "[*] ((M' ! i) gs) \<le> length M + q"
    using gs turing_commandD(4)[OF tc] assms(1,3) relocate by simp
  show "(\<And>i. i < length gs \<Longrightarrow> gs ! i < G) \<Longrightarrow>
       j < length gs \<Longrightarrow> (M' ! i) gs [.] j < G" for j
    using gs turing_commandD(2)[OF tc] assms(1,3) relocate by simp
qed

lemma length_relocate: "length (relocate q M) = length M"
  by (simp add: relocate_def)

lemma relocate_jump_targets:
  assumes "turing_machine k G M"
    and "M' = relocate q M"
    and "i < length M"
    and "length rs = k"
  shows "fst ((M' ! i) rs) \<le> length M + q"
  using turing_machine_def relocate_def assms relocate
  by (metis turing_commandD(4) diff_add_inverse2 fst_conv le_diff_conv nth_mem)

lemma relocate_zero: "relocate 0 M = M"
  unfolding relocate_def relocate_cmd_def by simp

subsection \<open>Sequences\<close>

text \<open>
To execute two Turing machines sequentially we concatenate the two machines,
relocating the second one by the length of the first one. In this way the
halting state of the first machine becomes the start state of the second
machine.
\<close>

definition turing_machine_sequential :: "machine \<Rightarrow> machine \<Rightarrow> machine" (infixl ";;" 55) where
  "M1 ;; M2 \<equiv> M1 @ (relocate (length M1) M2)"

text \<open>
If the number of tapes and the alphabet size match, the concatenation of two
Turing machines is again a Turing machine.
\<close>

lemma turing_machine_sequential_turing_machine [intro, simp]:
  assumes "turing_machine k G M1" and "turing_machine k G M2"
  shows "turing_machine k G (M1 ;; M2)" (is "turing_machine k G ?M")
proof
  show 1: "k \<ge> 2"
    using assms(1) turing_machine_def by simp
  show 2: "G \<ge> 4"
    using assms(1) turing_machine_def by simp
  have len: "length ?M = length M1 + length M2"
    using relocate_def turing_machine_sequential_def by simp
  show 3: "turing_command k (length ?M) G (?M ! i)" if "i < length ?M" for i
  proof (cases "i < length M1")
    case True
    then show ?thesis
      using turing_machineD[OF assms(1)] turing_machine_sequential_def len turing_command_mono
      by (metis (no_types, lifting) le_add1 nth_append)
  next
    case False
    then have "i - (length M1) < length M2" (is "?i < length M2")
      using False that len by simp
    then have "turing_command k (length ?M) G ((relocate (length M1) M2) ! ?i)"
      using assms(2) turing_command_relocate len by (simp add: add.commute)
    moreover have "?M ! i = (relocate (length M1) M2) ! ?i"
      using False by (simp add: nth_append turing_machine_sequential_def)
    ultimately show ?thesis
      by simp
  qed
qed

lemma turing_machine_sequential_empty: "turing_machine_sequential [] M = M"
  unfolding turing_machine_sequential_def using relocate_zero by simp

lemma turing_machine_sequential_nth:
  assumes "M = M1 ;; M2" and "p < length M2"
  shows "M ! (p + length M1) = relocate_cmd (length M1) (M2 ! p)"
proof-
  let ?r = "relocate (length M1) M2"
  have "M = M1 @ ?r"
    using assms(1) turing_machine_sequential_def by simp
  then have "M ! (p + length M1) = ?r ! p"
    by (simp add: nth_append)
  then show ?thesis
    using assms(2) relocate_def by simp
qed

lemma turing_machine_sequential_nth':
  assumes "M = M1 ;; M2" and "length M1 \<le> q" and "q < length M"
  shows "M ! q = relocate_cmd (length M1) (M2 ! (q - length M1))"
  using assms turing_machine_sequential_nth length_relocate turing_machine_sequential_def
  by (metis (no_types, lifting) add.assoc diff_add length_append less_add_eq_less)

lemma "length_turing_machine_sequential":
  "length (turing_machine_sequential M1 M2) = length M1 + length M2"
  using turing_machine_sequential_def relocate_def by simp

lemma exe_relocate:
  "exe (M1 ;; M2) (cfg <+=> length M1) = (exe M2 cfg) <+=> length M1 "
  using sem_relocate_cmd sem_state_indep exe_def turing_machine_sequential_nth length_turing_machine_sequential
  by (smt (verit, ccfv_SIG) add.commute diff_add_inverse2 fst_conv le_add2 less_diff_conv2 snd_conv)

lemma execute_pre_append:
  assumes "halts M1 cfg" and "fst cfg = 0" and "t \<le> running_time M1 cfg "
  shows "execute ((M0 ;; M1) @ M2) (cfg <+=> length M0) t = (execute M1 cfg t) <+=> length M0"
  using assms(3)
proof (induction t)
  case 0
  then show ?case
    by simp
next
  case (Suc t)
  let ?l0 = "length M0"
  let ?M = "(M0 ;; M1) @ M2"
  let ?cfg_t = "execute ?M (cfg <+=> ?l0) t"
  let ?cfg1_t = "execute M1 cfg t"
  let ?cmd1 = "M1 ! (fst ?cfg1_t)"
  let ?cmd = "?M ! (fst ?cfg_t)"
  have *: "?cfg1_t <+=> ?l0 = ?cfg_t"
    using Suc by simp
  then have "fst (?cfg1_t <+=> ?l0) = fst ?cfg_t"
    by simp
  then have 2: "fst ?cfg1_t + ?l0 = fst ?cfg_t"
    by simp
  from * have sndeq: "snd ?cfg1_t = snd ?cfg_t"
    by (metis snd_conv)
  have "fst (execute M1 cfg t) \<le> length M1"
    using halts_impl_le_length assms(1) halts_def by blast
  moreover have "fst ?cfg1_t \<noteq> length M1"
    using Suc.prems running_time_def wellorder_Least_lemma(2) by fastforce
  ultimately have 1: "fst ?cfg1_t < length M1"
    by simp
  with 2 have "relocate_cmd ?l0 ?cmd1 = (M0 ;; M1) ! (fst ?cfg1_t + ?l0)"
    by (metis turing_machine_sequential_nth)
  then have "relocate_cmd ?l0 ?cmd1 = ?M ! (fst ?cfg1_t + ?l0)"
    by (simp add: "1" nth_append length_turing_machine_sequential)
  then have 3: "relocate_cmd ?l0 ?cmd1 = ?cmd"
    using 2 by simp
  with 1 have "execute M1 cfg (Suc t) = sem ?cmd1 ?cfg1_t"
    by (simp add: exe_def)
  then have "(execute M1 cfg (Suc t)) <+=> ?l0 = (sem ?cmd1 ?cfg1_t) <+=> ?l0"
    by simp
  then have "(execute M1 cfg (Suc t)) <+=> ?l0 = (sem (relocate_cmd ?l0 ?cmd1) ?cfg1_t)"
    using sem_relocate_cmd by simp
  then have rhs: "(execute M1 cfg (Suc t)) <+=> ?l0 = sem ?cmd ?cfg1_t"
    using 3 by simp
  have "execute ?M (cfg <+=> ?l0) (Suc t) = exe ?M ?cfg_t"
    by simp
  moreover have "fst ?cfg_t < length ?M"
    using 1 2 by (simp add: length_turing_machine_sequential)
  ultimately have lhs: "execute ?M (cfg <+=> ?l0) (Suc t) = sem ?cmd ?cfg_t"
    by (simp add: exe_lt_length)
  have "sem ?cmd ?cfg_t = sem ?cmd ?cfg1_t"
    using sem_state_indep sndeq by fastforce
  with lhs rhs show ?case
    by simp
qed

lemma transits_pre_append':
  assumes "transforms M1 tps t tps'"
  shows "transits ((M0 ;; M1) @ M2) (length M0, tps) t (length M0 + length M1, tps')"
proof-
  let ?rt = "running_time M1 (0, tps)"
  let ?M = "(M0 ;; M1) @ M2"
  have "?rt \<le> t"
    using assms transforms_running_time by simp
  have "fst (execute M1 (0, tps) t) = length M1"
    using assms(1) execute_after_halting_ge halting_config_def transforms_halting_config transforms_running_time
    by (metis (no_types, opaque_lifting) fst_conv)
  then have *: "halts M1 (0, tps)"
    using halts_def by auto
  have "transits M1 (0, tps) t (length M1, tps')"
    using assms(1) transits_def by (simp add: transforms_def)
  then have "execute M1 (0, tps) ?rt = (length M1, tps')"
    using assms(1) halting_config_def transforms_halting_config by auto
  moreover have "execute ?M (length M0, tps) ?rt = (execute M1 (0, tps) ?rt) <+=> length M0"
    using execute_pre_append * by auto
  ultimately have "execute ?M (length M0, tps) ?rt = (length M1, tps') <+=> length M0"
    by simp
  then have "execute ?M (length M0, tps) ?rt = (length M0 + length M1, tps')"
    by simp
  then show ?thesis
    using \<open>?rt \<le> t\<close> transits_def by blast
qed

corollary transits_prepend:
  assumes "transforms M1 tps t tps'"
  shows "transits (M0 ;; M1) (length M0, tps) t (length M0 + length M1, tps')"
  using transits_pre_append' assms by (metis append_Nil2)

corollary transits_append:
  assumes "transforms M1 tps t tps'"
  shows "transits (M1 @ M2) (0, tps) t (length M1, tps')"
  using transits_pre_append' turing_machine_sequential_empty assms
  by (metis gen_length_def length_code list.size(3))

corollary execute_append:
  assumes "fst cfg = 0" and "halts M1 cfg" and "t \<le> running_time M1 cfg"
  shows "execute (M1 @ M2) cfg t = execute M1 cfg t"
  using assms execute_pre_append turing_machine_sequential_empty
  by (metis add.right_neutral list.size(3) prod.collapse)

lemma execute_sequential:
  assumes "execute M1 cfg1 t1 = cfg1'"
    and "fst cfg1 = 0"
    and "t1 = running_time M1 cfg1"
    and "execute M2 cfg2 t2 = cfg2'"
    and "cfg1' = cfg2 <+=> length M1"
    and "halts M1 cfg1"
  shows "execute (M1 ;; M2) cfg1 (t1 + t2) = cfg2' <+=> length M1"
proof-
  let ?M = "M1 ;; M2"
  have 1: "execute ?M cfg1 t1 = cfg1'"
    using execute_append assms turing_machine_sequential_def by simp
  then have 2: "execute ?M cfg1 (t1 + t2) = execute ?M cfg1' t2"
    using execute_additive by simp
  have "execute M2 cfg2 t2 = cfg2' \<Longrightarrow> execute ?M cfg1' t2 = cfg2' <+=> length M1" for t2
  proof (induction t2 arbitrary: cfg2')
    case 0
    then show ?case
      using 1 assms(5) by simp
  next
    case (Suc t2)
    let ?cfg = "execute M2 cfg2 t2"
    have "execute ?M cfg1' (Suc t2) = exe ?M (execute ?M cfg1' t2)"
      by simp
    then have "execute ?M cfg1' (Suc t2) = exe ?M (?cfg <+=> length M1)"
      using Suc by simp
    moreover have "execute M2 cfg2 (Suc t2) = exe M2 ?cfg"
      by simp
    ultimately show ?case
      using exe_relocate Suc.prems by metis
  qed
  then show ?thesis
    using assms(4) 2 by simp
qed

text \<open>
The semantics and running time of the @{text ";;"} operator:
\<close>

lemma transforms_turing_machine_sequential:
  assumes "transforms M1 tps1 t1 tps2" and "transforms M2 tps2 t2 tps3"
  shows "transforms (M1 ;; M2) tps1 (t1 + t2) tps3"
proof-
  let ?M = "M1 ;; M2"
  let ?cfg1 = "(0, tps1)"
  let ?cfg1' = "(length M1, tps2)"
  let ?t1 = "running_time M1 ?cfg1"
  let ?cfg2 = "(0, tps2)"
  let ?cfg2' = "(length M2, tps3)"
  let ?t2 = "running_time M2 ?cfg2"
  have "fst (execute M1 ?cfg1 ?t1) = length M1"
    using assms(1) halting_config_def transforms_halting_config by (metis fst_conv)
  then have *: "halts M1 ?cfg1"
    using halts_def by auto
  have "execute M1 ?cfg1 ?t1 = ?cfg1'"
    using assms(1) halting_config_def transforms_halting_config by auto
  moreover have "fst ?cfg1 = 0"
    by simp
  moreover have "execute M2 ?cfg2 ?t2 = ?cfg2'"
    using assms(2) halting_config_def transforms_halting_config by auto
  moreover have "?cfg1' = ?cfg2 <+=> length M1"
    by simp
  ultimately have "execute ?M ?cfg1 (?t1 + ?t2) = ?cfg2' <+=> length M1"
    using execute_sequential * by blast
  then have "execute ?M ?cfg1 (?t1 + ?t2) = (length ?M, tps3)"
    by (simp add: length_turing_machine_sequential)
  then have "transits ?M ?cfg1 (?t1 + ?t2) (length ?M, tps3)"
    using transits_def by blast
  moreover have "?t1 + ?t2 \<le> t1 + t2"
    using add_le_mono assms(1,2) transforms_running_time by blast
  ultimately have "transits ?M ?cfg1 (t1 + t2) (length ?M, tps3)"
    using transits_monotone by simp
  then show ?thesis
    using transforms_def by simp
qed

corollary transforms_tm_sequentialI:
  assumes "transforms M1 tps1 t1 tps2" and "transforms M2 tps2 t2 tps3" and "t12 = t1 + t2"
  shows "transforms (M1 ;; M2) tps1 t12 tps3"
  using assms transforms_turing_machine_sequential by simp

subsection \<open>Branches\<close>

text \<open>
A branching Turing machine consists of a condition and two Turing machines, one
for each of the branches. The condition can be any predicate over the list of
symbols read from the tapes. The branching TM thus needs to perform conditional
jumps, for which we will have the following command:
\<close>

definition cmd_jump :: "(symbol list \<Rightarrow> bool) \<Rightarrow> state \<Rightarrow> state \<Rightarrow> command" where
  "cmd_jump cond q1 q2 rs \<equiv> (if cond rs then q1 else q2, map (\<lambda>r. (r, Stay)) rs)"

lemma turing_command_jump_1:
  assumes "q1 \<le> q2" and "k > 0"
  shows "turing_command k q2 G (cmd_jump cond q1 q2)"
  using assms cmd_jump_def turing_commandI by simp

lemma turing_command_jump_2:
  assumes "q2 \<le> q1" and "k > 0"
  shows "turing_command k q1 G (cmd_jump cond q1 q2)"
  using assms cmd_jump_def turing_commandI by simp

lemma sem_jump_snd: "snd (sem (cmd_jump cond q1 q2) cfg) = snd cfg"
proof-
  let ?k = "||cfg||"
  let ?cmd = "cmd_jump cond q1 q2"
  let ?cfg' = "sem ?cmd cfg"
  let ?rs = "read (snd cfg)"
  have 1: "proper_command ?k ?cmd"
    using cmd_jump_def by simp
  then have len: "||?cfg'|| = ||cfg||"
    using sem_num_tapes_raw by simp
  have "snd ?cfg' ! i = act (snd (?cmd ?rs) ! i) (snd cfg ! i)" if "i < ||cfg||" for i
    using sem_snd 1 that by simp
  moreover have "snd (?cmd ?rs) ! i = (?rs!i, Stay)" if "i < ||cfg||" for i
    using cmd_jump_def by (simp add: read_length that)
  ultimately have "snd ?cfg' ! i = act (?rs ! i, Stay) (snd cfg ! i)" if "i < ||cfg||" for i
    using that by simp
  then have "snd ?cfg' ! i = snd cfg ! i" if "i < ||cfg||" for i
    using that act_Stay by simp
  then show "snd ?cfg' = snd cfg"
    using len nth_equalityI by force
qed

lemma sem_jump_fst1:
  assumes "cond (read (snd cfg))"
  shows "fst (sem (cmd_jump cond q1 q2) cfg) = q1"
  using cmd_jump_def sem assms by simp

lemma sem_jump_fst2:
  assumes "\<not> cond (read (snd cfg))"
  shows "fst (sem (cmd_jump cond q1 q2) cfg) = q2"
  using cmd_jump_def sem assms by simp

lemma sem_jump:
  "sem (cmd_jump cond q1 q2) cfg = (if cond (config_read cfg) then q1 else q2, snd cfg)"
  using sem_def sem_jump_snd cmd_jump_def by simp

lemma transits_jump:
  "transits [cmd_jump cond q1 q2] (0, tps) 1 (if cond (read tps) then q1 else q2, tps)"
  using transits_def sem_jump exe_def by auto

definition turing_machine_branch :: "(symbol list \<Rightarrow> bool) \<Rightarrow> machine \<Rightarrow> machine \<Rightarrow> machine"
  ("IF _ THEN _ ELSE _ ENDIF" 60)
where
  "IF cond THEN M1 ELSE M2 ENDIF \<equiv>
    [cmd_jump cond 1 (length M1 + 2)] @
    (relocate 1 M1) @
    [cmd_jump (\<lambda>_. True) (length M1 + length M2 + 2) 0] @
    (relocate (length M1 + 2) M2)"

lemma turing_machine_branch_len:
  "length (IF cond THEN M1 ELSE M2 ENDIF) = length M1 + length M2 + 2"
  unfolding turing_machine_branch_def by (simp add: relocate_def)

text \<open>
If the Turing machines for both branches have the same number of tapes and
the same alphabet size, the branching machine is a Turing machine, too.
\<close>

lemma turing_machine_branch_turing_machine:
  assumes "turing_machine k G M1" and "turing_machine k G M2"
  shows "turing_machine k G (IF cond THEN M1 ELSE M2 ENDIF)"
    (is "turing_machine _ _ ?M")
proof
  show "k \<ge> 2"
    using assms(2) turing_machine_def by simp
  show "G \<ge> 4"
    using assms(2) turing_machine_def by simp
  let ?C1 = "[cmd_jump cond 1 (length M1 + 2)]"
  let ?C2 = "relocate 1 M1"
  let ?C3 = "[cmd_jump (\<lambda>_. True) (length M1 + length M2 + 2) 0]"
  let ?C4 = "relocate (length M1 + 2) M2"
  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
    using turing_machine_branch_def by simp
  have len: "length ?M = length M1 + length M2 + 2"
    using turing_machine_branch_len by simp
  have "k > 0"
    using `k \<ge> 2` by simp
  show "turing_command k (length ?M) G (?M ! i)" if "i < length ?M" for i
  proof -
    consider
        "i < length ?C1"
      | "length ?C1 \<le> i \<and> i < length (?C1 @ ?C2)"
      | "length (?C1 @ ?C2) \<le> i \<and> i < length (?C1 @ ?C2 @ ?C3)"
      | "length (?C1 @ ?C2 @ ?C3) \<le> i \<and> i < length ?M"
      using `i < length ?M` by linarith
    then show ?thesis
    proof (cases)
      case 1
      then have "turing_command k (length M1 + 2) G (?C1 ! i)"
        using turing_command_jump_1 `k > 0` by simp
      then have "turing_command k (length ?M) G (?C1 ! i)"
        using turing_command_mono len by simp
      then show ?thesis
        using parts 1 by simp
    next
      case 2
      then have "i - length ?C1 < length ?C2"
        by auto
      then have "turing_command k (length M1 + 1) G (?C2 ! (i - length ?C1))"
        using turing_command_relocate assms length_relocate by metis
      then have "turing_command k (length ?M) G (?C2 ! (i - length ?C1))"
        using turing_command_mono len by simp
      then have "turing_command k (length ?M) G ((?C1 @ ?C2) ! i)"
        using 2 by simp
      then show ?thesis
        using parts 2 by (metis (no_types, lifting) append.assoc nth_append)
    next
      case 3
      then have "turing_command k (length ?M) G (?C3 ! (i - length (?C1 @ ?C2)))"
        using turing_command_jump_2 len `k > 0` by simp
      then have "turing_command k (length ?M) G ((?C1 @ ?C2 @ ?C3) ! i)"
        using 3 by (metis (no_types, lifting) append.assoc diff_is_0_eq' less_numeral_extra(3) nth_append zero_less_diff)
      then show ?thesis
        using parts 3 by (smt (verit, best) append.assoc nth_append)
    next
      case 4
      then have "i - length (?C1 @ ?C2 @ ?C3) < length ?C4"
        by (simp add: len less_diff_conv2 length_relocate)
      then have "turing_command k (length ?M) G (?C4 ! (i - length (?C1 @ ?C2 @ ?C3)))"
        using turing_command_relocate assms by (smt (verit, ccfv_SIG) add.assoc add.commute len length_relocate)
      then show ?thesis
        using parts 4 by (metis (no_types, lifting) append.assoc le_simps(3) not_less_eq_eq nth_append)
    qed
  qed
qed

text \<open>
If the condition is true, the branching TM executes $M_1$ and requires two extra
steps: one for evaluating the condition and one for the unconditional jump to
the halting state.
\<close>

lemma transforms_branch_true:
  assumes "transforms M1 tps t tps'" and "cond (read tps)"
  shows "transforms (IF cond THEN M1 ELSE M2 ENDIF) tps (t + 2) tps'"
    (is "transforms ?M _ _ _")
proof-
  let ?C1 = "[cmd_jump cond 1 (length M1 + 2)]"
  let ?C2 = "relocate 1 M1"
  let ?C3 = "[cmd_jump (\<lambda>_. True) (length M1 + length M2 + 2) 0]"
  let ?C4 = "relocate (length M1 + 2) M2"
  let ?C34 = "?C3 @ ?C4"
  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
    using turing_machine_branch_def by simp
  then have "?M = ?C1 @ ?C2 @ ?C34"
    by simp
  moreover have "?C1 @ ?C2 = ?C1 ;; M1"
    using turing_machine_sequential_def by simp
  ultimately have parts2: "?M = (?C1 ;; M1) @ ?C34"
    by simp
  have "execute ?M (0, tps) 1 = exe ?M (0, tps)"
    by simp
  also have "... = sem (?M ! 0) (0, tps)"
    using exe_def by (simp add: turing_machine_branch_len)
  also have "... = sem (?C1 ! 0) (0, tps)"
    by (simp add: parts)
  also have "... = sem (cmd_jump cond 1 (length M1 + 2)) (0, tps)"
    by simp
  also have "... = (1, tps)"
    using sem_jump by (simp add: assms(2))
  finally have "execute ?M (0, tps) 1 = (1, tps)" .
  then have phase1: "transits ?M (0, tps) 1 (1, tps)"
    using transits_def by auto
  have "length ?C1 = 1"
    by simp
  moreover have "transits ((?C1 ;; M1) @ ?C34) (length ?C1, tps) t (length ?C1 + length M1, tps')"
    using transits_pre_append' assms by blast
  ultimately have "transits ?M (1, tps) t (1 + length M1, tps')"
    using parts2 by simp
  with phase1 have "transits ?M (0, tps) (t + 1) (1 + length M1, tps')"
    using transits_additive by fastforce
  then have phase2: "transits ?M (0, tps) (t + 1) (length (?C1 @ ?C2), tps')"
    by (simp add: relocate_def)
  let ?cfg = "(length (?C1 @ ?C2), tps')"
  have *: "?M ! (length (?C1 @ ?C2)) = ?C3 ! 0"
    using parts by simp
  then have "execute ?M ?cfg 1 = exe ?M ?cfg"
    by simp
  also have "... = sem (cmd_jump (\<lambda>_. True) (length M1 + length M2 + 2) 0) ?cfg"
    using exe_def relocate_def turing_machine_branch_len * by (simp add: Suc_le_lessD)
  also have "... = (length M1 + length M2 + 2, snd ?cfg)"
    using sem_jump by simp
  also have "... = (length ?M, tps')"
    by (simp add: turing_machine_branch_len)
  finally have "execute ?M ?cfg 1 = (length ?M, tps')" .
  then have "transits ?M ?cfg 1 (length ?M, tps')"
    using transits_def by auto
  with phase2 have "transits ?M (0, tps) (t + 2) (length ?M, tps')"
    using transits_additive by fastforce
  then show ?thesis
    by (simp add: transforms_def)
qed

text \<open>
If the condition is false, the branching TM executes $M_2$ and requires one
extra step to evaluate the condition.
\<close>

lemma transforms_branch_false:
  assumes "transforms M2 tps t tps'" and "\<not> cond (read tps)"
  shows "transforms (IF cond THEN M1 ELSE M2 ENDIF) tps (t + 1) tps'"
    (is "transforms ?M _ _ _")
proof-
  let ?C1 = "[cmd_jump cond 1 (length M1 + 2)]"
  let ?C2 = "relocate 1 M1"
  let ?C3 = "[cmd_jump (\<lambda>_. True) (length M1 + length M2 + 2) 0]"
  let ?C4 = "relocate (length M1 + 2) M2"
  let ?C123 = "?C1 @ ?C2 @ ?C3"
  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
    using turing_machine_branch_def by simp
  moreover have len123: "length ?C123 = length M1 + 2"
    by (simp add: length_relocate)
  ultimately have seq: "?M = ?C123 ;; M2"
    by (simp add: turing_machine_sequential_def)
  have "execute ?M (0, tps) 1 = exe ?M (0, tps)"
    by simp
  also have "... = sem (?M ! 0) (0, tps)"
    using exe_def by (simp add: turing_machine_branch_len)
  also have "... = sem (cmd_jump cond 1 (length M1 + 2)) (0, tps)"
    by (simp add: parts)
  also have "... = (length M1 + 2, tps)"
    using assms(2) sem_jump by simp
  also have "... = (length ?C123, tps)"
    using len123 by simp
  finally have "execute ?M (0, tps) 1 = (length ?C123, tps)" .
  then have phase1: "transits ?M (0, tps) 1 (length ?C123, tps)"
    using transits_def by blast
  have "?M ! (length ?C123) = ?C4 ! 0"
    by (simp add: nth_append parts length_relocate)
  have "transits (?C123 ;; M2) (length ?C123, tps) t (length ?C123 + length M2, tps')"
    using transits_prepend assms by blast
  then have "transits ?M (length ?C123, tps) t (length ?M, tps')"
    by (simp add: seq length_turing_machine_sequential)
  with phase1 have "transits ?M (0, tps) (t + 1) (length ?M, tps')"
    using transits_additive by fastforce
  then show ?thesis
    using transforms_def by simp
qed

text \<open>
The behavior and running time of the branching Turing machine:
\<close>

lemma transforms_branch_full:
  assumes "c \<Longrightarrow> transforms M1 tps tT tpsT"
    and "\<not> c \<Longrightarrow> transforms M2 tps tF tpsF"
    and "c \<Longrightarrow> tT + 2 \<le> t"
    and "\<not> c \<Longrightarrow> tF + 1 \<le> t"
    and "c = cond (read tps)"
    and "tps' = (if c then tpsT else tpsF)"
  shows "transforms (IF cond THEN M1 ELSE M2 ENDIF) tps t tps'"
proof -
  have "transforms (IF cond THEN M1 ELSE M2 ENDIF)
      tps
      (if c then tT + 2 else tF + 1)
      (if c then tpsT else tpsF)"
    using assms(1,2,5) transforms_branch_true transforms_branch_false by simp
  moreover have "(if c then tT + 2 else tF + 1) \<le> t"
    using assms(3,4) by simp
  ultimately show ?thesis
    using transforms_monotone assms(6) by presburger
qed

corollary transforms_branchI:
  assumes "cond (read tps) \<Longrightarrow> transforms M1 tps tT tpsT"
    and "\<not> cond (read tps) \<Longrightarrow> transforms M2 tps tF tpsF"
    and "cond (read tps) \<Longrightarrow> tT + 2 \<le> t"
    and "\<not> cond (read tps) \<Longrightarrow> tF + 1 \<le> t"
    and "cond (read tps) \<Longrightarrow> tps' = tpsT"
    and "\<not> cond (read tps) \<Longrightarrow> tps' = tpsF"
  shows "transforms (IF cond THEN M1 ELSE M2 ENDIF) tps t tps'"
  using transforms_branch_full assms by (smt (z3))

subsection \<open>Loops\<close>

text \<open>
The loops are while loops consisting of a head and a body. The body is a Turing
machine that is executed in every iteration as long as the condition in the
head of the loop evaluates to true. The condition is of the same form as in
branching TMs, namely a predicate over the symbols read from the tapes.
Sometimes this is not expressive enough, and so we allow a Turing machine as
part of the loop head that is run prior to evaluating the condition. In most
cases, however, this TM is empty.
\<close>

definition turing_machine_loop :: "machine \<Rightarrow> (symbol list \<Rightarrow> bool) \<Rightarrow> machine \<Rightarrow> machine"
  ("WHILE _ ; _ DO _ DONE" 60)
where
  "WHILE M1 ; cond DO M2 DONE \<equiv>
    M1 @
    [cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)] @
    (relocate (length M1 + 1) M2) @
    [cmd_jump (\<lambda>_. True) 0 0]"

text \<open>
Intuitively the Turing machine @{term "WHILE M1 ; cond DO M2 DONE"}
first executes @{term M1} and then checks the condition @{term cond}. If it is
true, it executes @{term M2} and jumps back to the start state; otherwise it
jumps to the halting state.
\<close>

lemma turing_machine_loop_len:
  "length (WHILE M1 ; cond DO M2 DONE) = length M1 + length M2 + 2"
  unfolding turing_machine_loop_def by (simp add: relocate_def)

text \<open>
If both Turing machines have the same number of tapes and alphabet size,
then so does the looping Turing machine.
\<close>

lemma turing_machine_loop_turing_machine:
  assumes "turing_machine k G M1" and "turing_machine k G M2"
  shows "turing_machine k G (WHILE M1 ; cond DO M2 DONE)"
    (is "turing_machine _ _ ?M")
proof
  show 1: "k \<ge> 2"
    using assms(1) turing_machine_def by simp
  show 2: "G \<ge> 4"
    using assms(1) turing_machine_def by simp
  let ?C1 = "M1"
  let ?C2 = "[cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)]"
  let ?C3 = "relocate (length M1 + 1) M2"
  let ?C4 = "[cmd_jump (\<lambda>_. True) 0 0]"
  let ?C34 = "?C3 @ ?C4"
  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
    using turing_machine_loop_def by simp
  have len: "length ?M = length M1 + length M2 + 2"
    using turing_machine_loop_len by simp
  have "k > 0"
    using `k \<ge> 2` by simp

  show "turing_command k (length ?M) G (?M ! i)" if "i < length ?M" for i
  proof -
    consider
        "i < length ?C1"
      | "length ?C1 \<le> i \<and> i < length (?C1 @ ?C2)"
      | "length (?C1 @ ?C2) \<le> i \<and> i < length (?C1 @ ?C2 @ ?C3)"
      | "length (?C1 @ ?C2 @ ?C3) \<le> i \<and> i < length ?M"
      using `i < length ?M` by linarith
    then show ?thesis
    proof (cases)
      case 1
      then have "turing_command k (length M1) G (?C1 ! i)"
        using turing_machineD(3) assms by simp
      then have "turing_command k (length ?M) G (?C1 ! i)"
        using turing_command_mono len by simp
      then show ?thesis
        using parts 1 by (simp add: nth_append)
    next
      case 2
      then have "turing_command k (length M1 + length M2 + 2) G (?C2 ! (i - length ?C1))"
        using turing_command_jump_1 `0 < k` by simp
      then have "turing_command k (length ?M) G (?C2 ! (i - length ?C1))"
        using len by simp
      then have "turing_command k (length ?M) G ((?C1 @ ?C2) ! i)"
        using "2" le_add_diff_inverse by (simp add: nth_append)
      then show ?thesis
        using 2 parts by (simp add: nth_append)
    next
      case 3
      then have "turing_command k (length M2 + (length M1 + 1)) G (?C3 ! (i - length (?C1 @ ?C2)))"
        using turing_command_relocate length_relocate assms(2)
        by (smt (verit, best) add.commute add.left_commute add_less_cancel_left le_add_diff_inverse length_append)
      then have "turing_command k (length ?M) G (?C3 ! (i - length (?C1 @ ?C2)))"
        using turing_command_mono len by simp
      then have "turing_command k (length ?M) G ((?C1 @ ?C2 @ ?C3) ! i)"
        using 3 by (simp add: nth_append)
      then show ?thesis
        using parts 3 by (smt (verit) append.assoc nth_append)
    next
      case 4
      then have "turing_command k 0 G (?C4 ! (i - length (?C1 @ ?C2 @ ?C3)))"
        using turing_command_jump_1 `0 < k` len length_relocate by simp
      then have "turing_command k (length ?M) G (?C4 ! (i - length (?C1 @ ?C2 @ ?C3)))"
        using turing_command_mono by blast
      then show ?thesis
        using parts 4 by (metis (no_types, lifting) append.assoc nth_append verit_comp_simplify1(3))
    qed
  qed
qed

lemma transits_turing_machine_loop_cond_false:
  assumes "transforms M1 tps t1 tps'" and "\<not> cond (read tps')"
  shows "transits
            (WHILE M1 ; cond DO M2 DONE)
            (0, tps)
            (t1 + 1)
            (length M1 + length M2 + 2, tps')"
    (is "transits ?M _ _ _")
proof-
  let ?C1 = "M1"
  let ?C2 = "[cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)]"
  let ?C3 = "relocate (length M1 + 1) M2"
  let ?C4 = "[cmd_jump (\<lambda>_. True) 0 0]"
  let ?C34 = "?C3 @ ?C4"
  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
    using turing_machine_loop_def by simp
  then have "?M = ?C1 @ (?C2 @ ?C3 @ ?C4)"
    by simp
  then have "transits ?M (0, tps) t1 (length ?C1, tps')"
    using assms transits_append by simp
  moreover have "transits ?M (length M1, tps') 1 (length M1 + length M2 + 2, tps')"
  proof-
    have *: "?M ! (length ?C1) = cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)"
      using turing_machine_loop_def by simp
    have "execute ?M (length ?C1, tps') 1 = exe ?M (length ?C1, tps')"
      by simp
    also have "... = sem (?M ! (length ?C1)) (length ?C1, tps')"
      by (simp add: exe_lt_length turing_machine_loop_len)
    also have "... = sem (cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)) (length ?C1, tps')"
      using * by simp
    also have "... = (length M1 + length M2 + 2, tps')"
      using sem_jump assms(2) by simp
    finally have "execute ?M (length ?C1, tps') 1 = (length M1 + length M2 + 2, tps')" .
    then show ?thesis
      using transits_def by auto
  qed
  ultimately show "transits ?M (0, tps) (t1 + 1) (length M1 + length M2 + 2, tps')"
    using transits_additive by blast
qed

lemma transits_turing_machine_loop_cond_true:
  assumes "transforms M1 tps t1 tps'"
    and "transforms M2 tps' t2 tps''"
    and "cond (read tps')"
  shows "transits
            (WHILE M1 ; cond DO M2 DONE)
            (0, tps)
            (t1 + t2 + 2)
            (0, tps'')"
    (is "transits ?M _ _ _")
proof-
  let ?C1 = "M1"
  let ?C2 = "[cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)]"
  let ?C3 = "relocate (length M1 + 1) M2"
  let ?C4 = "[cmd_jump (\<lambda>_. True) 0 0]"
  let ?C34 = "?C3 @ ?C4"
  have parts: "?M = ?C1 @ ?C2 @ ?C3 @ ?C4"
    using turing_machine_loop_def by simp
  then have "?M = ?C1 @ (?C2 @ ?C3 @ ?C4)"
    by simp
  then have "transits ?M (0, tps) t1 (length ?C1, tps')"
    using assms(1,3) transits_append by simp
  moreover have "transits ?M (length ?C1, tps') 1 (length ?C1 + 1, tps')"
  proof-
    have *: "?M ! (length ?C1) = cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)"
      using turing_machine_loop_def by simp
    have "execute ?M (length ?C1, tps') 1 = exe ?M (length ?C1, tps')"
      by simp
    also have "... = sem (?M ! (length ?C1)) (length ?C1, tps')"
      by (simp add: exe_lt_length turing_machine_loop_len)
    also have "... = sem (cmd_jump cond (length M1 + 1) (length M1 + length M2 + 2)) (length ?C1, tps')"
      using * by simp
    also have "... = (length M1 + 1, tps')"
      using sem_jump assms(3) by simp
    finally have "execute ?M (length ?C1, tps') 1 = (length M1 + 1, tps')" .
    then show ?thesis
      using transits_def by auto
  qed
  ultimately have "transits ?M (0, tps) (t1 + 1) (length M1 + 1, tps')"
    using transits_additive by blast
  moreover have "transits ?M (length M1 + 1, tps') t2 (length M1 + length M2 + 1, tps'')"
  proof-
    have "?M = ((?C1 @ ?C2) ;; M2) @ ?C4"
      by (simp add: parts turing_machine_sequential_def)
    moreover have "length (?C1 @ ?C2) = length M1 + 1"
      by simp
    ultimately have "transits ?M (length M1 + 1, tps') t2 (length M1 + 1 + length M2, tps'')"
      using assms transits_pre_append' by metis
    then show ?thesis
      by simp
  qed
  ultimately have "transits ?M (0, tps) (t1 + t2 + 1) (length M1 + length M2 + 1, tps'')"
    using transits_additive by fastforce
  moreover have "transits ?M (length M1 + length M2 + 1, tps'') 1 (0, tps'')"
  proof-
    have *: "?M ! (length M1 + length M2 + 1) = cmd_jump (\<lambda>_. True) 0 0"
      by (simp add: nth_append parts length_relocate)
    have "execute ?M (length M1 + length M2 + 1, tps'') 1 = exe ?M (length M1 + length M2 + 1, tps'')"
      by simp
    also have "... = sem (?M ! (length M1 + length M2 + 1)) (length M1 + length M2 + 1, tps'')"
      by (simp add: exe_lt_length turing_machine_loop_len)
    also have "... = sem (cmd_jump (\<lambda>_. True) 0 0) (length M1 + length M2 + 1, tps'')"
      using * by simp
    also have "... = (0, tps'')"
      using sem_jump by simp
    finally have "execute ?M (length M1 + length M2 + 1, tps'') 1 = (0, tps'')" .
    then show ?thesis
      using transits_def by auto
  qed
  ultimately show "transits ?M (0, tps) (t1 + t2 + 2) (0, tps'')"
    using transits_additive by fastforce
qed

text \<open>
In this article we will only encounter while loops that are in fact for loops,
that is, where the number of iterations is known beforehand. Moreover, using the
same time bound for every iteration will lead to a good enough upper bound for
the entire loop.

The @{const transforms} rule for a loop with $m$ iterations where the running
time of both TMs is bounded by a constant:
\<close>

lemma transforms_loop_for:
  fixes m t1 t2 :: nat
    and M1 M2 :: machine
    and tps :: "nat \<Rightarrow> tape list"
    and tps' :: "nat \<Rightarrow> tape list"
  assumes "\<And>i. i \<le> m \<Longrightarrow> transforms M1 (tps i) t1 (tps' i)"
  assumes "\<And>i. i < m \<Longrightarrow> transforms M2 (tps' i) t2 (tps (Suc i))"
    and "\<And>i. i < m \<Longrightarrow> cond (read (tps' i))"
    and "\<not> cond (read (tps' m))"
  assumes "ttt \<ge> m * (t1 + t2 + 2) + t1 + 1"
  shows "transforms
            (WHILE M1 ; cond DO M2 DONE)
            (tps 0)
            ttt
            (tps' m)"
proof -
  define M where "M = WHILE M1 ; cond DO M2 DONE"
  define t where "t = t1 + t2 + 2"
  have "transits M (0, tps 0) (i * t) (0, tps i)" if "i \<le> m" for i
    using that
  proof (induction i)
    case 0
    then show ?case
      using transits_def by simp
  next
    case (Suc i)
    then have "i < m"
      by simp
    then have "transits M (0, tps i) t (0, tps (Suc i))"
      using M_def t_def assms transits_turing_machine_loop_cond_true by (metis le_eq_less_or_eq)
    moreover have "transits M (0, tps 0) (i * t) (0, tps i)"
      using Suc by simp
    ultimately have "transits M (0, tps 0) (i * t + t) (0, tps (Suc i))"
      using transits_additive by simp
    then show ?case
      by (metis add.commute mult_Suc)
  qed
  then have "transits M (0, tps 0) (m * t) (0, tps m)"
    by simp
  moreover have "transits M (0, tps m) (t1 + 1) (length M1 + length M2 + 2, tps' m)"
    using assms(1,4) transits_turing_machine_loop_cond_false M_def by simp
  ultimately have "transits M (0, tps 0) (m * t + t1 + 1) (length M1 + length M2 + 2, tps' m)"
    using transits_additive by fastforce
  then show ?thesis
    using transforms_def turing_machine_loop_len M_def assms(5) t_def transits_monotone
    by auto
qed

text \<open>
The rule becomes even simpler in the common case in which the Turing machine in
the loop head is empty.
\<close>

lemma transforms_loop_simple:
  fixes m t :: nat
    and M :: machine
    and tps :: "nat \<Rightarrow> tape list"
  assumes "\<And>i. i < m \<Longrightarrow> transforms M (tps i) t (tps (Suc i))"
    and "\<And>i. i < m \<Longrightarrow> cond (read (tps i))"
    and "\<not> cond (read (tps m))"
  assumes "ttt \<ge> m * (t + 2) + 1"
  shows "transforms
            (WHILE [] ; cond DO M DONE)
            (tps 0)
            ttt
            (tps m)"
  using transforms_loop_for[where ?tps'=tps and ?cond=cond and ?t1.0=0, OF _ assms(1) _ assms(3)]
    transforms_Nil assms(2,4)
  by simp

subsection \<open>A proof method\<close>

text \<open>
Statements about the behavior and running time of Turing machines, expressed via
the predicate @{const transforms}, are the most common ones we are going to
prove. The following proof method applies introduction rules for this
predicate. These rules are either the ones we proved for the control structures
(sequence, branching, loop) or the ones describing the semantics of concrete
Turing machines. The rules of the second kind are collected in the attribute
@{text transforms_intros}.

Applying such a rule usually leaves three kinds of goals: some simple ones
requiring only instantiation of schematic variables; one for the equality of two
tape lists; and one for the time bound. For the last two goals the proof method
offers parameters @{term tps} and @{term time}, respectively.

I have to admit that most of the details of the proof method were determined by
trial and error.

\null
\<close>

named_theorems transforms_intros
declare transforms_Nil [transforms_intros]

method tform uses tps time declares transforms_intros =
  (
   ((rule transforms_tm_sequentialI)+
    | rule transforms_branchI
    | rule transforms_loop_simple
    | rule transforms_loop_for
    | rule transforms_intros)
   ; (rule transforms_intros)?
   ; (simp only:; fail)?
   ; ((use tps in simp; fail) | (use time in simp; fail))?
   ; (match conclusion in "left = right" for left right :: "tape list"
        \<Rightarrow> \<open>(fastforce simp add: tps list_update_swap; fail)\<close>)?
   ; (match conclusion in "left = right" for left right :: nat
        \<Rightarrow> \<open>(use time in simp; fail)?\<close>)?
  )

text \<open>
These lemmas are sometimes helpful for proving the equality of tape lists:
\<close>

lemma list_update_swap_less: "i' < i \<Longrightarrow> ys[i := x, i' := x'] = ys[i' := x', i := x]"
  by (simp add: list_update_swap)

lemma nth_list_update_neq': "j \<noteq> i \<Longrightarrow> xs[i := x] ! j = xs ! j"
  by simp

end


theory IICF_Rbt_Set
  imports "Imperative_HOL_Time.IHT_Red_Black_Tree"
      "../Intf/IICF_Set"  "NREST.RefineMonadicVCG" "NREST.NREST"
begin

hide_const R B
subsection "library for some set implementation"
subsubsection "interface"

term rbt_map_assn
thm rbt_search rbt_insert_rule

definition Z :: "(('a, unit) Mapping_Str.map \<times> 'a set) set"
  where "Z = {(c,a)|c a. keys_of c = a}"

subsubsection "empty set init via rbtree"

definition set_init_t :: "nat" where "set_init_t = 1"

definition set_init_SPEC :: "nat set nrest" where
  "set_init_SPEC \<equiv> SPECT [{} \<mapsto> set_init_t ]"

definition rbt_map_assn' where "rbt_map_assn' a c =
        (\<exists>\<^sub>AM. rbt_map_assn M c * \<up>((M,a)\<in>Z))"

definition rbt_set_assn :: "_ set \<Rightarrow> (_, unit) rbt_node ref option \<Rightarrow> assn"  where [rewrite_ent]:
  "rbt_set_assn S p =
        (\<exists>\<^sub>AM. rbt_map_assn M p * \<up>(S = keys_of M))"

definition [rewrite]: "rbt_set_insert k b = rbt_insert k () b"

lemma g[rewrite]: "card (keys_of M) + 1 = sizeM1 M"
     by (auto simp: sizeM1_def)

definition rbt_pick where   "rbt_pick p = do {(case p of
     None \<Rightarrow> return None |
     Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     return (Some (key t))
   }) }"

lemma rbt_pick_rule [hoare_triple]:
  "<btree t p *$2>
   rbt_pick  p
   <\<lambda>r. btree t p * \<up>( (t = Leaf \<longrightarrow> r = None) \<and> (t\<noteq>Leaf \<longrightarrow> the r \<in> rbt_set t) )>\<^sub>t"
@proof @case "t = Leaf"  @qed

definition  rbt_map_pick where    "rbt_map_pick p = rbt_pick p"

lemma rbt_map_Leaf: "rbt_map (Leaf) = empty_map"
  by (simp add: rbt_map_def)

lemma neq_ext: "(\<exists>x. f x \<noteq>  g x ) \<Longrightarrow> f \<noteq> g" by auto

lemma meval_ext_neg: " M\<langle>x\<rangle> \<noteq> N\<langle>x\<rangle> \<Longrightarrow> M \<noteq> N"
  apply (cases M) apply (cases N) by auto

lemma rbt_map_Leaf_conv: "M = rbt_map t \<Longrightarrow> (t = Leaf) = (M = empty_map)"
  apply(cases t) apply (simp_all add: rbt_map_def empty_map_def)
  subgoal for c l k v r apply(rule meval_ext_neg[where x=k])
    apply(simp only:  meval.simps)
    apply(simp only: map_of_alist_nil'[symmetric]) by simp
  done

lemma empty_rbt_map_is_Leaf: "rbt_map t = empty_map \<Longrightarrow> t = Leaf"
  by(simp add: rbt_map_Leaf_conv)

lemma rbt_map_Leaf_is_empty_map: "rbt_map Leaf = empty_map "
  by(simp add: rbt_map_def)

lemma dd: "M= rbt_map t \<Longrightarrow> t = Leaf \<Longrightarrow> M = empty_map"
  by(simp add: rbt_map_def)

declare rbt_set_keys_of [forward]

lemma rbt_map_pick_rule [hoare_triple]:
  "<rbt_map_assn M p * $ 2>
   rbt_map_pick  p
   <\<lambda>r. rbt_map_assn M p * \<up>( (M = empty_map \<longrightarrow> r = None) \<and> (M\<noteq>empty_map \<longrightarrow> the r \<in> keys_of M))>\<^sub>t"
  by auto2

thm tree_is_empty_rule
declare tree_is_empty_rule [hoare_triple]

definition "rbt_map_isempty b = tree_is_empty b"

lemma rbt_map_isempty_rule[hoare_triple]: "<rbt_map_assn M b * $1> rbt_map_isempty b <\<lambda>r. rbt_map_assn M b * \<up> (r \<longleftrightarrow> (M = empty_map))>\<^sub>t"
  by auto2

setup \<open>fold del_prfstep_thm @{thms rbt_map_assn_def}\<close>

definition  rbt_set_pick where    "rbt_set_pick p = do {
        s \<leftarrow> rbt_map_pick p;
        return (the s) }"

theorem rbt_set_pick_rule [hoare_triple]:
  "S\<noteq>{} \<Longrightarrow> <rbt_set_assn S b * $4> rbt_set_pick b <\<lambda>r. rbt_set_assn S b * \<up>(r \<in> S)>\<^sub>t"
  by auto2

definition  rbt_set_isempty where    "rbt_set_isempty p =rbt_map_isempty p"

lemma rbt_set_isempty_rule: "<rbt_set_assn S b * $1> rbt_set_isempty b <\<lambda>r. rbt_set_assn S b * \<up> (r \<longleftrightarrow> (S = {}))>\<^sub>t"
  by auto2

declare [[print_trace]]
thm rbt_insert_rule rbt_insert_rule'
theorem rbt_insert_rule_abs [hoare_triple]:
  "<rbt_set_assn S p * $(rbt_insert_logN (card S + 1))> rbt_set_insert x p <rbt_set_assn (insert x S)>\<^sub>t"
  by auto2

lemma a[rewrite]: "S = keys_of M \<Longrightarrow> M\<langle>x\<rangle> = Some () \<longleftrightarrow> x \<in> S"
  by (simp add: keys_of_iff)

definition [rewrite]: "rbt_set_delete b k = rbt_delete k  b"

theorem rbt_delete_rule_abs [hoare_triple]:
  "<rbt_set_assn S p * $(rbt_delete_time_logN (card S + 1))> rbt_set_delete p x <rbt_set_assn (S -  {x})>\<^sub>t"
  by auto2

thm rbt_delete_rule

(*
theorem rbt_search_abs [hoare_triple]:
  "<rbt_set_assn S b * $(rbt_search_time_logN (card S + 1))> rbt_search x b <\<lambda>r. rbt_set_assn S b * \<up>(r = Some () \<longleftrightarrow> x \<in> S)>\<^sub>t"
  by auto2
*)

definition rbt_mem :: "'a::{heap,linorder} \<Rightarrow> ('a, unit) rbt_node ref option \<Rightarrow> bool Heap" where [rewrite]:
  "rbt_mem x p = do {
      f \<leftarrow> rbt_search x p;
      return (f = Some ()) }"

theorem rbt_mem_rule [hoare_triple]:
  "<rbt_set_assn S b * $(rbt_search_time_logN (card S + 1) + 1)> rbt_mem x b <\<lambda>r. rbt_set_assn S b * \<up>(r = (x \<in> S))>\<^sub>t"
  by auto2

definition paint :: "color \<Rightarrow> ('a::heap, 'b::heap) btree \<Rightarrow> unit Heap" where
  "paint c p = (case p of
    None \<Rightarrow> return ()
  | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     pp := Node (lsub t) c (key t) (val t) (rsub t)
   })"

lemma paint_rule [hoare_triple]:
  "<btree t p *$2>
   paint c p
   <\<lambda>_. btree (RBTree.paint c t) p>\<^sub>t"
@proof @case "t = Leaf" @qed

definition "set_empty = tree_empty"

theorem set_empty_rule [hoare_triple]:
  "<$1> set_empty <rbt_set_assn {}>" by auto2

lemma keys_of_empty_Map_empty: "{} = keys_of M \<longleftrightarrow> M=Map Map.empty"
  by(auto simp: keys_of_def meval_ext )

lemma inst_ex_assn: "A \<Longrightarrow>\<^sub>A B x \<Longrightarrow> A \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. B x)"
  using entails_ex_post by blast

lemma norm_ex_assn: "A \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. B x * C)  \<Longrightarrow> A \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. B x) * C"
  by (simp)

lemma fl': "(b \<Longrightarrow> A \<Longrightarrow>\<^sub>A B) \<Longrightarrow>  \<up>b *  A  \<Longrightarrow>\<^sub>A B"
  by (simp add: assn_times_comm entails_def)

lemma fl: "A \<Longrightarrow>\<^sub>A B \<Longrightarrow> b \<Longrightarrow> A \<Longrightarrow>\<^sub>A B * \<up>b"
  using entails_pure_post by blast
lemma fl_: "A \<Longrightarrow>\<^sub>A B \<Longrightarrow> b \<Longrightarrow> A \<Longrightarrow>\<^sub>A \<up>b * B "
  using fl assn_times_comm  by simp

lemma set_init_hnr'_short:
  "hn_refine (emp) set_empty emp rbt_set_assn (set_init_SPEC)"
  unfolding set_init_SPEC_def
  apply (rule extract_cost_otherway[OF _ set_empty_rule, where Cost_lb=1 and F=emp])
  apply simp
  subgoal
    apply(rule ent_true_drop(2))
    by (auto intro!: inst_ex_assn fl entails_triv simp:   rbt_map_assn'_def )
   by (auto intro: entails_triv simp: set_init_t_def)

lemma set_init_hnr':
  "hn_refine (emp) tree_empty emp rbt_map_assn' (set_init_SPEC)"
proof -
  from rbt_empty_rule[unfolded hoare_triple_def]
  have A: "\<And>h as \<sigma> r n t.
     pHeap h as n \<Turnstile> $ 1 \<Longrightarrow>
     run tree_empty (Some h) \<sigma> r t \<Longrightarrow>
     \<sigma> \<noteq> None \<and>
     pHeap (the \<sigma>) (new_addrs h as (the \<sigma>)) (n - t) \<Turnstile> rbt_map_assn empty_map r \<and>
     t \<le> n \<and> relH {a. a < heap.lim h \<and> a \<notin> as} h (the \<sigma>) \<and> heap.lim h \<le> heap.lim (the \<sigma>)" by blast

  thm entailsD

  show ?thesis unfolding hn_refine_def  set_init_SPEC_def set_init_t_def rbt_map_assn'_def
    apply auto
  proof (goal_cases)
    case (1 h as n)
    then have "pHeap h as (n + 1) \<Turnstile> emp * $ 1"
      using diff_add_inverse2 le_add2 mod_timeCredit_dest by presburger
    then have ph: "pHeap h as (n + 1) \<Turnstile> $ 1" by simp

    note A[OF ph] run_and_execute
    have
      "(\<exists>h' t r. execute tree_empty h = Some (r, h', t) \<and> (pHeap h' (new_addrs h as h') (n + 1 - t) \<Turnstile> rbt_map_assn empty_map r \<and>
    t \<le> n + 1 \<and> relH {a. a < heap.lim h \<and> a \<notin> as} h h' \<and> heap.lim h \<le> heap.lim h'))" apply(simp only: run_and_execute[symmetric])
      using  A[OF ph]  by blast
    then obtain h' t and r:: "(nat, unit) rbt_node ref option" where
        heap: "pHeap h' (new_addrs h as h') (n + 1 - t) \<Turnstile> rbt_map_assn empty_map r"
     and   "execute tree_empty h = Some (r, h', t)"
                "t \<le> n + 1" " relH {a. a < heap.lim h \<and> a \<notin> as} h h'" "heap.lim h \<le> heap.lim h'" by blast
    from heap have heap': "pHeap h' (new_addrs h as h') (Suc n - t) \<Turnstile> rbt_map_assn empty_map r" by simp
    show ?case apply(rule exI[where x=h'])  apply(rule exI[where x=t])   apply(rule exI[where x=r])
      apply safe
      apply fact
        apply (rule exI[where x=1]) apply safe apply simp apply fact
      subgoal apply(auto simp: keys_of_empty_Map_empty empty_map_def Z_def) apply(rule entailsD[OF _ heap'])
        unfolding empty_map_def
        by (smt entails_def entails_ex_post entails_frame'' entails_true match_rest one_assn_rule pure_assn_rule)
      apply fact
      apply fact
      done
  qed
qed

subsubsection "set insertion via rbtree"

definition set_ins_t :: "nat\<Rightarrow>nat" where "set_ins_t n = rbt_insert_logN (n+1)"

definition set_ins_SPEC where
  "set_ins_SPEC x S \<equiv> SPECT [insert x S \<mapsto> set_ins_t (card S)]"

lemma ent_ex: "(\<And>x. P x \<Longrightarrow>\<^sub>A Q) \<Longrightarrow> (\<exists>\<^sub>Ax. P x) \<Longrightarrow>\<^sub>A Q"
  by (meson entails_ex)

lemma isolate_first: "\<And>A B C. \<Gamma> \<Longrightarrow>\<^sub>A \<Gamma>' \<Longrightarrow> A \<Longrightarrow>\<^sub>A B \<Longrightarrow> \<Gamma> * A \<Longrightarrow>\<^sub>A \<Gamma>' * B"
  by (simp add: ent_star_mono)

lemma inZ_conv: "(M, S) \<in> Z \<longleftrightarrow> (S = keys_of M)" unfolding Z_def by auto

lemma set_ins_hnr_abs:
  "hn_refine (rbt_set_assn S p * hn_val Id x x') (rbt_set_insert x' p) (hn_val Id x x') rbt_set_assn (set_ins_SPEC x S)"
  unfolding set_ins_SPEC_def
  apply (rule extract_cost_otherway[OF _  rbt_insert_rule_abs ])
    apply (sep_auto)
   apply (sep_auto simp: hn_ctxt_def pure_def)
  apply(auto simp: set_ins_t_def)
  done

subsubsection "set membership via rbtree"

fun set_mem_t :: "nat\<Rightarrow>nat" where "set_mem_t n = rbt_search_time_logN (n + 1)"

definition set_mem_SPEC :: "'a \<Rightarrow> 'a set \<Rightarrow> bool nrest" where
  "set_mem_SPEC x S \<equiv> SPECT [ (x \<in> S) \<mapsto> set_mem_t (card S)]"

definition Y :: "(unit option \<times> bool) set" where
    "Y = {(c,a)|c a. c = Some () \<longleftrightarrow> a}"

definition Y' :: "bool \<Rightarrow> unit option \<Rightarrow> assn" where
  "Y' b v = \<up>(  v = Some () \<longleftrightarrow> b )"

(* theorems that should be visible from the outside *)

(* init *)
thm set_init_hnr'_short set_init_SPEC_def

(* insert *)
thm set_ins_hnr_abs set_ins_SPEC_def

(* membership test *)
(* thm set_mem_hnr_abs set_mem_SPEC_def *)

subsubsection "implement the interface"

context
  notes [intro!] = hfrefb_to_hoare_triple
  notes [simp] = pure_def hn_ctxt_def invalid_assn_def uncurry_t_def
                noparam_t_def oneparam_t_def
begin

  lemma mop_set_empty_rule_aux:
  "(uncurry0 set_empty, noparam_t mop_set_empty) \<in> [\<lambda>_. True, \<lambda>_. 1]\<^sub>b unit_assn\<^sup>k \<rightarrow> rbt_set_assn"
    by(sep_auto heap: set_empty_rule simp: mop_set_empty_def)

  lemmas mop_set_empty_rule[sepref_fr_rules] = mop_set_empty_rule_aux[hfb_to_hnr]

  lemma mop_set_insert_rule_aux: "(uncurry rbt_set_insert, uncurry_t mop_set_insert)
       \<in> [\<lambda>_. True, \<lambda>(_, S). rbt_insert_logN (card S + 1)]\<^sub>b (id_assn\<^sup>k *\<^sub>a rbt_set_assn\<^sup>d) \<rightarrow> rbt_set_assn"
    by (sep_auto heap: rbt_insert_rule_abs simp: mop_set_insert_def)

  lemmas mop_set_insert_rule[sepref_fr_rules] = mop_set_insert_rule_aux[hfb_to_hnr]

  lemma mop_set_delete_rule_aux: "(uncurry rbt_set_delete, uncurry_t mop_set_del)
       \<in> [\<lambda>_. True, \<lambda>(S,_). rbt_delete_time_logN (card S + 1)]\<^sub>b (rbt_set_assn\<^sup>d *\<^sub>a id_assn\<^sup>k) \<rightarrow> rbt_set_assn"
    by (sep_auto heap: rbt_delete_rule_abs simp: mop_set_del_def)

  lemmas mop_set_delete_rule[sepref_fr_rules] = mop_set_delete_rule_aux[hfb_to_hnr]

  lemma mop_set_member_rule_aux: "(uncurry rbt_mem, uncurry_t mop_set_member)
       \<in> [\<lambda>_. True, \<lambda>(_, S). rbt_search_time_logN (card S + 1) + 1]\<^sub>b (id_assn\<^sup>k *\<^sub>a rbt_set_assn\<^sup>k) \<rightarrow> bool_assn"
    by (sep_auto heap: rbt_mem_rule simp: mop_set_member_def)

  lemmas mop_set_member_rule[sepref_fr_rules] = mop_set_member_rule_aux[hfb_to_hnr]

  lemma mop_set_isempty_rule_aux: "(rbt_set_isempty, oneparam_t mop_set_isempty)
       \<in> [\<lambda>_. True, \<lambda>_. 1]\<^sub>b rbt_set_assn\<^sup>k \<rightarrow> bool_assn"
    by (sep_auto heap: rbt_set_isempty_rule simp: mop_set_isempty_def)

  lemmas mop_set_isempty_rule[sepref_fr_rules] = mop_set_isempty_rule_aux[hfb_to_hnr]

  lemma mop_set_pick_rule_aux: "(rbt_set_pick, oneparam_t mop_set_pick)
       \<in> [\<lambda>_. True, \<lambda>_. 4]\<^sub>b rbt_set_assn\<^sup>k \<rightarrow> id_assn"
    apply (sep_auto heap: rbt_set_pick_rule simp:  mop_set_pick_def)
    by (auto split: if_splits simp: bind_ASSERT_eq_if emb'_def ran_def)

  lemmas mop_set_pick_rule[sepref_fr_rules] = mop_set_pick_rule_aux[hfb_to_hnr]

end

paragraph "implement pick extract"

text \<open>Therefore use sepref to implement pick extract by pick and delete.\<close>

definition "rbt_set_pick_extract S = do { v \<leftarrow> mop_set_pick (\<lambda>_. 4) S;
                              C \<leftarrow> mop_set_del (\<lambda>(S,_). rbt_delete_time_logN (card S + 1)) S v;
                              RETURNT (v,C) }"

lemma rbt_set_pick_extract_refines: "rbt_delete_time_logN (card S + 1) + 4 \<le> t S \<Longrightarrow> rbt_set_pick_extract S \<le> mop_set_pick_extract t S"
  unfolding mop_set_pick_extract_def rbt_set_pick_extract_def mop_set_pick_def mop_set_del_def
  apply(rule le_ASSERTI)
  apply(rule T_specifies_I)
  by (vcg' \<open>simp add: Some_le_emb'_conv\<close>)

lemma rbt_set_pick_extract_refines': "(rbt_set_pick_extract, PR_CONST (mop_set_pick_extract t)) \<in> [\<lambda>S. rbt_delete_time_logN (card S + 1) + 4 \<le> t S]\<^sub>f Id \<rightarrow> \<langle>Id\<rangle>nrest_rel"
  apply(rule frefI)
  apply(rule nrest_relI) using rbt_set_pick_extract_refines by auto

schematic_goal mop_set_pick_extract_rule':
  notes [id_rules] = itypeI[Pure.of S "TYPE('a set)"]
  shows "hn_refine (hn_ctxt rbt_set_assn S p) (?c::?'c Heap) ?\<Gamma>' ?R (rbt_set_pick_extract S)"
  unfolding rbt_set_pick_extract_def
  by sepref

concrete_definition (in -) set_pick_extract uses mop_set_pick_extract_rule'

lemmas kruskal_ref_spec[sepref_fr_rules] = set_pick_extract.refine[FCOMP rbt_set_pick_extract_refines']

end