section\<open>Imparative implementation for Pointermap\<close>
theory Pointer_Map_Impl
imports Array_List
  "$AFP/Separation_Logic_Imperative_HOL/Sep_Main"
  "$AFP/Separation_Logic_Imperative_HOL/Examples/Hash_Map_Impl"
  Pointer_Map
begin

  record 'a pointermap_impl =
    entriesi :: "'a array_list"
    getentryi :: "('a,nat) hashtable"

  definition is_pointermap_impl :: "('a::{hashable,heap}) pointermap \<Rightarrow> 'a pointermap_impl \<Rightarrow> assn" where
    "is_pointermap_impl b bi \<equiv>
      is_array_list (entries b) (entriesi bi)
    * is_hashmap (getentry b) (getentryi bi)"

  lemma is_pointermap_impl_prec: "precise is_pointermap_impl"
    unfolding is_pointermap_impl_def[abs_def]
  apply(rule preciseI)
  apply(clarsimp)
  apply(rename_tac a a' x y p F F')
  apply(rule pointermapieq_exhaust)
   apply(rule_tac p = "entriesi p" and h = "(x,y)" in preciseD[OF is_array_list_prec])
   apply(unfold star_aci(1))
   apply blast
  apply(rule_tac p = "getentryi p" and h = "(x,y)" in preciseD[OF is_hashmap_prec])
  apply(unfold star_aci(2)[symmetric])
  apply(unfold star_aci(1)[symmetric]) (* black unfold magic *)
  apply(unfold star_aci(2)[symmetric])
  apply blast
  done

  definition pointermap_empty where
    "pointermap_empty \<equiv> do {
      hm \<leftarrow> hm_new;
      arl \<leftarrow> arl_empty;
      return \<lparr>entriesi = arl, getentryi = hm \<rparr>
    }"

  lemma [sep_heap_rules]: "< emp > pointermap_empty <is_pointermap_impl empty_pointermap>\<^sub>t"
    unfolding is_pointermap_impl_def
    by (sep_auto simp: pointermap_empty_def empty_pointermap_def)

  definition pm_pthi where
    "pm_pthi m p \<equiv> arl_nth (entriesi m) p"

  lemma [sep_heap_rules]: "pointermap_sane m \<Longrightarrow> pointermap_p_valid p m \<Longrightarrow>
    < is_pointermap_impl m mi > pm_pthi mi p <\<lambda>ai. is_pointermap_impl m mi * \<up>(ai = pm_pth m p)>"
    by (sep_auto simp: pm_pthi_def pm_pth_def is_pointermap_impl_def pointermap_p_valid_def)

  definition pointermap_getmki where
    "pointermap_getmki a m \<equiv> do {
        lo \<leftarrow> ht_lookup a (getentryi m);
        (case lo of
          Some l \<Rightarrow> return (l,m) |
          None \<Rightarrow> do {
            p \<leftarrow> return (snd (entriesi m));
        ent \<leftarrow> arl_append (entriesi m) a;
        lut \<leftarrow> hm_update a p (getentryi m);
        u \<leftarrow> return \<lparr>entriesi = ent, getentryi = lut\<rparr>;
        return (p,u)
          }
        )
    }"

  lemmas pointermap_getmki_defs = pointermap_getmki_def pointermap_getmk_def pointermap_insert_def is_pointermap_impl_def
  lemma [sep_heap_rules]: "pointermap_sane m \<Longrightarrow> pointermap_getmk a m = (p,u) \<Longrightarrow>
    < is_pointermap_impl m mi >
      pointermap_getmki a mi
    <\<lambda>(pi,ui). is_pointermap_impl u ui * \<up>(pi = p)>\<^sub>t"
  apply(cases "getentry m a")
   apply(unfold pointermap_getmki_def)
   apply(unfold return_bind)
   apply(rule bind_rule[where R = "\<lambda>r. is_pointermap_impl m mi * \<up>(r = None \<and> (snd (entriesi mi) = p)) * true"])
    apply(sep_auto simp: pointermap_getmki_defs is_array_list_def split: prod.splits;fail)
   apply(sep_auto simp: pointermap_getmki_defs)+
  done

end


theory OpSem
imports Main HOL.Rat
begin

type_synonym TS = rat (* Event *)
type_synonym T = nat (* Thread ID *)
type_synonym L = nat (*? Ref?*)
definition "null = (0 :: nat)"

type_synonym V = nat

(* bool: release/aquire or relaxed*)
datatype action =
    Read bool L V
  | Write bool L V
  | Update L V V

print_theorems

fun avar :: "action \<Rightarrow> L" where
    "avar (Read _ x v) = x"
  | "avar (Write _ x v) = x"
  | "avar (Update x e v) = x"

fun wr_val :: "action \<Rightarrow> V option" where
    "wr_val (Write _ _ v) =  Some v"
  | "wr_val (Update _ _ v) = Some  v"
  | "wr_val _ = None"

fun rd_val :: "action \<Rightarrow> V option" where
    "rd_val (Read _ _ v) = Some v"
  | "rd_val (Update _ v _) = Some v"
  | "rd_val _ = None"

fun isRA :: "action \<Rightarrow> bool" where
    "isRA (Read b _ _) = b"
  | "isRA (Write b _ _) = b"
  | "isRA (Update _ _ _) = True"

fun isWr :: "action \<Rightarrow> bool" where
    "isWr (Read _ _ _) = False"
  | "isWr (Write _ _ _) = True"
  | "isWr (Update _ _ _) = False"

fun isRd :: "action \<Rightarrow> bool" where
    "isRd (Read _ _ _) = True"
  | "isRd (Write _ _ _) = False"
  | "isRd (Update _ _ _) = False"

fun isUp :: "action \<Rightarrow> bool" where
    "isUp (Read _ _ _) = False"
  | "isUp (Write _ _ _) = False"
  | "isUp (Update _ _ _) = True"

abbreviation "reads a \<equiv> a \<in> (dom rd_val)"
abbreviation "writes a \<equiv> a \<in> (dom wr_val)"

type_synonym View = "L \<Rightarrow> T"

type_synonym event = "TS \<times> T \<times> action"

abbreviation time_stamp :: "event \<Rightarrow> TS" where "time_stamp e \<equiv> fst e"
abbreviation tid :: "event \<Rightarrow> T" where "tid e \<equiv> fst (snd e)"
abbreviation act :: "event \<Rightarrow> action" where "act e \<equiv> snd (snd e)"

abbreviation var :: "L \<times> TS \<Rightarrow> L" where "var \<equiv> fst"
abbreviation tst :: "L \<times> TS \<Rightarrow> TS" where "tst \<equiv> snd"

(*

record write_record =
  val :: V
  is_releasing :: bool

record surrey_state =
  writes :: "(L \<times> TS) set"
  thrView :: "T \<Rightarrow> L \<Rightarrow> (L \<times> TS)"
  modView :: "(L \<times> TS) \<Rightarrow> L \<Rightarrow> (L \<times> TS)"
  mods :: "(L \<times> TS) \<Rightarrow> write_record"
  write_available :: "(L \<times> TS) \<Rightarrow> bool" \<comment> \<open>rewrite as "covered" instead of write_available\<close>

definition "value \<sigma> w \<equiv>  val (mods \<sigma> w)"
definition "releasing \<sigma> w \<equiv>  is_releasing (mods \<sigma> w)"

definition "writes_on \<sigma> x = {w . var w = x \<and> w \<in> writes \<sigma>}"
definition "visible_writes \<sigma> t x \<equiv> {w \<in> writes_on \<sigma> x . tst(thrView \<sigma> t x) \<le> tst w}" \<comment> \<open>is this observable writes?\<close>

lemma writes_on_var [simp]: "w \<in> writes_on \<sigma> x \<Longrightarrow> var w = x"
  by (simp add: writes_on_def)

lemma visible_var [simp]: "w \<in> visible_writes \<sigma> t x \<Longrightarrow> var w = x"
  by (auto simp add: visible_writes_def)

lemma visible_writes_in_writes: "visible_writes \<sigma> t x \<subseteq> writes \<sigma>"
  using visible_writes_def writes_on_def by fastforce

definition "valid_fresh_ts \<sigma> w ts' \<equiv> tst w < ts' \<and> (\<forall> w' \<in> writes_on \<sigma> (var w). tst w < tst w' \<longrightarrow> ts' < tst w')"

definition "ts_oride m m' x \<equiv> if tst (m x) \<le> tst (m' x) then m' x else m x"

definition rev_app :: "'s \<Rightarrow> ('s \<Rightarrow> 't) \<Rightarrow> 't" (infixl ";;" 150)
  where
  "rev_app s f \<equiv> f s"

definition
  "update_thrView t nv \<sigma> \<equiv> \<sigma> \<lparr> thrView := (thrView \<sigma>)(t := nv)\<rparr>"

definition
  "update_modView w nv \<sigma> \<equiv> \<sigma> \<lparr> modView := (modView \<sigma>)(w := nv) \<rparr>"

definition
  "update_mods w nwr \<sigma> \<equiv> \<sigma> \<lparr> mods := (mods \<sigma>)(w := nwr)\<rparr> \<lparr>writes := writes \<sigma> \<union> {w}\<rparr>"

definition
  "update_wa w b \<sigma> \<equiv> \<sigma> \<lparr> write_available := (write_available \<sigma>)(w := b)\<rparr>"

definition "syncing \<sigma> w b \<equiv> releasing \<sigma> w \<and> b"

lemma [simp]: "syncing \<sigma> w False = False"
  by (simp add: syncing_def)

lemma [simp]: "syncing \<sigma> w True = releasing \<sigma> w"
  by (simp add: syncing_def)

definition
  "read_trans t b w \<sigma>  \<equiv>
       let new_thr_idx = (thrView \<sigma> t)(var w := w) in
       let new_thr_idx' =
             if syncing \<sigma> w b then ts_oride new_thr_idx (modView \<sigma> w) else new_thr_idx in
          \<sigma> ;; update_thrView t new_thr_idx'"

lemma [simp]: "\<not> syncing \<sigma> w b \<Longrightarrow> thrView (read_trans t b w \<sigma>) t = (thrView \<sigma> t)(var w := w)"
  by (simp add: read_trans_def rev_app_def update_thrView_def)

lemma syncing_thrView_read_trans [simp]: "syncing \<sigma> w b \<Longrightarrow>
                     thrView (read_trans t b w \<sigma>) t = ts_oride ((thrView \<sigma> t)(var w := w)) (modView \<sigma> w)"
  by (simp add: read_trans_def rev_app_def update_thrView_def)

lemma [simp]: "t' \<noteq> t \<Longrightarrow> thrView (read_trans t b w \<sigma>) t' = (thrView \<sigma> t')"
  apply (simp add: read_trans_def rev_app_def update_thrView_def)
  by (metis fun_upd_other surrey_state.select_convs(2) surrey_state.surjective surrey_state.update_convs(2))

lemma [simp]: "var w \<noteq> x \<Longrightarrow> b = False \<Longrightarrow> thrView (read_trans t b w \<sigma>) t x = thrView \<sigma> t x"
  by (simp add: read_trans_def rev_app_def update_thrView_def Let_def ts_oride_def)

lemma [simp]: "modView (read_trans t b w \<sigma>) = modView \<sigma>"
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "mods (read_trans t b w \<sigma>) = mods \<sigma>"
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "write_available (read_trans t b w \<sigma>) = write_available \<sigma>"
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "writes (read_trans t b w \<sigma>) = writes \<sigma>"
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "writes_on (read_trans t b w \<sigma>) x = writes_on \<sigma> x"
  apply(unfold writes_on_def)
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "value (read_trans t False w \<sigma>) x  = value \<sigma> x"
  apply(unfold value_def)
  by(simp add: read_trans_def Let_def rev_app_def update_thrView_def)

definition
  "write_trans t b w v \<sigma> ts' \<equiv>
          \<sigma> ;; update_thrView t ((thrView \<sigma> t)(var w := (var w, ts')))
            ;; update_modView (var w, ts') ((thrView \<sigma> t)(var w := (var w, ts')))
            ;; update_mods (var w, ts') \<lparr> val = v, is_releasing = b\<rparr>
            ;; update_wa (var w, ts') True"

lemma [simp]: "thrView (write_trans t b w v \<sigma> ts') t = (thrView \<sigma> t)(var w := (var w, ts'))"
  by (simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "t' \<noteq> t \<Longrightarrow> thrView (write_trans t b w v \<sigma> ts') t' = (thrView \<sigma> t')"
  by (simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow> modView (write_trans t b w v \<sigma> ts') w' = (thrView \<sigma> t)(var w := (var w, ts'))"
  apply (simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> modView (write_trans t b w v \<sigma> ts') w' = modView \<sigma> w'"
  by (auto simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> modView (write_trans t b w v \<sigma> ts') w' y = modView \<sigma> w' y"
  by (auto simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "tst w' \<noteq> ts' \<Longrightarrow> modView (write_trans t b w v \<sigma> ts') w' = modView \<sigma> w'"
  by (auto simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow> mods (write_trans t b w v \<sigma> ts') w' = \<lparr> val = v, is_releasing = b\<rparr>"
  apply (simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> mods (write_trans t b w v \<sigma> ts') w' = mods \<sigma> w'"
  by (auto simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "tst w' \<noteq> ts' \<Longrightarrow> mods (write_trans t b w v \<sigma> ts') w' = mods \<sigma> w'"
  by (auto simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow> write_available (write_trans t b w v \<sigma> ts') w' = True"
  apply (simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow>
                write_available (write_trans t b w v \<sigma> ts') w' = write_available \<sigma> w'"
  by (auto simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "tst w' \<noteq> ts' \<Longrightarrow> write_available (write_trans t b w v \<sigma> ts') w' = write_available \<sigma> w'"
  by (auto simp add: write_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma writes_new_w [simp]: "writes (write_trans t b w v \<sigma> ts') = writes \<sigma> \<union> {(var w, ts')}"
  by(simp add: Let_def rev_app_def
                   write_trans_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "x = var w \<Longrightarrow> writes_on (write_trans t b w v \<sigma> ts') x = writes_on \<sigma> x \<union> {(var w, ts')}"
  apply(unfold writes_on_def)
  apply(simp add: read_trans_def Let_def rev_app_def update_thrView_def)
  using Collect_cong by auto

lemma [simp]: "y \<noteq> var w \<Longrightarrow> writes_on (write_trans t b w v \<sigma> ts') y = writes_on \<sigma> y"
  apply(unfold writes_on_def)
  by(auto simp add: read_trans_def Let_def rev_app_def update_thrView_def)

lemma [simp]: "w \<in> writes_on \<sigma> y \<Longrightarrow>  w \<in> writes_on (write_trans t b w' v \<sigma> ts') y"
  apply(unfold writes_on_def)
  by simp

definition "update_trans t w v' \<sigma> ts' \<equiv>
       let new_thr_idx = (thrView \<sigma> t)(var w := (var w, ts')) in
         let new_thr_idx' =
             if releasing \<sigma> w
             then
                 ts_oride new_thr_idx (modView \<sigma> w)
             else
                 new_thr_idx
             in
                 \<sigma> ;; update_thrView t new_thr_idx'
                   ;; update_modView (var w, ts') new_thr_idx' \<comment> \<open>TODO: check this prime on new_thr_idx\<close>
                   ;; update_mods (var w, ts') \<lparr> val = v', is_releasing = True\<rparr>
                   ;; update_wa (var w, ts') True
                   ;; update_wa w False"

lemma [simp]: "\<not> releasing \<sigma> w \<Longrightarrow>
                     thrView (update_trans  t w v' \<sigma> ts') t = (thrView \<sigma> t)(var w := (var w, ts'))"
  by (simp add: Let_def rev_app_def update_modView_def update_mods_def update_thrView_def update_trans_def update_wa_def)

lemma [simp]: " releasing \<sigma> w \<Longrightarrow>
                  thrView (update_trans  t w v' \<sigma> ts') t = ts_oride ((thrView \<sigma> t)(var w := (var w, ts'))) (modView \<sigma> w)"
  by (auto simp add: Let_def update_trans_def update_wa_def rev_app_def update_modView_def update_mods_def update_thrView_def)

lemma [simp]: "t' \<noteq> t \<Longrightarrow> thrView (update_trans  t w v' \<sigma> ts') t' = (thrView \<sigma> t')"
  by (simp add: Let_def update_trans_def update_wa_def rev_app_def update_modView_def update_mods_def update_thrView_def)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow>
             \<not> releasing \<sigma> w \<Longrightarrow> modView (update_trans t w v' \<sigma> ts') w' = (thrView \<sigma> t)(var w := (var w, ts'))"
  apply (simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow>
             releasing \<sigma> w \<Longrightarrow> modView (update_trans t w v' \<sigma> ts') w' = ts_oride ((thrView \<sigma> t)(var w := (var w, ts'))) (modView \<sigma> w)"
  apply (simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> modView (update_trans t w v' \<sigma> ts') w' = modView \<sigma> w'"
  by (auto simp add: Let_def fun_upd_idem_iff fun_upd_twist rev_app_def update_modView_def update_mods_def update_thrView_def update_trans_def update_wa_def)

lemma [simp]: "tst w' \<noteq> ts' \<Longrightarrow> modView (update_trans t w v' \<sigma> ts') w' = modView \<sigma> w'"
  by (auto simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> mods (update_trans t w v' \<sigma> ts') w' = mods \<sigma> w'"
  by (auto simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "tst w' \<noteq> ts' \<Longrightarrow> mods (update_trans t w v' \<sigma> ts') w' = mods \<sigma> w'"
  by (auto simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow>
             mods (update_trans t w v' \<sigma> ts') w' = \<lparr> val = v', is_releasing = True\<rparr>"
  apply (simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse)

lemma [simp]: "var w' = var w \<Longrightarrow> tst w' = ts' \<Longrightarrow>
       tst w \<noteq> ts' \<Longrightarrow> write_available (update_trans t w v' \<sigma> ts') w'"
  apply (auto simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)
  by (metis prod.collapse)

lemma [simp]: "var w' \<noteq> var w \<Longrightarrow> write_available (update_trans t w v' \<sigma> ts') w' = write_available \<sigma> w'"
  by (auto simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "\<not> write_available (update_trans t w v' \<sigma> ts') w"
  by (simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "tst w' \<noteq> ts' \<and> tst w' \<noteq> tst w \<Longrightarrow> write_available (update_trans t w v' \<sigma> ts') w' = write_available \<sigma> w'"
 by (auto simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "writes (update_trans t w v' \<sigma> ts') = writes \<sigma> \<union> {(var w, ts')}"
 by (auto simp add: Let_def update_trans_def rev_app_def update_wa_def update_thrView_def
                   update_modView_def update_mods_def)

lemma [simp]: "x = var w \<Longrightarrow> writes_on (update_trans t w v' \<sigma> ts') x = writes_on \<sigma> x \<union> {(x, ts')}"
  apply(unfold writes_on_def)
  apply(simp add: read_trans_def Let_def rev_app_def update_thrView_def)
  using Collect_cong by auto

lemma [simp]: "y \<noteq> var w \<Longrightarrow> writes_on (update_trans t w v' \<sigma> ts') y = writes_on \<sigma> y"
  apply(unfold writes_on_def)
  by(auto simp add: read_trans_def Let_def rev_app_def update_thrView_def)

definition step :: "T \<Rightarrow> action \<Rightarrow> surrey_state \<Rightarrow> surrey_state \<Rightarrow> bool"
  where
    "step t a \<sigma> \<sigma>'\<equiv>
       \<exists> w. w \<in> visible_writes \<sigma> t (avar a) \<and>
       (case a of
         Read b x v \<Rightarrow>
           v = value \<sigma> w \<and>
           \<sigma>' = read_trans t b w \<sigma>
       | Write b x v \<Rightarrow> \<exists> ts'.
           write_available \<sigma> w \<and> \<comment> \<open> TODO: use sets and predicates consistently \<close>
           valid_fresh_ts \<sigma> w ts' \<and>
           \<sigma>' = write_trans t b w v \<sigma> ts'
       | Update x v v' \<Rightarrow> \<exists> ts'.
           v = value \<sigma> w \<and>
           write_available \<sigma> w \<and>
           valid_fresh_ts \<sigma> w ts' \<and>
           \<sigma>' = update_trans t w v' \<sigma> ts')
           "

lemma step_cases:
       "step t a \<sigma> \<sigma>'
          \<Longrightarrow>
        \<lbrakk>\<And> w b x v. \<sigma>' = read_trans t b w \<sigma> \<and> a = Read b x v \<and> w \<in> visible_writes \<sigma> t (avar a) \<and>
          v = value \<sigma> w \<Longrightarrow> P \<sigma> (read_trans t b w \<sigma>)\<rbrakk>
         \<Longrightarrow>
       \<lbrakk>\<And> w b x v ts'. \<sigma>' = write_trans t b w v \<sigma> ts' \<and> a = Write b x v \<and> w \<in> visible_writes \<sigma> t (avar a) \<and>
           write_available \<sigma> w \<and>
           valid_fresh_ts \<sigma> w ts'
           \<Longrightarrow> P \<sigma> (write_trans t b w v \<sigma> ts') \<rbrakk>
         \<Longrightarrow>
       \<lbrakk>\<And> w x v v' ts'. \<sigma>' = update_trans t w v' \<sigma> ts' \<and> a = Update x v v' \<and>
           w \<in> visible_writes \<sigma> t (avar a) \<and>
           v = value \<sigma> w \<and>
           write_available \<sigma> w \<and>
           valid_fresh_ts \<sigma> w ts'
           \<Longrightarrow> P \<sigma> (update_trans t w v' \<sigma> ts')\<rbrakk>
  \<Longrightarrow> P \<sigma> \<sigma>'"
  apply(simp add: step_def) apply(case_tac a) by auto

definition "WrX x v \<equiv> Write False x v"
definition "WrR x v \<equiv> Write True x v"
definition "RdX x v \<equiv> Read False x v"
definition "RdA x v \<equiv> Read True x v"

abbreviation WrX_state_abbr:: " surrey_state \<Rightarrow> L \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ [_ := _]\<^sub>_ _" [100,100,100,100,100])
  where "\<sigma> [x := v]\<^sub>t \<sigma>' \<equiv> step t (WrX x v) \<sigma> \<sigma>'"

abbreviation WrR_state_abbr:: " surrey_state \<Rightarrow> L \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ [_ :=\<^sup>R _]\<^sub>_ _" [100,100,100,100,100])
  where "\<sigma> [x :=\<^sup>R v]\<^sub>t \<sigma>' \<equiv> step t (WrR x v) \<sigma> \<sigma>'"

abbreviation RdX_state_abbr:: " surrey_state \<Rightarrow> V \<Rightarrow> L \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ [_ \<leftarrow> _]\<^sub>_ _" [100,100,100,100,100])
  where "\<sigma> [r \<leftarrow> x]\<^sub>t \<sigma>' \<equiv> step t (RdX x r) \<sigma> \<sigma>'"

abbreviation RdA_state_abbr:: " surrey_state \<Rightarrow> V \<Rightarrow> L \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ [_ \<leftarrow>\<^sup>A _]\<^sub>_ _" [100,100,100,100,100])
  where "\<sigma> [r \<leftarrow>\<^sup>A x]\<^sub>t \<sigma>' \<equiv> step t (RdA x r) \<sigma> \<sigma>'"

abbreviation Up_state_abbr:: " surrey_state \<Rightarrow> L \<Rightarrow> V \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("_ RMW[_, _, _]\<^sub>_ _" [100,100,100,100,100,100])
  where "\<sigma> RMW[x, u, v]\<^sub>t \<sigma>' \<equiv> step t (Update x u v) \<sigma> \<sigma>'"

definition "initial_state \<sigma> I \<equiv>
                 \<exists> F . writes \<sigma> = (\<lambda>x. (x, F x)) ` UNIV \<and>
                       (\<forall> t x. thrView \<sigma> t x = (x, F x)) \<and>
                       (\<forall> w x. modView \<sigma> w x = (x, F x)) \<and>
                       (\<forall> w. mods \<sigma> w = \<lparr> val = I (var w), is_releasing = False \<rparr>) \<and>
                       (\<forall> w. write_available \<sigma> w = True)"

(*
definition "initial_state \<sigma> I \<equiv>
                 \<exists> F . writes \<sigma> = {(x, F x) | x. True} \<and>
                       (\<forall> t x. thrView \<sigma> t x = (x, F x)) \<and>
                       (\<forall> w x. modView \<sigma> w x = (x, F x)) \<and>
                       (\<forall> w. mods \<sigma> w = \<lparr> val = I (var w), is_releasing = False \<rparr>) \<and>
                       (\<forall> w. write_available \<sigma> w = True)"
*)

definition  "lastWr \<sigma> x \<equiv> (x, Max (tst`(writes_on \<sigma> x)))"

definition
  "wfs \<sigma> \<equiv>
      (\<forall> t x. thrView \<sigma> t x \<in> writes_on \<sigma> x) \<and>
      (\<forall> w x. modView \<sigma> w x \<in> writes_on \<sigma> x) \<and>
      (\<forall> x. finite(writes_on \<sigma> x)) \<and>
      (\<forall> w. w \<in> writes \<sigma> \<longrightarrow> modView \<sigma> w (var w) = w) \<and>
      (\<forall> w x. w = lastWr \<sigma> x \<longrightarrow> write_available \<sigma> w )"

lemma initially_write_unique:
  "initial_state \<sigma> I \<Longrightarrow> w \<in> writes_on \<sigma> x \<Longrightarrow> w' \<in> writes_on \<sigma> x \<Longrightarrow> w = w'"
  apply(unfold initial_state_def writes_on_def) by auto

  lemma finite_single_fst_eq: \<open>finite {w. fst w = x \<and> (\<exists>x. w = (x, F
    x))}\<close> (is \<open>finite ?A\<close>) proof - have \<open>?A \<subseteq> {(x, F x)}\<close> by auto from
    finite_subset[OF this] show ?thesis by auto qed

  lemma in_writes_onI: \<open>var w = x \<Longrightarrow> w \<in> writes \<sigma> \<Longrightarrow> w \<in> writes_on \<sigma> x\<close>
    unfolding writes_on_def by auto

(*
  lemma initial_wfs: assumes "initial_state \<sigma> I" shows "wfs \<sigma>" using
    assms initially_write_unique[OF assms(1)]

    apply (auto simp add: wfs_def
     initial_state_def lastWr_def
     intro: in_writes_onI)

    sledgehammer
*)

(* TODO: do something about SMTs *)
lemma initial_wfs:
  assumes "initial_state \<sigma> I"
  shows "wfs \<sigma>"
  apply(simp add: initial_state_def wfs_def)
  apply(rule conjI) apply (unfold writes_on_def, clarify)
  apply (metis (mono_tags) UNIV_I assms fst_conv image_eqI initial_state_def)
  apply(rule conjI)
  using assms apply (simp add: initial_state_def)
   apply auto[1]
  apply rule using initially_write_unique[OF assms]
  apply (smt Collect_cong empty_iff finite.intros(1) finite.intros(2) insert_compr mem_Collect_eq not_finite_existsD writes_on_def)
  using assms apply safe
  apply (simp add: initial_state_def) apply auto[1]
  using initial_state_def by blast

lemma allI_case: "\<lbrakk>\<And> y. x \<noteq> y \<Longrightarrow> P y\<rbrakk> \<Longrightarrow> \<lbrakk>P x\<rbrakk> \<Longrightarrow> \<forall> y. P y" by fastforce

lemma [simp]: "wfs \<sigma> \<Longrightarrow> writes_on \<sigma> x \<noteq> {}"
  apply(simp add: wfs_def)
  by (metis empty_iff)

lemma [simp]: "wfs \<sigma> \<Longrightarrow> finite(writes_on \<sigma> x)"
  by(simp add: wfs_def)

lemma [simp]: "wfs \<sigma> \<Longrightarrow> thrView \<sigma> t x \<in> writes_on \<sigma> x"
  by(simp add: wfs_def)

lemma [simp]: "wfs \<sigma> \<Longrightarrow> modView \<sigma> w x \<in> writes_on \<sigma> x"
  using wfs_def by blast

lemma [simp]: "wfs \<sigma> \<Longrightarrow> modView (read_trans t b w \<sigma>) w x \<in> writes_on (read_trans t b w \<sigma>) x"
  by auto

lemma [simp]: "wfs \<sigma> \<Longrightarrow> writes_on \<sigma> x =  writes_on (read_trans t b w \<sigma>) x"
  by auto

lemma own_ModView:
  assumes "wfs \<sigma>"
      and "w \<in> writes \<sigma>"
    shows "modView \<sigma> w (var w) = w"
  using assms apply(unfold wfs_def)
  by blast

lemma ts_oride_same_var:
  assumes "wfs \<sigma>"
      and "x = var w"
      and "w \<in> visible_writes \<sigma> t (var w)"
    shows "ts_oride ((thrView \<sigma> t)(var w := w)) (modView \<sigma> w) x = w"
  apply(simp add: ts_oride_def) apply safe using assms
  apply (meson own_ModView subsetCE visible_writes_in_writes)
  using assms(2) apply blast
  using assms(2) by blast

lemma ts_oride_diff_var:
  assumes "wfs \<sigma>"
      and "x \<noteq> var w"
      and "w \<in> visible_writes \<sigma> t (var w)"
    shows "ts_oride ((thrView \<sigma> t)(var w := w')) (modView \<sigma> w) x = ts_oride (thrView \<sigma> t) (modView \<sigma> w) x"
  apply(simp add: ts_oride_def)
  using assms(2) by blast

lemma ts_oride_split:
  assumes "tst (m' x) \<le> tst (m x) \<Longrightarrow> P (m x)"
      and "tst (m x) \<le> tst (m' x) \<Longrightarrow> P (m' x)"
    shows "P (ts_oride m m' x)"
  apply(simp add: ts_oride_def)
  by (simp add: assms(1) assms(2))

lemma wr_other_pres_last: "wfs \<sigma> \<Longrightarrow> x \<noteq> xa \<Longrightarrow> lastWr (write_trans t ba (x, b) v \<sigma> ts') xa = lastWr \<sigma> xa"
  by(simp add: lastWr_def)

lemma upd_other_pres_last: "wfs \<sigma> \<Longrightarrow> x \<noteq> xa \<Longrightarrow> lastWr (update_trans t (x, b) v \<sigma> ts') xa = lastWr \<sigma> xa"
  by(simp add: lastWr_def)

lemma last_w_not_last: "wfs \<sigma> \<Longrightarrow> (xa, b) \<in> visible_writes \<sigma> t xa \<Longrightarrow> valid_fresh_ts \<sigma> (xa,b) ts'  \<Longrightarrow> b \<noteq> Max (tst ` writes_on \<sigma> xa) \<Longrightarrow> lastWr (write_trans t ba (xa, b) v \<sigma> ts') xa =  lastWr  \<sigma> xa "
  apply(simp add: visible_writes_def valid_fresh_ts_def)
  apply(elim conjE)
  apply(subgoal_tac "b <  Max (tst ` writes_on \<sigma> xa)")
   defer
  apply(unfold wfs_def , clarsimp)
   apply (metis Max_ge finite_imageI image_eqI le_neq_trans snd_conv)
  apply(subgoal_tac "tst (lastWr \<sigma> xa) = Max (tst ` writes_on \<sigma> xa)")
   defer
   apply (simp add: lastWr_def)
  apply (simp add: lastWr_def)
  apply(subgoal_tac "ts' <  Max (tst ` writes_on \<sigma> xa)")
   defer
   apply simp
  apply (metis (mono_tags, lifting) Max_in empty_iff finite_imageI image_iff)
  by (smt Max_ge Max_in empty_iff finite_imageI finite_insert image_is_empty insert_iff le_neq_trans less_imp_not_less)

lemma last_w_not_last_upd: "wfs \<sigma> \<Longrightarrow> (xa, b) \<in> visible_writes \<sigma> t xa \<Longrightarrow> valid_fresh_ts \<sigma> (xa,b) ts'  \<Longrightarrow> b \<noteq> Max (tst ` writes_on \<sigma> xa) \<Longrightarrow> lastWr (update_trans t (xa, b) v \<sigma> ts') xa =  lastWr  \<sigma> xa "
  apply(simp add: visible_writes_def valid_fresh_ts_def)
  apply(elim conjE)
  apply(subgoal_tac "b <  Max (tst ` writes_on \<sigma> xa)")
   defer
  apply(unfold wfs_def, clarsimp)
   apply (metis Max_ge finite_imageI image_eqI le_neq_trans snd_conv)
  apply(subgoal_tac "tst (lastWr \<sigma> xa) = Max (tst ` writes_on \<sigma> xa)")
  apply (simp add: lastWr_def)
  apply(subgoal_tac "ts' <  Max (tst ` writes_on \<sigma> xa)")
   apply (smt Max_ge Max_in dual_order.antisym empty_iff finite_imageI finite_insert image_is_empty insert_iff leD)
  apply (metis (mono_tags, lifting) Max_in empty_iff finite_imageI image_iff)
  by (simp add: lastWr_def)

lemma lastWr_w: "wfs \<sigma> \<Longrightarrow> (xa, Max (tst ` writes_on \<sigma> xa)) \<in> visible_writes \<sigma> t xa \<Longrightarrow> valid_fresh_ts \<sigma> ((xa, Max (tst ` writes_on \<sigma> xa))) ts' \<Longrightarrow>
    lastWr (write_trans t ba ((xa, Max (tst ` writes_on \<sigma> xa)))  v \<sigma> ts') xa = (xa, ts')"
  apply(unfold wfs_def)
  apply clarsimp
  apply(simp add: valid_fresh_ts_def)
  apply(elim conjE)
  apply(simp add: lastWr_def)
  by (meson Max_ge Max_insert2 dual_order.strict_implies_order dual_order.trans finite_imageI)

lemma lastWr_upd: "wfs \<sigma> \<Longrightarrow> (xa, Max (tst ` writes_on \<sigma> xa)) \<in> visible_writes \<sigma> t xa \<Longrightarrow> valid_fresh_ts \<sigma> ((xa, Max (tst ` writes_on \<sigma> xa))) ts' \<Longrightarrow>
    lastWr (update_trans t ((xa, Max (tst ` writes_on \<sigma> xa)))  v \<sigma> ts') xa = (xa, ts')"
  apply(unfold wfs_def)
  apply clarsimp
  apply(simp add: valid_fresh_ts_def)
  apply(elim conjE)
  apply(simp add: lastWr_def)
  by (meson Max_ge Max_insert2 dual_order.strict_implies_order dual_order.trans finite_imageI)

(*
lemmas lastWrdefs [simp] = lastWr_def

lemma finite_writes:
  assumes "aa \<noteq> xa"
    and "finite{w. var w = xa \<and> w \<in> surrey_state.writes \<sigma>}"
  shows
    "finite{w. var w = xa \<and>
              w \<in> surrey_state.writes (write_trans t ba (aa, b) v \<sigma> ts')}"
 using assms apply auto
  by (smt Collect_cong fst_conv)

lemma wfs_preserved:
  assumes "wfs \<sigma>"
      and "step t a \<sigma> \<sigma>'"
    shows "wfs \<sigma>'"
  using assms(1) apply(unfold wfs_def)
  apply (rule step_cases[OF assms(2)])
  apply safe apply clarsimp
  unfolding writes_on_def apply (simp add: read_trans_def rev_app_def Let_def)
  apply (intro conjI impI)
  apply (simp add: ts_oride_def update_thrView_def)
  apply (simp add: ts_oride_def update_thrView_def)
  apply clarsimp
  apply (meson in_mono visible_writes_in_writes)
  apply (simp add: ts_oride_def update_thrView_def)
  apply (simp add: ts_oride_def update_thrView_def)
  apply (meson in_mono visible_writes_in_writes)
  apply auto[4]
  unfolding writes_on_def apply (simp add: update_modView_def update_thrView_def update_wa_def update_mods_def write_trans_def rev_app_def Let_def)
  unfolding writes_on_def apply (simp add: update_modView_def update_thrView_def update_wa_def update_mods_def write_trans_def rev_app_def Let_def)
  unfolding writes_on_def apply (simp add: visible_writes_def valid_fresh_ts_def update_modView_def update_thrView_def update_wa_def update_mods_def write_trans_def rev_app_def Let_def)
         apply(case_tac "xa = aa")
          prefer 2 apply (erule_tac x = "xa" in allE)+ apply auto [1] using finite_writes
  apply (smt Collect_cong fst_conv)
  apply (unfold writes_on_def) apply auto [1]
  sledgehammer
  sorry
*)

lemma wfs_preserved:
  assumes "wfs \<sigma>"
      and "step t a \<sigma> \<sigma>'"
    shows "wfs \<sigma>'"
  apply(unfold wfs_def)
  apply rule defer apply rule defer apply rule defer defer
    apply clarsimp defer
    apply clarsimp
     apply (rule step_cases[OF assms(2)]) apply simp_all
  using assms(1) wfs_def apply auto[1]
  apply(case_tac "var w = aa")
       apply(case_tac "(aa, b) = (x, ts')") apply simp
  apply simp
       apply(case_tac "b = ts'") apply simp using assms(1) wfs_def apply blast
   apply simp apply(case_tac "var w = x") apply simp
  using assms(1) wfs_def apply blast  apply simp
  using assms(1) wfs_def apply blast
   apply simp apply(case_tac "var w = x") apply simp
  using assms(1) wfs_def apply blast apply simp
  using assms(1) wfs_def apply blast
     apply(case_tac "var w = aa") (*********)
  apply(case_tac "releasing \<sigma> w")
      apply(case_tac "(aa, b) = (x, ts')")
        apply simp apply (metis assms(1) fun_upd_same ts_oride_def wfs_def)
       apply(case_tac "b = ts'") apply(case_tac "var w = x") apply simp
        apply simp apply(rule ts_oride_split) using assms(1) apply simp
          using assms(1) apply simp
          apply(case_tac "var w = x") apply simp using assms(1) wfs_def apply blast
               apply simp using assms(1) wfs_def apply blast
              apply(case_tac "(aa, b) = (x, ts')") apply simp
          apply simp apply(case_tac "var w = x") apply simp using assms(1) wfs_def apply blast
          apply(case_tac "b = ts'")apply simp using assms(1) wfs_def apply blast
         apply simp using assms(1) wfs_def apply blast
          apply(case_tac "var w = x") apply simp using assms(1) wfs_def apply blast
             apply simp using assms(1) wfs_def apply blast
          apply clarsimp apply (rule step_cases[OF assms(2)]) apply simp_all
          using assms(1) wfs_def apply blast
             apply(case_tac "var w = x") apply simp using assms(1) wfs_def apply blast
             apply simp using assms(1) wfs_def apply blast
             apply(case_tac "var w = x") apply simp using assms(1) wfs_def apply blast
            apply simp using assms(1) wfs_def apply blast
           defer
          apply (rule step_cases[OF assms(2)])
            apply(case_tac "ta = t") apply(case_tac "syncing \<sigma> w b")
               apply simp apply(rule ts_oride_split)
          apply (metis assms(1) fun_upd_apply subsetCE visible_writes_in_writes wfs_def)
  using assms(1) wfs_def apply blast apply simp
     apply (metis assms(1) subsetCE visible_writes_in_writes wfs_def)
    apply simp using assms(1) wfs_def apply blast
            apply(case_tac "ta = t") apply simp
  using assms(1) wfs_def apply blast
  apply simp apply(case_tac "var w = x") apply simp
  using assms(1) wfs_def apply blast
   apply simp using assms(1) wfs_def apply blast
  apply(case_tac "ta = t") apply simp apply(case_tac "releasing \<sigma> w") apply simp
  apply(case_tac "var w = x") apply simp
     apply (metis assms(1) fun_upd_same ts_oride_def wfs_def)
  apply simp apply(rule ts_oride_split)
  using assms(1) apply auto[1]
  using assms(1) wfs_def apply blast
  apply simp
  using assms(1) wfs_def apply blast
  apply simp apply(case_tac "var w = x") apply simp
  using assms(1) wfs_def apply blast apply simp
  using assms(1) wfs_def apply blast
           apply (rule step_cases[OF assms(2)]) apply simp
          using assms(1)
             apply(unfold wfs_def read_trans_def)
          apply(simp add: rev_app_def Let_def syncing_def)
             apply(simp add: update_wa_def update_mods_def update_modView_def update_thrView_def ts_oride_def)
          apply(simp add: lastWr_def)
             apply(unfold writes_on_def, simp)
            apply(elim conjE)
            apply(intro conjI)
             apply(intro allI impI)
          apply simp
          apply (smt fun_upd_def rev_app_def surrey_state.select_convs(3) surrey_state.surjective surrey_state.update_convs(1) surrey_state.update_convs(2) surrey_state.update_convs(3) surrey_state.update_convs(4) surrey_state.update_convs(5) update_modView_def update_mods_def update_thrView_def update_wa_def visible_var write_trans_def)
          (**)  apply(intro allI impI)
          apply clarsimp
             apply(case_tac "aa \<noteq> x")
          apply(unfold  visible_writes_def writes_on_def)
             apply simp
            apply clarsimp
            apply(case_tac "x \<noteq> xa")
          using assms(1)
             apply(simp add: wr_other_pres_last lastWr_def)
            apply simp
            apply(case_tac "b \<noteq>  Max (tst ` writes_on \<sigma> xa)")
          using assms(1)
             apply simp
          apply(subgoal_tac "(xa, b) \<in> visible_writes \<sigma> t xa")
              apply (simp add: last_w_not_last)
              apply(simp add: write_trans_def rev_app_def)
          apply (simp add:  update_modView_def update_mods_def update_thrView_def update_wa_def)
          apply(simp add: visible_writes_def)

          apply (metis wfs_def)
            apply simp
          apply(subgoal_tac "lastWr (write_trans t ba (xa, Max (tst ` writes_on \<sigma> xa)) v \<sigma> ts') xa = (xa, ts')")
             apply simp
          using assms(1)
          apply(unfold wfs_def)
          apply clarsimp
          apply(simp add: valid_fresh_ts_def)
          apply(elim conjE)
          apply(simp add: lastWr_def)
            apply (meson Max_ge Max_insert2 dual_order.strict_implies_order dual_order.trans finite_imageI)

           apply(elim conjE)
            apply(intro conjI)
             apply(intro allI impI)
          apply simp
            apply (simp add:  rev_app_def Let_def  update_modView_def update_mods_def update_thrView_def update_wa_def  update_trans_def)
            apply(intro conjI impI)
          apply(simp add: ts_oride_def)
          apply (metis assms(1) less_le_not_le own_ModView valid_fresh_ts_def)
                    apply blast
          apply blast
             apply(intro allI impI)
           apply clarsimp
           apply(case_tac "aa \<noteq> xa")

          using assms(1)
            apply simp
            apply(simp add:  upd_other_pres_last lastWr_def)
           apply clarsimp
            apply(case_tac "b \<noteq>  Max (tst ` writes_on \<sigma> xa)")
          using assms(1)
             apply simp
          apply(subgoal_tac "(xa, b) \<in> visible_writes \<sigma> t xa")
              apply (simp add: last_w_not_last_upd)
              apply(simp add: update_trans_def rev_app_def)
          apply (simp add:  update_modView_def update_mods_def update_thrView_def update_wa_def Let_def)
          apply(simp add: visible_writes_def)

          apply (simp add: lastWr_def)

            apply (simp add: lastWr_def visible_writes_def)
          apply clarsimp
          apply (metis wfs_def)
          using assms(1)
          apply(unfold wfs_def)
          apply clarsimp
          apply(simp add: valid_fresh_ts_def)
          apply(elim conjE)
            apply(simp add: lastWr_def)
            apply (elim conjE)
            apply clarsimp
              apply(simp add: update_trans_def rev_app_def)
          apply (simp add:  update_modView_def update_mods_def update_thrView_def update_wa_def Let_def)
          apply(intro impI conjI)

          apply (metis (no_types, lifting) Max.coboundedI finite.insertI finite_imageI insertI1 sup.absorb2 sup.strict_order_iff)
          using assms(1)
           by simp

lemma [simp]: "var(lastWr \<sigma> x) = x" by(simp add: lastWr_def)

lemma last_write_max: "wfs \<sigma> \<Longrightarrow> w \<in> writes_on \<sigma> x \<Longrightarrow> tst w \<le> tst (lastWr \<sigma> x)"
  by(simp add: lastWr_def)

lemma last_write_write_on [simp]: "wfs \<sigma> \<Longrightarrow>  lastWr \<sigma> x \<in> writes_on \<sigma> x"
  apply(simp add: lastWr_def )
  apply(case_tac "Max (tst`(writes_on \<sigma> x)) \<in> tst`(writes_on \<sigma> x)")
   defer apply simp
  using writes_on_var by fastforce

lemma lastWr_visible:
    "wfs \<sigma> \<Longrightarrow> lastWr \<sigma> x \<in> visible_writes \<sigma> t x"
  by (metis (no_types, lifting) CollectI last_write_max last_write_write_on visible_writes_def wfs_def)

lemma lastWr_read_pres: "lastWr (read_trans t b w \<sigma>) x = lastWr \<sigma> x"
  by(simp add: lastWr_def)

lemma write_to_different_var [simp]: "wfs \<sigma> \<Longrightarrow> var w \<noteq> x \<Longrightarrow> lastWr (write_trans t b w v \<sigma> ts') x = lastWr \<sigma> x"
  by(simp add: lastWr_def)

lemma [simp]: "wfs \<sigma> \<Longrightarrow> w = (lastWr \<sigma> x) \<Longrightarrow> valid_fresh_ts \<sigma> w ts' \<Longrightarrow>
                    lastWr (write_trans t b w v \<sigma> ts') x = (x, ts')"
  apply (simp add: valid_fresh_ts_def)
  by (simp add: lastWr_def max.strict_order_iff)

lemma [simp]: "wfs \<sigma> \<Longrightarrow> w \<noteq> lastWr \<sigma> x \<Longrightarrow> w \<in> writes_on \<sigma> x \<Longrightarrow> valid_fresh_ts \<sigma> w ts' \<Longrightarrow>
                    lastWr (write_trans t b w v \<sigma> ts') x = lastWr \<sigma> x"
  apply (subst lastWr_def) apply(case_tac "var w = x") apply simp_all defer
   apply (simp add: lastWr_def)
 apply (simp add: valid_fresh_ts_def)
  by (metis dual_order.order_iff_strict lastWr_def last_write_max last_write_write_on max.absorb2 prod.exhaust_sel sndI writes_on_var)

lemma [simp]: " wfs \<sigma> \<Longrightarrow> var w \<noteq> x \<Longrightarrow> value (write_trans t b w v \<sigma> ts')(lastWr \<sigma> x) = value \<sigma> (lastWr \<sigma> x)"
 by(simp add: value_def)

lemma [simp]: "wfs \<sigma> \<Longrightarrow> w = lastWr \<sigma> x \<Longrightarrow> valid_fresh_ts \<sigma> w ts' \<Longrightarrow>lastWr (update_trans t w v' \<sigma> ts') x = (x, ts')"
  apply (subst lastWr_def) apply simp
  by (simp add: lastWr_def less_eq_rat_def max.absorb1 valid_fresh_ts_def)

lemma [simp]: "wfs \<sigma> \<Longrightarrow> w \<noteq> lastWr \<sigma> x \<Longrightarrow> w \<in> writes_on \<sigma> x \<Longrightarrow> valid_fresh_ts \<sigma> w ts' \<Longrightarrow>
                    lastWr (update_trans t w v' \<sigma> ts') x = lastWr \<sigma> x"
  apply (subst lastWr_def) apply(case_tac "var w = x") apply simp_all
  by (metis lastWr_def last_write_max last_write_write_on less_eq_rat_def max_def prod.collapse snd_conv valid_fresh_ts_def writes_on_var)

lemma modView_lte_last: "wfs \<sigma> \<Longrightarrow> tst(modView \<sigma> w x) \<le> tst(lastWr \<sigma> x)"
  using last_write_max wfs_def by blast

definition "p_obs \<sigma> t x u \<equiv> \<exists> w. w \<in> visible_writes \<sigma> t x \<and> u = value \<sigma> w"

definition "d_obs \<sigma> view x u \<equiv> view x = lastWr \<sigma> x \<and> value \<sigma> (lastWr \<sigma> x) = u"

definition "d_obs_t \<sigma> t x u \<equiv> d_obs \<sigma> (thrView \<sigma> t) x u"

definition "c_obs \<sigma> x u t y v \<equiv>
              \<forall> w \<in> visible_writes \<sigma> t x. value \<sigma> w = u \<longrightarrow>
                         d_obs \<sigma> (modView \<sigma> w) y v \<and>
                         releasing \<sigma> w"

abbreviation p_obs_abbr:: "nat  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow>  surrey_state \<Rightarrow> bool" ("[_ \<approx>\<^sub>_ _] _" [100, 100, 100, 100])
  where "[x \<approx>\<^sub>t u] \<sigma> \<equiv> p_obs \<sigma> t x u"

abbreviation d_obs_abbr:: "nat  \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> surrey_state \<Rightarrow> bool" ("[_ =\<^sub>_ _] _" [100, 100, 100, 100])
  where "[x =\<^sub>t u] \<sigma> \<equiv> d_obs_t \<sigma> t x u"

abbreviation c_obs_abbr:: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> surrey_state \<Rightarrow> bool" ("[_ = _]\<lparr>_ =\<^sub>_ _ \<rparr> _" [100, 100, 100, 100, 100, 100])
  where "[x = u]\<lparr>y =\<^sub>t v\<rparr> \<sigma> \<equiv> c_obs \<sigma> x u t y v"

definition "covered \<sigma> x \<equiv> \<forall> w .  w \<in> writes_on \<sigma> x \<and> write_available \<sigma> w \<longrightarrow> w = lastWr \<sigma> x"

definition "covered_v \<sigma> x v \<equiv> \<forall> w .  w \<in> writes_on \<sigma> x \<and> write_available \<sigma> w \<longrightarrow> w = lastWr \<sigma> x \<and> value \<sigma> w = v"

abbreviation covered_v_abbr:: "L \<Rightarrow> V  \<Rightarrow> surrey_state \<Rightarrow> bool" ("cvd[_, _] _" [100, 100,100])
  where "cvd[x, u] \<sigma> \<equiv> covered_v \<sigma> x u"

definition "mo w w'\<equiv> var(w) = var(w') \<and> tst(w) < tst(w')"

definition "enc \<sigma> view x u \<equiv> \<exists> w . w \<in> writes_on \<sigma> x \<and> tst(w) \<le> tst(view x) \<and> value \<sigma> w = u"

definition "enc_t \<sigma> t x u \<equiv>  enc \<sigma> (thrView \<sigma> t) x u"

definition "p_vorder \<sigma> u x v \<equiv> \<exists> w w'.  w \<in> writes_on \<sigma> x  \<and>  w' \<in> writes_on \<sigma> x \<and>
                                        value \<sigma> w = u \<and> value \<sigma> w' = v \<and>
                                        mo w w' "

definition "d_vorder \<sigma> u x v \<equiv> (\<forall> w w'.  w \<in> writes_on \<sigma> x  \<and>  w' \<in> writes_on \<sigma> x \<and>
                                        value \<sigma> w = u \<and> value \<sigma> w' = v \<longrightarrow>
                                        mo w w') \<and> p_vorder \<sigma> u x v"

definition "init_val \<sigma> x v \<equiv>
  \<exists> w . w \<in> writes_on \<sigma> x \<and>
        (\<forall>w'\<in> writes_on \<sigma> x .  w \<noteq> w' \<longrightarrow>  mo w w') \<and>
        value \<sigma> w = v"

definition "amo \<sigma> x u \<equiv> \<not> p_vorder \<sigma> u x u"

definition "no_val \<sigma> x i u \<equiv> init_val \<sigma> x i \<and> \<not> p_vorder \<sigma> i x u"

definition "last_val \<sigma> x u i \<equiv>
                init_val \<sigma> x i \<and> p_vorder \<sigma> i x u
                \<and> (\<forall> w. w \<noteq> u \<longrightarrow> \<not> p_vorder \<sigma> u x w)"

abbreviation p_vorder_abbr:: "V  \<Rightarrow> L \<Rightarrow> V \<Rightarrow>  surrey_state \<Rightarrow> bool" ("[_ \<leadsto>\<^sub>_ _] _" [100,100,100,100])
  where "[u \<leadsto>\<^sub>x v] \<sigma> \<equiv> p_vorder \<sigma> u x v"

abbreviation d_vorder_abbr:: "V  \<Rightarrow> L \<Rightarrow> V \<Rightarrow>  surrey_state \<Rightarrow> bool" ("[_ \<hookrightarrow>\<^sub>_ _] _" [100,100,100,100])
  where "[u \<hookrightarrow>\<^sub>x v] \<sigma> \<equiv> d_vorder \<sigma> u x v"

abbreviation amo_abbr:: "L \<Rightarrow> V \<Rightarrow>  surrey_state \<Rightarrow> bool" ("[\<one>\<^sub>_ _] _" [100,100,100])
  where "[\<one>\<^sub>x u] \<sigma> \<equiv> amo \<sigma> x u"

abbreviation no_abbr:: "L \<Rightarrow> V \<Rightarrow> V \<Rightarrow> surrey_state \<Rightarrow> bool" ("[\<zero>\<^sub>_ _]\<^sub>_ _" [100,100,100,100])
  where "[\<zero>\<^sub>x u]\<^sub>i \<sigma> \<equiv> no_val \<sigma> x i u"

abbreviation enc_abbr:: "L \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("[en _ _]\<^sub>_ _" [100,100,100,100])
  where "[en x u]\<^sub>t \<sigma> \<equiv> enc_t \<sigma> t x u"

abbreviation last_abbr:: "L \<Rightarrow> V \<Rightarrow> V \<Rightarrow> T \<Rightarrow> surrey_state \<Rightarrow> bool" ("[last _ _ _]\<^sub>_ _" [100, 100,100,100,100])
  where "[last x i u]\<^sub>t \<sigma> \<equiv> last_val \<sigma> x u i"

abbreviation init_abbr:: "L \<Rightarrow> V  \<Rightarrow> surrey_state \<Rightarrow> bool" ("[init _ _] _" [100, 100,100])
  where "[init x v] \<sigma> \<equiv> init_val \<sigma> x v"

lemma d_obs_lastWr_visible:
  "wfs \<sigma> \<Longrightarrow> [x =\<^sub>t u] \<sigma> \<Longrightarrow> w \<in> visible_writes \<sigma> t x \<Longrightarrow> w = lastWr \<sigma> x"
  apply (simp add: d_obs_def d_obs_t_def lastWr_def visible_writes_def, auto)
  by (metis dual_order.antisym lastWr_def last_write_max last_write_write_on prod.collapse writes_on_var)

lemma d_obs_implies_p_obs:
  "wfs \<sigma> \<Longrightarrow> [x =\<^sub>t u] \<sigma> \<Longrightarrow> [x \<approx>\<^sub>t u] \<sigma>"
  apply(simp add: d_obs_t_def d_obs_def p_obs_def) using lastWr_visible
  by (metis lastWr_def)

lemma d_obs_p_obs_agree: "wfs \<sigma> \<Longrightarrow> [x =\<^sub>t u] \<sigma> \<Longrightarrow> [x \<approx>\<^sub>t v] \<sigma> \<Longrightarrow> u = v"
  apply(unfold p_obs_def d_obs_t_def d_obs_def visible_writes_def)apply clarsimp
  by (metis eq_snd_iff fst_conv lastWr_def last_write_max leD order.not_eq_order_implies_strict writes_on_var)

lemma not_p_obs_implies_c_obs: "\<not> [x \<approx>\<^sub>t u] \<sigma> \<Longrightarrow> [x = u]\<lparr>y =\<^sub>t v\<rparr> \<sigma>"
  by(auto simp add: p_obs_def c_obs_def)

lemma "[x =\<^sub>t n] \<sigma> \<Longrightarrow> [x =\<^sub>t' m] \<sigma> \<Longrightarrow> m = n"
  by (simp add: d_obs_def d_obs_t_def)

end


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory signed_div
imports "../CTranslation"
begin

install_C_file "signed_div.c"

context signed_div
begin

lemma f_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL f(5, -1) \<lbrace> \<acute>ret__int = -5 \<rbrace>"
  apply vcg
  apply (clarsimp simp: sdiv_word_def sdiv_int_def)
  done

lemma f_overflow:
  shows "\<lbrakk> a_' s = of_int (- (2^31)); b_' s = -1 \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> \<langle> Call f_'proc ,Normal s\<rangle> \<Rightarrow> Fault SignedArithmetic"
  apply (rule exec.Call [where \<Gamma>=\<Gamma>, OF f_impl, simplified f_body_def creturn_def])
  apply (rule exec.CatchMiss)
  apply (subst exec.simps, clarsimp simp del: word_neq_0_conv simp: sdiv_word_def sdiv_int_def)+
  apply simp
  done

lemma g_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL g(-5, 10) \<lbrace> \<acute>ret__int = -5 \<rbrace>"
  apply vcg
  apply (clarsimp simp: smod_word_def smod_int_def sdiv_int_def)
  done

lemma h_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL h(5, -1) \<lbrace> \<acute>ret__int = 0 \<rbrace>"
  apply vcg
  apply (simp add: word_div_def uint_word_ariths)
  done

(* FIXME: f! *)
lemma i_result:
  "\<Gamma> \<turnstile> \<lbrace> True \<rbrace> \<acute>ret__int :== CALL f(5, -1) \<lbrace> \<acute>ret__int = -5 \<rbrace>"
  apply vcg
  apply (clarsimp simp: sdiv_word_def sdiv_int_def)
  done

end

end


(*  Title:      JinjaThreads/BV/BVConform.thy
    Author:     Cornelia Pusch, Gerwin Klein, Andreas Lochbihler

The invariant for the type safety proof.
*)

header {* \isaheader{BV Type Safety Invariant} *}

theory BVConform
imports
  BVSpec
  "../JVM/JVMExec"
begin

context JVM_heap_base begin

definition confT :: "'c prog \<Rightarrow> 'heap \<Rightarrow> 'addr val \<Rightarrow> ty err \<Rightarrow> bool" ("_,_ |- _ :<=T _" [51,51,51,51] 50)
where
  "P,h |- v :<=T E \<equiv> case E of Err \<Rightarrow> True | OK T \<Rightarrow> P,h \<turnstile> v :\<le> T"

notation (xsymbols)
  confT ("_,_ \<turnstile> _ :\<le>\<^sub>\<top> _" [51,51,51,51] 50)

abbreviation confTs :: "'c prog \<Rightarrow> 'heap \<Rightarrow> 'addr val list \<Rightarrow> ty\<^sub>l \<Rightarrow> bool"
            ("_,_ |- _ [:<=T] _" [51,51,51,51] 50)
where
  "P,h |- vs [:<=T] Ts \<equiv> list_all2 (confT P h) vs Ts"

notation (xsymbols)
  confTs ("_,_ \<turnstile> _ [:\<le>\<^sub>\<top>] _" [51,51,51,51] 50)

definition conf_f :: "'addr jvm_prog \<Rightarrow> 'heap \<Rightarrow> ty\<^sub>i \<Rightarrow> 'addr bytecode \<Rightarrow> 'addr frame \<Rightarrow> bool"
where
  "conf_f P h \<equiv> \<lambda>(ST,LT) is (stk,loc,C,M,pc). P,h \<turnstile> stk [:\<le>] ST \<and> P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT \<and> pc < size is"

primrec conf_fs :: "['addr jvm_prog,'heap,ty\<^sub>P,mname,nat,ty,'addr frame list] \<Rightarrow> bool"
where
  "conf_fs P h \<Phi> M\<^sub>0 n\<^sub>0 T\<^sub>0 [] = True"

| "conf_fs P h \<Phi> M\<^sub>0 n\<^sub>0 T\<^sub>0 (f#frs) =
  (let (stk,loc,C,M,pc) = f in
  (\<exists>ST LT Ts T mxs mxl\<^sub>0 is xt.
    \<Phi> C M ! pc = Some (ST,LT) \<and>
    (P \<turnstile> C sees M:Ts \<rightarrow> T = \<lfloor>(mxs,mxl\<^sub>0,is,xt)\<rfloor> in C) \<and>
    (\<exists>Ts' T' D m D'.
       is!pc = (Invoke M\<^sub>0 n\<^sub>0) \<and> class_type_of' (ST!n\<^sub>0) = \<lfloor>D\<rfloor> \<and> P \<turnstile> D sees M\<^sub>0:Ts' \<rightarrow> T' = m in D' \<and> P \<turnstile> T\<^sub>0 \<le> T') \<and>
    conf_f P h (ST, LT) is f \<and> conf_fs P h \<Phi> M (size Ts) T frs))"

primrec conf_xcp :: "'addr jvm_prog \<Rightarrow> 'heap \<Rightarrow> 'addr option \<Rightarrow> 'addr instr \<Rightarrow> bool" where
  "conf_xcp P h None i = True"
| "conf_xcp P h \<lfloor>a\<rfloor>   i = (\<exists>D. typeof_addr h a = \<lfloor>Class_type D\<rfloor> \<and> P \<turnstile> D \<preceq>\<^sup>* Throwable \<and>
                               (\<forall>D'. P \<turnstile> D \<preceq>\<^sup>* D' \<longrightarrow> is_relevant_class i P D'))"

end

context JVM_heap_conf_base begin

definition correct_state :: "[ty\<^sub>P,'thread_id,('addr, 'heap) jvm_state] \<Rightarrow> bool"
                  ("_ |- _:_ [ok]"  [61,0,0] 61)
where
  "correct_state \<Phi> t \<equiv> \<lambda>(xp,h,frs).
        P,h \<turnstile> t \<surd>t \<and> hconf h \<and> preallocated h \<and>
        (case frs of
             [] \<Rightarrow> True
             | (f#fs) \<Rightarrow>
             (let (stk,loc,C,M,pc) = f
              in \<exists>Ts T mxs mxl\<^sub>0 is xt \<tau>.
                    (P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>(mxs,mxl\<^sub>0,is,xt)\<rfloor> in C) \<and>
                    \<Phi> C M ! pc = Some \<tau> \<and>
                    conf_f P h \<tau> is f \<and> conf_fs P h \<Phi> M (size Ts) T fs \<and>
                    conf_xcp P h xp (is ! pc) ))"

notation (xsymbols)
 correct_state ("_ \<turnstile> _:_ \<surd>"  [61,0,0] 61)

end

context JVM_heap_base begin

lemma conf_f_def2:
  "conf_f P h (ST,LT) is (stk,loc,C,M,pc) \<equiv>
  P,h \<turnstile> stk [:\<le>] ST \<and> P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT \<and> pc < size is"
  by (simp add: conf_f_def)

section {* Values and @{text "\<top>"} *}

lemma confT_Err [iff]: "P,h \<turnstile> x :\<le>\<^sub>\<top> Err"
  by (simp add: confT_def)

lemma confT_OK [iff]:  "P,h \<turnstile> x :\<le>\<^sub>\<top> OK T = (P,h \<turnstile> x :\<le> T)"
  by (simp add: confT_def)

lemma confT_cases:
  "P,h \<turnstile> x :\<le>\<^sub>\<top> X = (X = Err \<or> (\<exists>T. X = OK T \<and> P,h \<turnstile> x :\<le> T))"
  by (cases X) auto

lemma confT_widen [intro?, trans]:
  "\<lbrakk> P,h \<turnstile> x :\<le>\<^sub>\<top> T; P \<turnstile> T \<le>\<^sub>\<top> T' \<rbrakk> \<Longrightarrow> P,h \<turnstile> x :\<le>\<^sub>\<top> T'"
  by (cases T', auto intro: conf_widen)

end

context JVM_heap begin

lemma confT_hext [intro?, trans]:
  "\<lbrakk> P,h \<turnstile> x :\<le>\<^sub>\<top> T; h \<unlhd> h' \<rbrakk> \<Longrightarrow> P,h' \<turnstile> x :\<le>\<^sub>\<top> T"
  by (cases T) (blast intro: conf_hext)+

end

section {* Stack and Registers *}

context JVM_heap_base begin

lemma confTs_Cons1 [iff]:
  "P,h \<turnstile> x # xs [:\<le>\<^sub>\<top>] Ts = (\<exists>z zs. Ts = z # zs \<and> P,h \<turnstile> x :\<le>\<^sub>\<top> z \<and> list_all2 (confT P h) xs zs)"
by(rule list_all2_Cons1)

lemma confTs_confT_sup:
  "\<lbrakk> P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT; n < size LT; LT!n = OK T; P \<turnstile> T \<le> T' \<rbrakk>
  \<Longrightarrow> P,h \<turnstile> (loc!n) :\<le> T'"
  apply (frule list_all2_lengthD)
  apply (drule list_all2_nthD, simp)
  apply simp
  apply (erule conf_widen, assumption+)
  done

lemma confTs_widen [intro?, trans]:
  "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT \<Longrightarrow> P \<turnstile> LT [\<le>\<^sub>\<top>] LT' \<Longrightarrow> P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT'"
  by (rule list_all2_trans, rule confT_widen)

lemma confTs_map [iff]:
  "(P,h \<turnstile> vs [:\<le>\<^sub>\<top>] map OK Ts) = (P,h \<turnstile> vs [:\<le>] Ts)"
  by (induct Ts arbitrary: vs) (auto simp add: list_all2_Cons2)

lemma reg_widen_Err [iff]:
  "(P \<turnstile> replicate n Err [\<le>\<^sub>\<top>] LT) = (LT = replicate n Err)"
  by (induct n arbitrary: LT) (auto simp add: list_all2_Cons1)

end

context JVM_heap begin

lemma confTs_hext [intro?]:
  "P,h \<turnstile> loc [:\<le>\<^sub>\<top>] LT \<Longrightarrow> h \<unlhd> h' \<Longrightarrow> P,h' \<turnstile> loc [:\<le>\<^sub>\<top>] LT"
  by (fast elim: list_all2_mono confT_hext)

section {* correct-frames *}

declare fun_upd_apply[simp del]

lemma conf_f_hext:
  "\<lbrakk> conf_f P h \<Phi> M f; h \<unlhd> h' \<rbrakk> \<Longrightarrow> conf_f P h' \<Phi> M f"
by(cases f, cases \<Phi>, auto simp add: conf_f_def intro: confs_hext confTs_hext)

lemma conf_fs_hext:
  "\<lbrakk> conf_fs P h \<Phi> M n T\<^sub>r frs; h \<unlhd> h' \<rbrakk> \<Longrightarrow> conf_fs P h' \<Phi> M n T\<^sub>r frs"
apply (induct frs arbitrary: M n T\<^sub>r)
 apply simp
apply clarify
apply (simp (no_asm_use))
apply clarify
apply (unfold conf_f_def)
apply (simp (no_asm_use) split: split_if_asm)
apply (fast elim!: confs_hext confTs_hext)+
done

declare fun_upd_apply[simp]

lemma conf_xcp_hext:
  "\<lbrakk> conf_xcp P h xcp i; h \<unlhd> h' \<rbrakk> \<Longrightarrow> conf_xcp P h' xcp i"
by(cases xcp)(auto elim: typeof_addr_hext_mono)

end

context JVM_heap_conf_base begin

lemmas defs1 = correct_state_def conf_f_def wt_instr_def eff_def norm_eff_def app_def xcpt_app_def

lemma correct_state_impl_Some_method:
  "\<Phi> \<turnstile> t: (None, h, (stk,loc,C,M,pc)#frs)\<surd>
  \<Longrightarrow> \<exists>m Ts T. P \<turnstile> C sees M:Ts\<rightarrow>T = \<lfloor>m\<rfloor> in C"
  by(fastforce simp add: defs1)

end

context JVM_heap_conf_base' begin

end

end


theory Proto_Sepref_Borrow
imports Sepref
begin

  (* Simple-Minded borrowing for sepref.

    Idea: When we can prove that we have not changed an object abstractly,
      and its concrete value is still the same, we can reinstantiate it
      after it has been invalidated.

  *)

  text \<open>Operation to reinstantiate dst, by moving source.
    Implementations will also require a proof that the concrete objects are equal!
  \<close>
  definition "unborrow src dst \<equiv> doN {ASSERT (src=dst); RETURN ()}"
  sepref_register unborrow

  lemma unborrow_correct[refine_vcg]: "s=d \<Longrightarrow> unborrow s d \<le> SPEC (\<lambda>r. r=()) (\<lambda>_. 0)"
    unfolding unborrow_def SPEC_def ASSERT_def iASSERT_def apply simp by (auto simp: RETURNT_def)

  lemma unborrow_rule[sepref_comb_rules]:
    assumes FRAME: "\<Gamma> \<turnstile> hn_ctxt R src srci ** hn_invalid R dst dsti ** F"
    assumes [simp]: "vassn_tag \<Gamma> \<Longrightarrow> srci = dsti"
    shows "hn_refine \<Gamma> (return ()::unit llM) (hn_invalid R src srci ** hn_ctxt R dst dsti ** F) unit_assn (unborrow$src$dst)"
    apply (rule hn_refine_vassn_tagI)
    apply (rule hn_refine_cons_pre[OF _ FRAME])
    unfolding unborrow_def apply (simp only: APP_def)
    apply (rule hn_refineI'')
    apply (simp add: refine_pw_simps)
    unfolding hn_ctxt_def invalid_assn_def pure_def
    by vcg'

  lemma unborrow_nofail[refine_pw_simps]: "nofailT (unborrow a b) \<longleftrightarrow> a=b" by (auto simp: unborrow_def refine_pw_simps)

  text \<open>Assertion that adds constraint on concrete value. Used to carry through concrete equalities.\<close>
  definition "cnc_assn \<phi> A a c \<equiv> \<up>(\<phi> c) ** A a c"

  lemma norm_ceq_assn[named_ss sepref_frame_normrel]: "hn_ctxt (cnc_assn \<phi> A) a c = (\<up>(\<phi> c) ** hn_ctxt A a c)"
    unfolding hn_ctxt_def cnc_assn_def by simp

  lemma cnc_assn_prod_conv[named_ss sepref_frame_normrel]:
    shows "\<And>A B \<phi>. A \<times>\<^sub>a cnc_assn \<phi> B = cnc_assn (\<phi> o snd) (A\<times>\<^sub>aB)"
      and "\<And>A B \<phi>. cnc_assn \<phi> A \<times>\<^sub>a B = cnc_assn (\<phi> o fst) (A\<times>\<^sub>aB)"
    unfolding cnc_assn_def
    by (auto simp: sep_algebra_simps fun_eq_iff)

  (* BEWARE: This only only holds without time, would need to have
     to add (infinite?) time credits to premise HT

  text \<open>Rule to prove a-posteriori constraint (Only useful for simple programs.
    TODO: More partial Hoare-triples would make this more useful, e.g.,
      we could assume assertions, preconditions, and even termination!
  )\<close>
  lemma hnr_ceq_assnI:
    assumes HNR: "hn_refine \<Gamma> c \<Gamma>' R a"
    assumes HT: "llvm_htriple \<Gamma> c (\<lambda>x'. \<up>(\<phi> x') ** sep_true)"
    shows "hn_refine \<Gamma> c \<Gamma>' (cnc_assn \<phi> R) a"
  proof (rule hn_refine_nofailI)
    assume NF: "nofailT a"

    show ?thesis
      apply (rule hn_refineI)
      apply (rule cons_post_rule)
      apply (rule htriple_conj_pure[OF HNR[THEN hn_refineD[OF _ NF]] HT])
      apply (auto simp: sep_algebra_simps pred_lift_extract_simps cnc_assn_def)
      done

  qed
  *)

end


theory IICF_Misc
imports "../Sepref"
begin

context
  fixes t ::  "nat"
begin
  definition "mop_plus a b =SPECT [a +  b \<mapsto> t]"

  lemma mop_plus: "\<And>tt. tt \<le> lst (SPECT [ a +  b \<mapsto> t]) Q \<Longrightarrow> tt
           \<le> lst (mop_plus a b) Q" unfolding mop_plus_def by simp

  sepref_register "mop_plus"
  print_theorems
end

lemma hn_refine_plus[sepref_fr_rules]: " hn_refine (hn_val Id a' a * hn_val Id b' b)
           (ureturn (a +  b))
       (hn_val Id a' a * hn_val Id b' b)
       (pure Id) (((PR_CONST (mop_plus t)) $ a' $ b'))"
  unfolding hn_refine_def apply (auto simp:   mult.assoc  execute_ureturn pure_def hn_ctxt_def)
  by (auto simp: top_assn_rule zero_enat_def relH_def  mop_plus_def elim: pureD )

context
  fixes t ::  "nat"
begin
  definition "mop_min a b =SPECT [min a b \<mapsto> t]"

  lemma mop_min: "\<And>tt. tt \<le> lst (SPECT [ min a b \<mapsto> t]) Q \<Longrightarrow> tt
           \<le> lst (mop_min a b) Q" unfolding mop_min_def by simp

  sepref_register "mop_min"
  print_theorems
end

lemma hn_refine_min[sepref_fr_rules]: " hn_refine (hn_val Id a' a * hn_val Id b' b)
           (ureturn (min a b))
       (hn_val Id a' a * hn_val Id b' b)
       (pure Id) (((PR_CONST (mop_min t)) $ a' $ b'))"
  unfolding hn_refine_def apply (auto simp:   mult.assoc  execute_ureturn pure_def hn_ctxt_def)
  by (auto simp: top_assn_rule zero_enat_def relH_def  mop_min_def elim: pureD )

context
  fixes t ::  "nat"
begin
  definition "mop_swap e =SPECT [prod.swap e \<mapsto> t]"

  lemma mop_swap: "\<And>tt. tt \<le> lst (SPECT [ prod.swap e \<mapsto> t]) Q \<Longrightarrow> tt
           \<le> lst (mop_swap e) Q" unfolding mop_swap_def by simp

  sepref_register "mop_swap"
  print_theorems
end

lemma hn_refine_swap[sepref_fr_rules]: " hn_refine (hn_ctxt (nat_assn \<times>\<^sub>a nat_assn) e' e)
           (ureturn (prod.swap e))
       (hn_ctxt (nat_assn \<times>\<^sub>a nat_assn) e' e)
       (nat_assn \<times>\<^sub>a nat_assn) (((PR_CONST (mop_swap t)) $ e'))"
  unfolding hn_refine_def apply (auto simp:      execute_ureturn    )
   apply (auto simp: top_assn_rule zero_enat_def relH_def prod.swap_def mop_swap_def elim: pureD )
  apply(rule exI[where x=0]) apply auto
  by (smt BNF_Greatest_Fixpoint.IdD IdI entails_def entails_true hn_ctxt_def mult.left_neutral pure_assn_rule pure_def pure_true)

end


(*  Title:      JinjaThreads/Framework/FWLifting.thy
    Author:     Andreas Lochbihler
*)

section \<open>Lifting of thread-local properties to the multithreaded case\<close>

theory FWLifting
imports
  FWWellform
begin

text\<open>Lifting for properties that only involve thread-local state information and the shared memory.\<close>

definition
  ts_ok :: "('t \<Rightarrow> 'x \<Rightarrow> 'm \<Rightarrow> bool) \<Rightarrow> ('l, 't,'x) thread_info \<Rightarrow> 'm \<Rightarrow> bool"
where
  "\<And>ln. ts_ok P ts m \<equiv> \<forall>t. case (ts t) of None \<Rightarrow> True | \<lfloor>(x, ln)\<rfloor> \<Rightarrow> P t x m"

lemma ts_okI:
  "\<lbrakk> \<And>t x ln. ts t = \<lfloor>(x, ln)\<rfloor> \<Longrightarrow> P t x m \<rbrakk> \<Longrightarrow> ts_ok P ts m"
by(auto simp add: ts_ok_def)

lemma ts_okE:
  "\<lbrakk> ts_ok P ts m; \<lbrakk> \<And>t x ln. ts t = \<lfloor>(x, ln)\<rfloor> \<Longrightarrow> P t x m \<rbrakk> \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
by(auto simp add: ts_ok_def)

lemma ts_okD:
  "\<And>ln. \<lbrakk> ts_ok P ts m; ts t = \<lfloor>(x, ln)\<rfloor> \<rbrakk> \<Longrightarrow> P t x m"
by(auto simp add: ts_ok_def)

lemma ts_ok_True [simp]:
  "ts_ok (\<lambda>t m x. True) ts m"
by(auto intro: ts_okI)

lemma ts_ok_conj:
  "ts_ok (\<lambda>t x m. P t x m \<and> Q t x m) = (\<lambda>ts m. ts_ok P ts m \<and> ts_ok Q ts m)"
by(auto intro: ts_okI intro!: ext dest: ts_okD)

lemma ts_ok_mono:
  "\<lbrakk> ts_ok P ts m; \<And>t x. P t x m \<Longrightarrow> Q t x m \<rbrakk> \<Longrightarrow> ts_ok Q ts m"
by(auto intro!: ts_okI dest: ts_okD)

text\<open>Lifting for properites, that also require additional data that does not change during execution\<close>

definition
  ts_inv :: "('i \<Rightarrow> 't \<Rightarrow> 'x \<Rightarrow> 'm \<Rightarrow> bool) \<Rightarrow> ('t \<rightharpoonup> 'i) \<Rightarrow> ('l,'t,'x) thread_info \<Rightarrow> 'm \<Rightarrow> bool"
where
  "\<And>ln. ts_inv P I ts m \<equiv> \<forall>t. case (ts t) of None \<Rightarrow> True | \<lfloor>(x, ln)\<rfloor> \<Rightarrow> \<exists>i. I t = \<lfloor>i\<rfloor> \<and> P i t x m"

lemma ts_invI:
  "\<lbrakk> \<And>t x ln. ts t = \<lfloor>(x, ln)\<rfloor> \<Longrightarrow> \<exists>i. I t = \<lfloor>i\<rfloor> \<and> P i t x m \<rbrakk> \<Longrightarrow> ts_inv P I ts m"
by(simp add: ts_inv_def)

lemma ts_invE:
  "\<lbrakk> ts_inv P I ts m; \<forall>t x ln. ts t = \<lfloor>(x, ln)\<rfloor> \<longrightarrow> (\<exists>i. I t = \<lfloor>i\<rfloor> \<and> P i t x m) \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
by(auto simp add: ts_inv_def)

lemma ts_invD:
  "\<And>ln. \<lbrakk> ts_inv P I ts m; ts t = \<lfloor>(x, ln)\<rfloor> \<rbrakk> \<Longrightarrow> \<exists>i. I t = \<lfloor>i\<rfloor> \<and> P i t x m"
by(auto simp add: ts_inv_def)

text \<open>Wellformedness properties for lifting\<close>

definition
  ts_inv_ok :: "('l,'t,'x) thread_info \<Rightarrow> ('t \<rightharpoonup> 'i) \<Rightarrow> bool"
where
  "ts_inv_ok ts I \<equiv> \<forall>t. ts t = None \<longleftrightarrow> I t = None"

lemma ts_inv_okI:
  "(\<And>t. ts t = None \<longleftrightarrow> I t = None) \<Longrightarrow> ts_inv_ok ts I"
by(clarsimp simp add: ts_inv_ok_def)

lemma ts_inv_okI2:
  "(\<And>t. (\<exists>v. ts t = \<lfloor>v\<rfloor>) \<longleftrightarrow> (\<exists>v. I t = \<lfloor>v\<rfloor>)) \<Longrightarrow> ts_inv_ok ts I"
by(force simp add: ts_inv_ok_def)

lemma ts_inv_okE:
  "\<lbrakk> ts_inv_ok ts I; \<forall>t. ts t = None \<longleftrightarrow> I t = None \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by(force simp add: ts_inv_ok_def)

lemma ts_inv_okE2:
  "\<lbrakk> ts_inv_ok ts I; \<forall>t. (\<exists>v. ts t = \<lfloor>v\<rfloor>) \<longleftrightarrow> (\<exists>v. I t = \<lfloor>v\<rfloor>) \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P"
by(force simp add: ts_inv_ok_def)

lemma ts_inv_okD:
  "ts_inv_ok ts I \<Longrightarrow> (ts t = None) \<longleftrightarrow> (I t = None)"
by(erule ts_inv_okE, blast)

lemma ts_inv_okD2:
  "ts_inv_ok ts I \<Longrightarrow> (\<exists>v. ts t = \<lfloor>v\<rfloor>) \<longleftrightarrow> (\<exists>v. I t = \<lfloor>v\<rfloor>)"
by(erule ts_inv_okE2, blast)

lemma ts_inv_ok_conv_dom_eq:
  "ts_inv_ok ts I \<longleftrightarrow> (dom ts = dom I)"
proof -
  have "ts_inv_ok ts I \<longleftrightarrow> (\<forall>t. ts t = None \<longleftrightarrow> I t = None)"
    unfolding ts_inv_ok_def by blast
  also have "\<dots> \<longleftrightarrow> (\<forall>t. t \<in> - dom ts \<longleftrightarrow> t \<in> - dom I)" by(force)
  also have "\<dots> \<longleftrightarrow> dom ts = dom I" by auto
  finally show ?thesis .
qed

lemma ts_inv_ok_upd_ts:
  "\<lbrakk> ts t = \<lfloor>x\<rfloor>; ts_inv_ok ts I \<rbrakk> \<Longrightarrow> ts_inv_ok (ts(t \<mapsto> x')) I"
by(auto dest!: ts_inv_okD intro!: ts_inv_okI split: if_splits)

lemma ts_inv_upd_map_option:
  assumes "ts_inv P I ts m"
  and "\<And>x ln. ts t = \<lfloor>(x, ln)\<rfloor> \<Longrightarrow> P (the (I t)) t (fst (f (x, ln))) m"
  shows "ts_inv P I (ts(t := (map_option f (ts t)))) m"
using assms
by(fastforce intro!: ts_invI split: if_split_asm dest: ts_invD)

fun upd_inv :: "('t \<rightharpoonup> 'i) \<Rightarrow> ('i \<Rightarrow> 't \<Rightarrow> 'x \<Rightarrow> 'm \<Rightarrow> bool) \<Rightarrow> ('t,'x,'m) new_thread_action \<Rightarrow> ('t \<rightharpoonup> 'i)"
where
  "upd_inv I P (NewThread t x m) = I(t \<mapsto> SOME i. P i t x m)"
| "upd_inv I P _ = I"

fun upd_invs :: "('t \<rightharpoonup> 'i) \<Rightarrow> ('i \<Rightarrow> 't \<Rightarrow> 'x \<Rightarrow> 'm \<Rightarrow> bool) \<Rightarrow> ('t,'x,'m) new_thread_action list \<Rightarrow> ('t \<rightharpoonup> 'i)"
where
  "upd_invs I P [] = I"
| "upd_invs I P (ta#tas) = upd_invs (upd_inv I P ta) P tas"

lemma upd_invs_append [simp]:
  "upd_invs I P (xs @ ys) = upd_invs (upd_invs I P xs) P ys"
by(induct xs arbitrary: I)(auto)

lemma ts_inv_ok_upd_inv':
 "ts_inv_ok ts I \<Longrightarrow> ts_inv_ok (redT_updT' ts ta) (upd_inv I P ta)"
by(cases ta)(auto intro!: ts_inv_okI elim: ts_inv_okD del: iffI)

lemma ts_inv_ok_upd_invs':
  "ts_inv_ok ts I \<Longrightarrow> ts_inv_ok (redT_updTs' ts tas) (upd_invs I P tas)"
proof(induct tas arbitrary: ts I)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS I)
  note IH = \<open>\<And>ts I. ts_inv_ok ts I \<Longrightarrow> ts_inv_ok (redT_updTs' ts TAS) (upd_invs I P TAS)\<close>
  note esok = \<open>ts_inv_ok TS I\<close>
  from esok have "ts_inv_ok (redT_updT' TS TA) (upd_inv I P TA)"
    by -(rule ts_inv_ok_upd_inv')
  hence "ts_inv_ok (redT_updTs' (redT_updT' TS TA) TAS) (upd_invs (upd_inv I P TA) P TAS)"
    by (rule IH)
  thus ?case by simp
qed

lemma ts_inv_ok_upd_inv:
 "ts_inv_ok ts I \<Longrightarrow> ts_inv_ok (redT_updT ts ta) (upd_inv I P ta)"
apply(cases ta)
apply(auto intro!: ts_inv_okI elim: ts_inv_okD del: iffI)
done

lemma ts_inv_ok_upd_invs:
  "ts_inv_ok ts I \<Longrightarrow> ts_inv_ok (redT_updTs ts tas) (upd_invs I P tas)"
proof(induct tas arbitrary: ts I)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS I)
  note IH = \<open>\<And>ts I. ts_inv_ok ts I \<Longrightarrow> ts_inv_ok (redT_updTs ts TAS) (upd_invs I P TAS)\<close>
  note esok = \<open>ts_inv_ok TS I\<close>
  from esok have "ts_inv_ok (redT_updT TS TA) (upd_inv I P TA)"
    by -(rule ts_inv_ok_upd_inv)
  hence "ts_inv_ok (redT_updTs (redT_updT TS TA) TAS) (upd_invs (upd_inv I P TA) P TAS)"
    by (rule IH)
  thus ?case by simp
qed

lemma ts_inv_ok_inv_ext_upd_inv:
  "\<lbrakk> ts_inv_ok ts I; thread_ok ts ta \<rbrakk> \<Longrightarrow> I \<subseteq>\<^sub>m upd_inv I P ta"
by(cases ta)(auto intro!: map_le_same_upd dest: ts_inv_okD)

lemma ts_inv_ok_inv_ext_upd_invs:
  "\<lbrakk> ts_inv_ok ts I; thread_oks ts tas\<rbrakk>
  \<Longrightarrow> I \<subseteq>\<^sub>m upd_invs I P tas"
proof(induct tas arbitrary: ts I)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS I)
  note IH = \<open>\<And>ts I. \<lbrakk> ts_inv_ok ts I; thread_oks ts TAS\<rbrakk> \<Longrightarrow> I \<subseteq>\<^sub>m upd_invs I P TAS\<close>
  note esinv = \<open>ts_inv_ok TS I\<close>
  note cct = \<open>thread_oks TS (TA # TAS)\<close>
  from esinv cct have "I \<subseteq>\<^sub>m upd_inv I P TA"
    by(auto intro: ts_inv_ok_inv_ext_upd_inv)
  also from esinv cct have "ts_inv_ok (redT_updT' TS TA) (upd_inv I P TA)"
    by(auto intro: ts_inv_ok_upd_inv')
  with cct have "upd_inv I P TA \<subseteq>\<^sub>m upd_invs (upd_inv I P TA) P TAS"
    by(auto intro: IH)
  finally show ?case by simp
qed

lemma upd_invs_Some:
  "\<lbrakk> thread_oks ts tas; I t = \<lfloor>i\<rfloor>; ts t = \<lfloor>x\<rfloor> \<rbrakk> \<Longrightarrow> upd_invs I Q tas t = \<lfloor>i\<rfloor>"
proof(induct tas arbitrary: ts I)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS I)
  note IH = \<open>\<And>ts I. \<lbrakk>thread_oks ts TAS; I t = \<lfloor>i\<rfloor>; ts t = \<lfloor>x\<rfloor>\<rbrakk> \<Longrightarrow> upd_invs I Q TAS t = \<lfloor>i\<rfloor>\<close>
  note cct = \<open>thread_oks TS (TA # TAS)\<close>
  note it = \<open>I t = \<lfloor>i\<rfloor>\<close>
  note est = \<open>TS t = \<lfloor>x\<rfloor>\<close>
  from cct have cctta: "thread_ok TS TA"
    and ccttas: "thread_oks (redT_updT' TS TA) TAS" by auto
  from cctta it est have "upd_inv I Q TA t = \<lfloor>i\<rfloor>"
    by(cases TA, auto)
  moreover
  have "redT_updT' TS TA t = \<lfloor>x\<rfloor>" using cctta est
    by - (rule redT_updT'_Some)
  ultimately have "upd_invs (upd_inv I Q TA) Q TAS t = \<lfloor>i\<rfloor>" using ccttas
    by -(erule IH)
  thus ?case by simp
qed

lemma upd_inv_Some_eq:
  "\<lbrakk> thread_ok ts ta; ts t = \<lfloor>x\<rfloor> \<rbrakk> \<Longrightarrow> upd_inv I Q ta t = I t"
by(cases ta, auto)

lemma upd_invs_Some_eq: "\<lbrakk> thread_oks ts tas; ts t = \<lfloor>x\<rfloor> \<rbrakk> \<Longrightarrow> upd_invs I Q tas t = I t"
proof(induct tas arbitrary: ts I)
  case Nil thus ?case by simp
next
  case (Cons TA TAS TS I)
  note IH = \<open>\<And>ts I. \<lbrakk>thread_oks ts TAS; ts t = \<lfloor>x\<rfloor>\<rbrakk> \<Longrightarrow> upd_invs I Q TAS t = I t\<close>
  note cct = \<open>thread_oks TS (TA # TAS)\<close>
  note est = \<open>TS t = \<lfloor>x\<rfloor>\<close>
  from cct est have "upd_invs (upd_inv I Q TA) Q TAS t = upd_inv I Q TA t"
    apply(clarsimp)
    apply(erule IH)
    by(rule redT_updT'_Some)
  also from cct est have "\<dots> = I t"
    by(auto elim: upd_inv_Some_eq)
  finally show ?case by simp
qed

lemma SOME_new_thread_upd_invs:
  assumes Qsome: "Q (SOME i. Q i t x m) t x m"
  and nt: "NewThread t x m \<in> set tas"
  and cct: "thread_oks ts tas"
  shows "\<exists>i. upd_invs I Q tas t = \<lfloor>i\<rfloor> \<and> Q i t x m"
proof(rule exI[where x="SOME i. Q i t x m"])
  from nt cct have "upd_invs I Q tas t = \<lfloor>SOME i. Q i t x m\<rfloor>"
  proof(induct tas arbitrary: ts I)
    case Nil thus ?case by simp
  next
    case (Cons TA TAS TS I)
    note IH = \<open>\<And>ts I. \<lbrakk> NewThread t x m \<in> set TAS; thread_oks ts TAS \<rbrakk> \<Longrightarrow> upd_invs I Q TAS t = \<lfloor>SOME i. Q i t x m\<rfloor>\<close>
    note nt = \<open>NewThread t x m \<in> set (TA # TAS)\<close>
    note cct = \<open>thread_oks TS (TA # TAS)\<close>
    { assume nt': "NewThread t x m \<in> set TAS"
      from cct have ?case
        apply(clarsimp)
        by(rule IH[OF nt']) }
    moreover
    { assume ta: "TA = NewThread t x m"
      with cct have rup: "redT_updT' TS TA t = \<lfloor>(undefined, no_wait_locks)\<rfloor>"
        by(simp)
      from cct have cctta: "thread_oks (redT_updT' TS TA) TAS" by simp
      from ta have "upd_inv I Q TA t = \<lfloor>SOME i. Q i t x m\<rfloor>"
        by(simp)
      hence ?case
        by(clarsimp simp add: upd_invs_Some_eq[OF cctta, OF rup]) }
    ultimately show ?case using nt by auto
  qed
  with Qsome show "upd_invs I Q tas t = \<lfloor>SOME i. Q i t x m\<rfloor> \<and> Q (SOME i. Q i t x m) t x m"
    by(simp)
qed

lemma ts_ok_into_ts_inv_const:
  assumes "ts_ok P ts m"
  obtains I where "ts_inv (\<lambda>_. P) I ts m"
proof -
  from assms have "ts_inv (\<lambda>_. P) (\<lambda>t. if t \<in> dom ts then Some undefined else None) ts m"
    by(auto intro!: ts_invI dest: ts_okD)
  thus thesis by(rule that)
qed

lemma ts_inv_const_into_ts_ok:
  "ts_inv (\<lambda>_. P) I ts m \<Longrightarrow> ts_ok P ts m"
by(auto intro!: ts_okI dest: ts_invD)

lemma ts_inv_into_ts_ok_Ex:
  "ts_inv Q I ts m \<Longrightarrow> ts_ok (\<lambda>t x m. \<exists>i. Q i t x m) ts m"
by(rule ts_okI)(blast dest: ts_invD)

lemma ts_ok_Ex_into_ts_inv:
  "ts_ok (\<lambda>t x m. \<exists>i. Q i t x m) ts m \<Longrightarrow> \<exists>I. ts_inv Q I ts m"
by(rule exI[where x="\<lambda>t. \<lfloor>SOME i. Q i t (fst (the (ts t))) m\<rfloor>"])(auto 4 4 dest: ts_okD intro: someI intro: ts_invI)

lemma Ex_ts_inv_conv_ts_ok:
  "(\<exists>I. ts_inv Q I ts m) \<longleftrightarrow> (ts_ok (\<lambda>t x m. \<exists>i. Q i t x m) ts m)"
by(auto dest: ts_inv_into_ts_ok_Ex ts_ok_Ex_into_ts_inv)

end