theory LLVM_Floyd_VCG
imports Monad2 LLVM_Typecheck Sep_Algebra_Add
begin

definition "EXACT h h' \<equiv> h'=h"
lemma strictly_exact_EXACT[simp]: "strictly_exact (EXACT h)"
  unfolding EXACT_def by (auto intro: strictly_exactI)

lemma EXACT_split: "a##b \<Longrightarrow> EXACT (a+b) = (EXACT a ** EXACT b)"
  unfolding EXACT_def sep_conj_def by auto

lemma EXACT_zero[simp]: "EXACT 0 = \<box>" by (auto simp: sep_algebra_simps EXACT_def)

lemma EXACT_eq_iff[simp]: "EXACT a = EXACT b \<longleftrightarrow> a=b"
  unfolding EXACT_def by metis

typ val
typ vaddr
typ "val memory"

term \<open>(\<bowtie>)\<close>

fun va_disj :: "vaddr \<Rightarrow> vaddr \<Rightarrow> bool" where
  "va_disj [] _ \<longleftrightarrow> False"
| "va_disj _ [] \<longleftrightarrow> False"
| "va_disj (VA_ARRAY_IDX _ # _) (VA_FIELD_IDX _ # _) \<longleftrightarrow> True"
| "va_disj (VA_FIELD_IDX _ # _) (VA_ARRAY_IDX _ # _) \<longleftrightarrow> True"
| "va_disj (VA_ARRAY_IDX i # as) (VA_ARRAY_IDX j # bs) \<longleftrightarrow> (i=j \<longrightarrow> va_disj as bs)"
| "va_disj (VA_FIELD_IDX i # as) (VA_FIELD_IDX j # bs) \<longleftrightarrow> (i=j \<longrightarrow> va_disj as bs)"

lemma va_disj_add_simps[simp]: "\<not>va_disj uu []" by (cases uu) auto

lemma va_disj_irrefl[simp]: "\<not>(va_disj as as)"
  apply (induction as)
  subgoal by simp
  subgoal for a as by (cases a) auto
  done

lemma va_disj_sym: "va_disj as bs \<longleftrightarrow> va_disj bs as"
  by (induction as bs rule: va_disj.induct) auto

lemma array_struct_indepL_iff1[simp]:
  "lower_lens (array_item\<^sub>L i) \<bowtie> lower_lens (struct_field\<^sub>L j)"
  apply unfold_locales
  by (auto simp: struct_field\<^sub>L_def array_item\<^sub>L_def is_VSTRUCT_def is_VARRAY_def)

lemma array_struct_indepL_iff2[simp]:
  "lower_lens (struct_field\<^sub>L j) \<bowtie> lower_lens (array_item\<^sub>L i)"
  by (simp add: lens_indep_sym)

lemmas array_struct_indepL_iff = array_struct_indepL_iff1 array_struct_indepL_iff2

lemma array_item\<^sub>L_rn[simp]: "rnlens (lower_lens (array_item\<^sub>L i))"
  apply (rule rnlensI[where x="VINT (Inr (lconst 32 1))" and y="VINT (Inr (lconst 32 0))" and s="VARRAY (replicate (i+1) undefined)"])
  by auto

lemma struct_field\<^sub>L_rn[simp]: "rnlens (lower_lens (struct_field\<^sub>L i))"
  apply (rule rnlensI[where x="VINT (Inr (lconst 32 1))" and y="VINT (Inr (lconst 32 0))" and s="VSTRUCT (replicate (i+1) undefined)"])
  by auto

lemma array_array_indepL_iff[simp]: "lower_lens (array_item\<^sub>L i) \<bowtie> lower_lens (array_item\<^sub>L j) \<longleftrightarrow> i\<noteq>j"
  apply rule
  subgoal by auto
  subgoal
    apply unfold_locales
    by (auto simp: struct_field\<^sub>L_def array_item\<^sub>L_def is_VARRAY_def list_update_swap)
  done

lemma struct_struct_indepL_iff[simp]: "lower_lens (struct_field\<^sub>L i) \<bowtie> lower_lens (struct_field\<^sub>L j) \<longleftrightarrow> i\<noteq>j"
  apply rule
  subgoal by auto
  subgoal
    apply unfold_locales
    by (auto simp: struct_field\<^sub>L_def array_item\<^sub>L_def is_VSTRUCT_def list_update_swap)
  done

(* TODO: Move *)
lemma rnl_id[simp]: "rnlens (id\<^sub>L::'a\<Longrightarrow>'a) \<longleftrightarrow> (\<exists>x y::'a. x\<noteq>y)"
  by (auto simp: rnlens_def)

lemma rnl_vai[simp]: "rnlens (lower_lens (lens_of_vai a))"
  by (cases a)  auto

lemma rnl_vaddr[simp]: "rnlens (lower_lens (lens_of_vaddr a))"
  by (induction a) auto

(* TODO: <-- direction should also hold, but requires some lemmas on lens composition and indep *)
lemma "va_disj a b \<Longrightarrow> lower_lens (lens_of_vaddr a) \<bowtie> lower_lens (lens_of_vaddr b)"
  apply (induction a b rule: va_disj.induct)
  apply (auto) []
  apply (auto) []
  apply (auto simp: lens_indep_extend2) []
  apply (auto simp: lens_indep_extend2) []
  subgoal for i as j bs
    apply (cases "i=j")
    apply (auto simp: lens_indep_extend2 lens_indep_left_comp)
    done
  subgoal for i as j bs
    apply (cases "i=j")
    apply (auto simp: lens_indep_extend2 lens_indep_left_comp)
    done
  done

datatype primval = PVINT "nat + lint" | PVPTR "addr option option"

definition "va_disj' A B \<equiv> \<forall>a\<in>dom A. \<forall>b\<in>dom B. va_disj a b"

lemma va_disj'_imp_dom_disj[simp]: "va_disj' A B \<Longrightarrow> dom A \<inter> dom B = {}"
  apply (auto simp: va_disj'_def)
  by (meson domI va_disj_irrefl)

typedef va_sep = "{ as::vaddr \<rightharpoonup> primval . \<forall>a\<in>dom as. \<forall>b\<in>dom as. a=b \<or> va_disj a b }" by auto
setup_lifting type_definition_va_sep

instantiation va_sep :: "{unique_zero_sep_algebra, stronger_sep_algebra}" begin

  lift_definition sep_disj_va_sep :: "va_sep \<Rightarrow> va_sep \<Rightarrow> bool" is "va_disj'" .
  lift_definition plus_va_sep :: "va_sep \<Rightarrow> va_sep \<Rightarrow> va_sep" is "\<lambda>as bs. if va_disj' as bs then as++bs else as"
    by (auto 6 3 split: if_splits simp: Ball_def va_disj_sym va_disj'_def simp: domIff)

  lift_definition zero_va_sep :: va_sep is "Map.empty" by auto

  instance
    apply standard
    apply (transfer; auto simp: va_disj'_def)
    apply (transfer; auto 0 3 simp: va_disj'_def intro: va_disj_sym[THEN iffD1])
    apply (transfer; auto)
    apply (determ \<open>transfer\<close>; auto 0 3 simp: va_disj'_def map_add_comm intro: domI va_disj_sym[THEN iffD1])
    apply (determ transfer; auto simp: va_disj'_def domI)
    apply (determ transfer; auto  simp: va_disj'_def domI)
    apply (determ transfer; auto  simp: va_disj'_def domI)
    apply (determ transfer) using va_disj'_imp_dom_disj apply fastforce
    apply (determ transfer; auto  simp: va_disj'_def domI)
    done

end

(* TODO: Move *)
lemma size_list_nth_estimation[termination_simp]:
  "x1 < length vs \<Longrightarrow> size (vs ! x1) < Suc (size_list size vs)"
  by (meson less_irrefl_nat not_less_eq nth_mem size_list_estimation)

lemma size_enumerate_estimation[termination_simp]:
   "(a, b) \<in> list.set (List.enumerate 0 vs) \<Longrightarrow> size b < Suc (size_list size vs)"
  by (metis enumerate_eq_zip lessI not_less set_zip_rightD size_list_estimation')

lift_definition va_int :: "(nat+lint) \<Rightarrow> va_sep" is "\<lambda>i. [ [] \<mapsto> PVINT i]" by auto
lift_definition va_ptr :: "addr option option \<Rightarrow> va_sep" is "\<lambda>a. [ [] \<mapsto> PVPTR a]" by auto
lift_definition va_in_array :: "nat \<Rightarrow> va_sep \<Rightarrow> va_sep" is "\<lambda>i m. \<lambda>VA_ARRAY_IDX j#as\<Rightarrow> if i=j then m as else None | _ \<Rightarrow> None"
  by (fastforce split: list.splits va_item.splits if_splits)
lift_definition va_in_struct :: "nat \<Rightarrow> va_sep \<Rightarrow> va_sep" is "\<lambda>i m. \<lambda>VA_FIELD_IDX j#as\<Rightarrow> if i=j then m as else None | _ \<Rightarrow> None"
  by (fastforce split: list.splits va_item.splits if_splits)

fun va_cons :: "va_item \<Rightarrow> va_sep \<Rightarrow> va_sep" where
  "va_cons (VA_ARRAY_IDX i) = va_in_array i"
| "va_cons (VA_FIELD_IDX i) = va_in_struct i"

definition va_append :: "vaddr \<Rightarrow> va_sep \<Rightarrow> va_sep" where "va_append \<equiv> foldr va_cons"

lemma va_append_append_eq[simp]: "va_append a (va_append b s) = va_append (a@b) s"
  by (auto simp: va_append_def)

lemma va_append_Nil[simp]: "va_append [] s = s"
  by (auto simp: va_append_def)

fun val_\<alpha> :: "val \<Rightarrow> va_sep" where
  "val_\<alpha> (VINT i) = va_int i"
| "val_\<alpha> (VPTR a) = va_ptr a"
| "val_\<alpha> (VARRAY vs) = (fold (\<lambda>(i,v) s. s + va_in_array i (val_\<alpha> v)) (List.enumerate 0 vs) 0)"
| "val_\<alpha> (VSTRUCT vs) = (fold (\<lambda>(i,v) s. s + va_in_struct i (val_\<alpha> v)) (List.enumerate 0 vs) 0)"

lemma va_prim_dj:
  "va_int i ## x \<longleftrightarrow> x=0"
  "va_ptr p ## x \<longleftrightarrow> x=0"
  by (determ transfer; auto simp: va_disj'_def)+

lemma va_array_struct_dj:
  "va_in_array i v ## va_in_struct j v'"
  "va_in_struct j v' ## va_in_array i v"
  by (determ transfer; auto simp: va_disj'_def split: list.splits va_item.splits if_splits)+

lemma va_array_array_dj:
  "va_in_array i v ## va_in_array j v' \<longleftrightarrow> i\<noteq>j \<or> v##v'"
  apply (determ transfer)
  apply (rule)
  subgoal by (force simp: va_disj'_def dom_def split: list.splits va_item.splits if_splits)
  subgoal by (auto simp: va_disj'_def dom_def split: list.splits va_item.splits if_splits)
  done

lemma va_struct_struct_dj:
  "va_in_struct i v ## va_in_struct j v' \<longleftrightarrow> i\<noteq>j \<or> v##v'"
  apply (determ transfer)
  apply (rule)
  subgoal by (force simp: va_disj'_def dom_def split: list.splits va_item.splits if_splits)
  subgoal by (auto simp: va_disj'_def dom_def split: list.splits va_item.splits if_splits)
  done

lemmas va_djs[simp] = va_prim_dj va_array_struct_dj va_array_array_dj va_struct_struct_dj

lemma va_cons_dj_iff: "va_cons a x ## va_cons b y \<longleftrightarrow> (a=b \<longrightarrow> x##y)"
  by (cases a; cases b) auto

lemma va_append_same_dj_iff[simp]: "va_append a x ## va_append a y \<longleftrightarrow> (x##y)"
  apply (induction a)
  apply (auto simp: va_append_def va_cons_dj_iff)
  done

lemma to_va_append:
  "va_in_array i s = va_append [VA_ARRAY_IDX i] s"
  "va_in_struct i s = va_append [VA_FIELD_IDX i] s"
  "va_cons a s = va_append [a] s"
  by (auto simp: va_append_def)

term EXACT

lemma va_in_array_comm_plus[simp]: "va_in_array i (s+t) = va_in_array i s + va_in_array i t"
  apply transfer
  apply (rule ext)
  apply (auto 0 0 split: list.splits va_item.splits option.splits if_splits simp: map_add_def)
  apply (auto 0 0 simp: va_disj'_def split: list.splits va_item.splits option.splits if_splits)
  apply (auto simp: dom_def) []
  apply (force simp: dom_def split: list.splits va_item.splits option.splits if_splits) []
  done

lemma va_in_struct_comm_plus[simp]: "va_in_struct i (s+t) = va_in_struct i s + va_in_struct i t"
  apply transfer
  apply (rule ext)
  apply (auto 0 0 split: list.splits va_item.splits option.splits if_splits simp: map_add_def)
  apply (auto 0 0 simp: va_disj'_def split: list.splits va_item.splits option.splits if_splits)
  apply (auto simp: dom_def) []
  apply (force simp: dom_def split: list.splits va_item.splits option.splits if_splits) []
  done

lemma va_cons_comm_plus[simp]: "va_cons a (s\<^sub>1+s\<^sub>2) = va_cons a s\<^sub>1 + va_cons a s\<^sub>2"
  by (cases a; auto)

lemma va_append_comm_plus[simp]:  "va_append a (s\<^sub>1+s\<^sub>2) = va_append a s\<^sub>1 + va_append a s\<^sub>2"
  by (induction a) (auto simp: va_append_def)

lemma va_in_x_zero[simp]:
  "va_in_array i 0 = 0"
  "va_in_struct i 0 = 0"
  by (determ transfer; auto intro!: ext split: list.splits va_item.splits; fail)+

lemma va_cons_zero[simp]: "va_cons a 0 = 0"
  by (cases a) auto

lemma va_append_zero[simp]: "va_append a 0 = 0"
  by (induction a) (auto simp: va_append_def)

definition "points_to a v \<equiv> EXACT (va_append a (val_\<alpha> v))"

find_theorems "List.enumerate _ (_@_) "

lemma fold_in_array_disj_aux: "i\<ge>length xs \<Longrightarrow> fold (\<lambda>(i, v) s. s + va_in_array i (val_\<alpha> v)) (List.enumerate 0 xs) 0 ## va_in_array i (val_\<alpha> v)"
  apply (induction xs arbitrary: i v rule: rev_induct)
  apply (auto simp: enumerate_append_eq)
  done

lemma fold_in_struct_disj_aux: "i\<ge>length xs \<Longrightarrow> fold (\<lambda>(i, v) s. s + va_in_struct i (val_\<alpha> v)) (List.enumerate 0 xs) 0 ## va_in_struct i (val_\<alpha> v)"
  apply (induction xs arbitrary: i v rule: rev_induct)
  apply (auto simp: enumerate_append_eq)
  done

lemma pto_split_array:
  "points_to a (VARRAY xs) = (\<And>* map (\<lambda>(i,x). points_to (a@[VA_ARRAY_IDX i]) x) (List.enumerate 0 xs))"
  apply (auto simp: points_to_def)
  apply (induction xs rule: rev_induct)
  apply (auto simp: enumerate_append_eq EXACT_split fold_in_array_disj_aux sep_algebra_simps)
  apply (auto simp: to_va_append)
  done

lemma pto_split_struct:
  "points_to a (VSTRUCT xs) = (\<And>* map (\<lambda>(i,x). points_to (a@[VA_FIELD_IDX i]) x) (List.enumerate 0 xs))"
  apply (auto simp: points_to_def)
  apply (induction xs rule: rev_induct)
  apply (auto simp: enumerate_append_eq EXACT_split fold_in_struct_disj_aux sep_algebra_simps)
  apply (auto simp: to_va_append)
  done

xxx, ctd here: Towards separation logic and rules.
  1. Separate out memory model from control flow and deep embedding.
  2. Transfer sep-algebra
  3. Use generic block-allocator in memory model, with sep-algebra
  4. Transfer/adapt tooling from IMPlusPlus/ ImpHOL-VCG

lemma "va_append"

lemma "va_append [VA_ARRAY_IDX 2, VA_FIELD_IDX 1] (va_int i) = foos"
  apply (simp add: va_append_def)

definition "val_assn v \<equiv> EXACT (val_\<alpha> v)"

definition "fold_idx f l a \<equiv> fold f (zip l [0..<length l]) a"

find_theorems List.enumerate

lemma "val_assn (VSTRUCT flds) = fold (\<lambda>(i,v). va_in_struct i (val_assn v)) (List.enumerate 0 flds) \<box>"
  unfolding val_assn_def
  apply (simp)

oops
xxx, ctd here: Derive assertions, and show how to combine/split them?

  oops
  ; auto simp: va_disj'_def split: list.splits va_item.splits if_splits)

fun val_\<alpha>_aux :: "val \<Rightarrow> vaddr \<rightharpoonup> primval" where
  "val_\<alpha>_aux (VINT i) = [ [] \<mapsto> PVINT i ]"
| "val_\<alpha>_aux (VPTR a) = [ [] \<mapsto> PVPTR a ]"
| "val_\<alpha>_aux (VARRAY vs) = (\<lambda>VA_ARRAY_IDX i # as \<Rightarrow> if i<length vs then val_\<alpha>_aux (vs!i) as else None | _ \<Rightarrow> None)"
| "val_\<alpha>_aux (VSTRUCT vs) = (\<lambda>VA_FIELD_IDX i # as \<Rightarrow> if i<length vs then val_\<alpha>_aux (vs!i) as else None | _ \<Rightarrow> None)"

lemma val_\<alpha>_aux_dj: "as\<in>dom (val_\<alpha>_aux v) \<Longrightarrow> bs \<in> dom (val_\<alpha>_aux v) \<Longrightarrow> as\<noteq>bs \<Longrightarrow> va_disj as bs"
  apply (induction v arbitrary: as bs rule: val_\<alpha>_aux.induct)
  apply (auto split: list.splits va_item.splits if_splits; blast)+
  done

lift_definition val_\<alpha> :: "val \<Rightarrow> va_sep" is val_\<alpha>_aux using val_\<alpha>_aux_dj by auto

lemma "val_\<alpha>"

oops
xxx, ctd here: \<alpha> :: val \<Rightarrow> va_sep
  which laws are required?

thm is_VSTRUCT_def
find_theorems  lower_lens

find_theorems "(\<bowtie>)" "(\<bullet>\<^sub>L)"

oops
xxx, ctd here: Separation algebra on abstraction of values!

  Attempt 1:
    abstract to function from addresses to primitive values
    requires separation algebra on addr = block_addr \<times> vaddr

      \<rightarrow> block_addr: Simple \<noteq> algebra
      \<rightarrow> vaddr: Do disjoint-predicate: Disjoint if no addr is prefix of other addr
        \<longrightarrow> Should map to lens independence

    functors to describe content of arrays and structures (relate them to val), with split rules.

\<rightarrow> Generalization to memory is straightforward (block_allocator!)

definition

(* TODO: Move *)
lemma mwp_mono[mono]:
  assumes "N\<longrightarrow>N'" "\<And>e. F e \<longrightarrow> F' e" "\<And>e s. E e s \<longrightarrow> E' e s" "\<And>r s. S r s \<longrightarrow> S' r s"
  shows "mwp m N F E S \<le> mwp m N' F' E' S'"
  using assms
  by (auto simp: mwp_def split: mres.split)

(* TODO: Move *)
lemma mwp_combine:
  assumes "mwp c N F E S"
  assumes "mwp c N' F' E' S'"
  shows "mwp c (N\<and>N') (\<lambda>msg. F msg \<and> F' msg) (\<lambda>e s. E e s \<and> E' e s) (\<lambda>r s. S r s \<and> S' r s)"
  using assms
  by (auto simp: mwp_def split: mres.split)

inductive eventually for P E where
  evtl_reached: "\<lbrakk>P \<sigma> = Some \<Phi>; \<Phi> s\<rbrakk> \<Longrightarrow> eventually P E f \<sigma> s"
| evtl_step: "\<lbrakk>P \<sigma> = None; mwp (run (c \<sigma>) s) top bot E (eventually P E c)\<rbrakk> \<Longrightarrow> eventually P E c \<sigma> s"

definition "exec_block_loop_body epn block_map label \<equiv> doM {
    \<comment> \<open>Lookup label\<close>
    block \<leftarrow> lookup (STATIC_ERROR ''undef label'') block_map label;
    exec_block_reset epn block
  }"

definition "exec_block_loop epn block_map label \<equiv>
  mwhile (\<lambda>_. return True) (exec_block_loop_body epn block_map) label"

lemma floyd_partial_main_lemma:
  assumes "eventually P E (exec_block_loop_body epn block_map) label\<^sub>0 s\<^sub>0"
  assumes "\<And>label \<Phi> s. \<lbrakk>P label = Some \<Phi>; \<Phi> s\<rbrakk>
    \<Longrightarrow> mwp (run (exec_block_loop_body epn block_map label) s) top err.is_static E (eventually P E (exec_block_loop_body epn block_map))"
  shows "mwp (run (exec_block_loop epn block_map label\<^sub>0) s\<^sub>0) top err.is_static E bot"
proof -
  show "mwp (run (exec_block_loop epn block_map label\<^sub>0) s\<^sub>0) top err.is_static E bot"
    unfolding exec_block_loop_def
    apply (rule mwhile_invar_rule[OF refl, where I="eventually P E (exec_block_loop_body epn block_map)"])
    apply simp
    apply (fact)
    apply (auto simp: run_simps cong del: mwp_cong)
    apply (erule eventually.cases; clarsimp)
    subgoal
      apply (rule mwp_cons[OF assms(2)])
      apply (assumption|simp)+
      done
    subgoal
      by (erule mwp_cons) auto
    done

qed

definition "init_proc_state params args \<equiv> mfold' (uncurry define_lvar) (zip (map snd params) args)"

definition "proc_epilogue r \<equiv> doM {
  lbs \<leftarrow> use (exec_state.local_blocks\<^sub>L)\<^sub>S;
  mfold' (\<lambda>x. zoom (exec_state.memory\<^sub>L)\<^sub>S (block_free block_type.ON_STACK x)) lbs;
  return r
}"

lemma init_proc_state_eapprox:
  "mwp (run (init_proc_state params args) s) bot err.is_static bot top"
proof -

  have R1: "mwp (run (define_lvar n v) s) bot err.is_static bot top" for n v s
    unfolding define_lvar_def
    by (auto simp: run_simps split: option.split)

  thm R1[THEN mwp_cons]

  have "mwp (run (mfold' (uncurry define_lvar) pas) s) bot err.is_static bot top" for pas s
    apply (induction pas arbitrary: s)
    apply (auto simp: run_simps intro!: R1[THEN mwp_cons])
    done

  then show ?thesis
    by (auto simp: init_proc_state_def)

qed

lemma proc_epilogue_eapprox: "mwp (run (proc_epilogue r) s) bot ((=) MEM_ERROR) bot top"
proof -
  have R1: "mwp (run (mfold' (\<lambda>x. zoom (exec_state.memory\<^sub>L)\<^sub>S (block_free block_type.ON_STACK x)) lbs) s) bot ((=) MEM_ERROR) bot top"
    for lbs
    apply (induction lbs arbitrary: s)
    apply (auto simp: run_simps block_free_def split: option.split)
    done

  show ?thesis
    unfolding proc_epilogue_def
    by (auto simp: run_simps split: option.split intro!: R1[THEN mwp_cons])

qed

lemma
  assumes "mwp (run (exec_proc epn p args) \<mu>) top no_static_err (top::'e \<Rightarrow> _) top"
  assumes "P args \<mu>"
  assumes PL: "mwp (run (init_proc_state (procedure.params p) args) (mk_fresh_exec_state \<mu>)) top top (top::'e \<Rightarrow> _) P\<^sub>l"
  assumes PROL: "\<And>s. P\<^sub>l () s \<Longrightarrow> mwp (run (exec_block epn (procedure.prologue p)) s) top err.is_static QQQ XXX"
  assumes EPIL: "\<And>r s. QQQ r s
       \<Longrightarrow> mwp (run (proc_epilogue r) s) top err.is_static (top::'e \<Rightarrow> _)
            (\<lambda>r s. Q r (get' exec_state.memory\<^sub>L s))"

  assumes IV_INIT: "\<And>label s. XXX label s \<Longrightarrow> eventually INVARS QQQ (exec_block_loop_body epn (map_of (procedure.blocks p))) label s"
  assumes IV_STEP: "\<And>label s \<Phi>. \<lbrakk> INVARS label = Some \<Phi>; \<Phi> s \<rbrakk> \<Longrightarrow>
    mwp (run (exec_block_loop_body epn (map_of (procedure.blocks p)) label) s) top err.is_static QQQ
            (eventually INVARS QQQ (exec_block_loop_body epn (map_of (procedure.blocks p))))"

  shows "mwp (run (exec_proc epn p args) \<mu>) top bot (top::'e \<Rightarrow> _) Q"
proof -
  obtain params prologue blocks rtype where [simp]: "p=PROC params prologue blocks rtype"
    by (cases p)

  have "mwp (run (exec_proc epn p args) \<mu>) top err.is_static (bot::'e \<Rightarrow> _) Q"
    unfolding exec_proc_def
    apply (subst exec_block_loop_body_def[symmetric])
    apply (subst exec_block_loop_def[symmetric])
    apply (subst init_proc_state_def[symmetric])
    apply (subst proc_epilogue_def[symmetric])
    apply (auto simp: run_simps cong del: mwp_cong split: option.split)
    apply (rule mwp_cons)
    apply (rule mwp_combine[OF init_proc_state_eapprox])
    apply (rule PL[simplified])
    apply simp
    apply simp
    apply simp
    apply simp
    apply (rule mwp_cons)
    apply (rule PROL[simplified])
    apply simp
    apply simp
    apply simp
    apply (rule mwp_cons)
    apply (rule mwp_combine[OF proc_epilogue_eapprox])
    apply (rule EPIL)
    apply simp
    apply simp
    apply clarsimp
    apply simp
    apply simp
    apply (rule mwp_cons)
    apply (rule floyd_partial_main_lemma[where P=INVARS and E=QQQ])
    apply simp_all
    thm IV_INIT[simplified]
    apply (rule IV_INIT[simplified]; simp)
    subgoal
      apply (rule mwp_cons)
      thm IV_STEP[simplified]
      apply (rule IV_STEP[simplified])
      apply simp+
      done
    subgoal
      apply (rule mwp_cons)
      apply (rule mwp_combine[OF proc_epilogue_eapprox])
      apply (rule EPIL)
      by auto
    done

  from mwp_combine[OF this assms(1)] show ?thesis
    by (rule mwp_cons) auto

qed

xxx, ctd here: What is QQQ and XXX in context of procedures + sep-logic assertions?

definition "whilek (k::nat) b c s \<equiv> doM {
  (s,_) \<leftarrow> mwhile
    (\<lambda>(s,k). doM { return (b s \<and> k>0)})
    (\<lambda>(s,k). doM { s \<leftarrow> c s; return (s, k - 1) })
    (s,k);
  return s
  }"

lemma whilek_unfold: "whilek k b c s
  = (if b s \<and> k>0 then doM { s \<leftarrow> c s; whilek (k - 1) b c s   } else return s)"
  unfolding whilek_def
  apply (subst mwhile_unfold)
  apply (rule M_eqI)
  apply (auto simp: run_simps)
  done

lemma whilek0[simp]: "whilek 0 b c \<sigma> = return \<sigma>"
  apply (subst whilek_unfold) by simp

definition "fin_Qk k b c Q \<sigma> s \<equiv>
  mwp (run (whilek k b c \<sigma>) s) (True) top top (\<lambda>\<sigma> s. \<not>b \<sigma> \<and> Q \<sigma> s)"

lemma "fin_Qk 0 b c Q \<sigma> s \<longleftrightarrow> \<not>b \<sigma> \<and> Q \<sigma> s"
  unfolding fin_Qk_def by (simp add: run_simps)

lemma fin_Qk_unfold: "fin_Qk 0 b c Q \<sigma> s = (
    if b \<sigma> \<and> (0::nat)>0 then
      mwp (run (c \<sigma>) s) top top top (fin_Qk (k-1) b c Q)
    else
      \<not>b \<sigma> \<and> Q \<sigma> s
  )"
  unfolding fin_Qk_def
  apply (subst whilek_unfold)
  apply (auto simp: run_simps)
  done

lemma
  shows "mwp (run (mwhile (\<lambda>_. return True) step l) s) bot bot Q bot"
  apply (rule mwhile_invar_rule[OF refl])

lemma "mwp (run (whilek ))"

  oops
   xxx: Iterate execution at most k times ...
    show relation with while-loop

end


(*  Title:      JinjaThreads/MM/JMM_Type2.thy
    Author:     Andreas Lochbihler
*)

section \<open>JMM heap implementation 2\<close>

theory JMM_Type2
imports
  "../Common/ExternalCallWF"
  "../Common/ConformThreaded"
  JMM_Heap
begin

subsection \<open>Definitions\<close>

datatype addr = Address htype nat   \<comment> \<open>heap type and sequence number\<close>

lemma rec_addr_conv_case_addr [simp]: "rec_addr = case_addr"
by(auto intro!: ext split: addr.split)

instantiation addr :: addr begin
definition "hash_addr (a :: addr) = (case a of Address ht n \<Rightarrow> int n)"
definition "monitor_finfun_to_list (ls :: addr \<Rightarrow>f nat) = (SOME xs. set xs = {x. finfun_dom ls $ x })"
instance
proof
  fix ls :: "addr \<Rightarrow>f nat"
  show "set (monitor_finfun_to_list ls) = Collect (($) (finfun_dom ls))"
    unfolding monitor_finfun_to_list_addr_def
    using finite_list[OF finite_finfun_dom, where ?f.1 = "ls"]
    by(rule someI_ex)
qed
end

primrec the_Address :: "addr \<Rightarrow> htype \<times> nat"
where "the_Address (Address hT n) = (hT, n)"

text \<open>
  The JMM heap only stores which sequence numbers of a given @{typ "htype"} have already been allocated.
\<close>

type_synonym JMM_heap = "htype \<Rightarrow> nat set"

translations (type) "JMM_heap" <= (type) "htype \<Rightarrow> nat set"

definition jmm_allocate :: "JMM_heap \<Rightarrow> htype \<Rightarrow> (JMM_heap \<times> addr) set"
where "jmm_allocate h hT = (let hhT = h hT in (\<lambda>n. (h(hT := insert n hhT), Address hT n)) ` (- hhT))"

abbreviation jmm_empty :: "JMM_heap" where "jmm_empty == (\<lambda>_. {})"

definition jmm_typeof_addr :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr \<rightharpoonup> htype"
where "jmm_typeof_addr P h = (\<lambda>hT. if is_htype P hT then Some hT else None) \<circ> fst \<circ> the_Address"

definition jmm_typeof_addr' :: "'m prog \<Rightarrow> addr \<rightharpoonup> htype"
where "jmm_typeof_addr' P = (\<lambda>hT. if is_htype P hT then Some hT else None) \<circ> fst \<circ> the_Address"

lemma jmm_typeof_addr'_conv_jmm_type_addr: "jmm_typeof_addr' P = jmm_typeof_addr P h"
by(simp add: jmm_typeof_addr_def jmm_typeof_addr'_def)

lemma jmm_typeof_addr'_conv_jmm_typeof_addr: "(\<lambda>_. jmm_typeof_addr' P) = jmm_typeof_addr P"
by(simp add: jmm_typeof_addr_def jmm_typeof_addr'_def fun_eq_iff)

lemma jmm_typeof_addr_conv_jmm_typeof_addr': "jmm_typeof_addr = (\<lambda>P _. jmm_typeof_addr' P)"
by(simp add: jmm_typeof_addr'_conv_jmm_typeof_addr)

definition jmm_heap_read :: "JMM_heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> addr val \<Rightarrow> bool"
where "jmm_heap_read h a ad v = True"

context
  notes [[inductive_internals]]
begin

inductive jmm_heap_write :: "JMM_heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> addr val \<Rightarrow> JMM_heap \<Rightarrow> bool"
where "jmm_heap_write h a ad v h"

end

definition jmm_hconf :: "JMM_heap \<Rightarrow> bool"
where "jmm_hconf h \<longleftrightarrow> True"

definition jmm_allocated :: "JMM_heap \<Rightarrow> addr set"
where "jmm_allocated h = {Address CTn n|CTn n. n \<in> h CTn}"

definition jmm_spurious_wakeups :: "bool"
where "jmm_spurious_wakeups = True"

lemmas jmm_heap_ops_defs =
  jmm_allocate_def jmm_typeof_addr_def
  jmm_heap_read_def jmm_heap_write_def
  jmm_allocated_def jmm_spurious_wakeups_def

type_synonym thread_id = "addr"

abbreviation (input) addr2thread_id :: "addr \<Rightarrow> thread_id"
where "addr2thread_id \<equiv> \<lambda>x. x"

abbreviation (input) thread_id2addr :: "thread_id \<Rightarrow> addr"
where "thread_id2addr \<equiv> \<lambda>x. x"

interpretation jmm: heap_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write
  for P
.

abbreviation jmm_hext :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> JMM_heap \<Rightarrow> bool" ("_ \<turnstile> _ \<unlhd>jmm _" [51,51,51] 50)
where "jmm_hext \<equiv> jmm.hext TYPE('m)"

abbreviation jmm_conf :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr val \<Rightarrow> ty \<Rightarrow> bool"
  ("_,_ \<turnstile>jmm _ :\<le> _"  [51,51,51,51] 50)
where "jmm_conf P \<equiv> jmm.conf TYPE('m) P P"

abbreviation jmm_addr_loc_type :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> ty \<Rightarrow> bool"
  ("_,_ \<turnstile>jmm _@_ : _" [50, 50, 50, 50, 50] 51)
where "jmm_addr_loc_type P \<equiv> jmm.addr_loc_type TYPE('m) P P"

abbreviation jmm_confs :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr val list \<Rightarrow> ty list \<Rightarrow> bool"
  ("_,_ \<turnstile>jmm _ [:\<le>] _"  [51,51,51,51] 50)
where "jmm_confs P \<equiv> jmm.confs TYPE('m) P P"

abbreviation jmm_tconf :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr \<Rightarrow> bool" ("_,_ \<turnstile>jmm _ \<surd>t" [51,51,51] 50)
where "jmm_tconf P \<equiv> jmm.tconf TYPE('m) P P"

interpretation jmm: allocated_heap_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write
  jmm_allocated
  for P
.

text \<open>Now a variation of the JMM with a different read operation that permits to read only type-conformant values\<close>

abbreviation jmm_heap_read_typed :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> addr val \<Rightarrow> bool"
where "jmm_heap_read_typed P \<equiv> jmm.heap_read_typed TYPE('m) P P"

interpretation jmm': heap_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write
  for P .

abbreviation jmm'_hext :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> JMM_heap \<Rightarrow> bool" ("_ \<turnstile> _ \<unlhd>jmm'' _" [51,51,51] 50)
where "jmm'_hext \<equiv> jmm'.hext TYPE('m)"

abbreviation jmm'_conf :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr val \<Rightarrow> ty \<Rightarrow> bool"
  ("_,_ \<turnstile>jmm'' _ :\<le> _"  [51,51,51,51] 50)
where "jmm'_conf P \<equiv> jmm'.conf TYPE('m) P P"

abbreviation jmm'_addr_loc_type :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> ty \<Rightarrow> bool"
  ("_,_ \<turnstile>jmm'' _@_ : _" [50, 50, 50, 50, 50] 51)
where "jmm'_addr_loc_type P \<equiv> jmm'.addr_loc_type TYPE('m) P P"

abbreviation jmm'_confs :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr val list \<Rightarrow> ty list \<Rightarrow> bool"
  ("_,_ \<turnstile>jmm'' _ [:\<le>] _"  [51,51,51,51] 50)
where "jmm'_confs P \<equiv> jmm'.confs TYPE('m) P P"

abbreviation jmm'_tconf :: "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr \<Rightarrow> bool" ("_,_ \<turnstile>jmm'' _ \<surd>t" [51,51,51] 50)
where "jmm'_tconf P \<equiv> jmm'.tconf TYPE('m) P P"

subsection \<open>Heap locale interpretations\<close>

subsection \<open>Locale \<open>heap\<close>\<close>

lemma jmm_heap: "heap addr2thread_id thread_id2addr jmm_allocate (jmm_typeof_addr P) jmm_heap_write P"
proof
  fix h' a h hT
  assume "(h', a) \<in> jmm_allocate h hT" "is_htype P hT"
  thus "jmm_typeof_addr P h' a = \<lfloor>hT\<rfloor>"
    by(auto simp add: jmm_heap_ops_defs)
next
  fix h hT h' a
  assume "(h', a) \<in> jmm_allocate h hT"
  thus "P \<turnstile> h \<unlhd>jmm h'" by(auto simp add: jmm_heap_ops_defs intro: jmm.hextI)
next
  fix h a al v h'
  assume "jmm_heap_write h a al v h'"
  thus "P \<turnstile> h \<unlhd>jmm h'" by cases auto
qed simp

interpretation jmm: heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write
  P
  for P
by(rule jmm_heap)

declare jmm.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemmas jmm'_heap = jmm_heap

interpretation jmm': heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write
  P
  for P
by(rule jmm'_heap)

declare jmm'.typeof_addr_thread_id2_addr_addr2thread_id [simp del]

lemma jmm_heap_read_typed_default_val:
  "heap_base.heap_read_typed typeof_addr jmm_heap_read P h a al
   (default_val (THE T. heap_base.addr_loc_type typeof_addr P h a al T))"
by(rule heap_base.heap_read_typedI)(simp_all add: heap_base.THE_addr_loc_type jmm_heap_read_def heap_base.defval_conf)

lemma jmm_allocate_Eps:
  "(SOME ha. ha \<in> jmm_allocate h hT) = (h', a')
  \<Longrightarrow> jmm_allocate h hT \<noteq> {} \<longrightarrow> (h', a') \<in> jmm_allocate h hT"
by(auto dest: jmm.allocate_Eps)

lemma jmm_allocate_eq_empty: "jmm_allocate h hT = {} \<longleftrightarrow> h hT = UNIV"
by(auto simp add: jmm_allocate_def)

lemma jmm_allocate_otherD:
  "(h', a) \<in> jmm_allocate h hT \<Longrightarrow> \<forall>hT'. hT' \<noteq> hT \<longrightarrow> h' hT' = h hT'"
by(auto simp add: jmm_allocate_def)

lemma jmm_start_heap_ok: "jmm.start_heap_ok"
apply(simp add: jmm.start_heap_ok_def jmm.start_heap_data_def initialization_list_def sys_xcpts_list_def jmm.create_initial_object_simps)
apply(split prod.split, clarify, clarsimp simp add: jmm.create_initial_object_simps jmm_allocate_eq_empty Thread_neq_sys_xcpts sys_xcpts_neqs dest!: jmm_allocate_Eps jmm_allocate_otherD)+
done

subsection \<open>Locale \<open>heap_conf\<close>\<close>

interpretation jmm: heap_conf_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write jmm_hconf
  P
  for P .

abbreviation (input) jmm'_hconf :: "JMM_heap \<Rightarrow> bool"
where "jmm'_hconf == jmm_hconf"

interpretation jmm': heap_conf_base
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write jmm'_hconf
  P
  for P .

abbreviation jmm_heap_read_typeable :: "'m prog \<Rightarrow> bool"
where "jmm_heap_read_typeable P \<equiv> jmm.heap_read_typeable TYPE('m) P jmm_hconf P"

abbreviation jmm'_heap_read_typeable :: "'m prog \<Rightarrow> bool"
where "jmm'_heap_read_typeable P \<equiv> jmm'.heap_read_typeable TYPE('m) P jmm_hconf P"

lemma jmm_heap_read_typeable: "jmm_heap_read_typeable P"
by(rule jmm.heap_read_typeableI)(simp add: jmm_heap_read_def)

lemma jmm'_heap_read_typeable: "jmm'_heap_read_typeable P"
by(rule jmm'.heap_read_typeableI)(auto simp add: jmm_heap_read_def jmm.heap_read_typed_def dest: jmm'.addr_loc_type_fun)

lemma jmm_heap_conf:
  "heap_conf addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_write jmm_hconf P"
by(unfold_locales)(simp_all add: jmm_hconf_def jmm_heap_ops_defs split: if_split_asm)

interpretation jmm: heap_conf
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write jmm_hconf
  P
  for P
by(rule jmm_heap_conf)

lemmas jmm'_heap_conf = jmm_heap_conf

interpretation jmm': heap_conf
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write jmm'_hconf
  P
  for P
by(rule jmm'_heap_conf)

subsection \<open>Locale \<open>heap_progress\<close>\<close>

lemma jmm_heap_progress:
  "heap_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_read jmm_heap_write jmm_hconf P"
proof
  fix h a al T
  assume "jmm_hconf h"
    and al: "P,h \<turnstile>jmm a@al : T"
  show "\<exists>v. jmm_heap_read h a al v \<and> P,h \<turnstile>jmm v :\<le> T"
    using jmm.defval_conf[of P P h T] unfolding jmm_heap_ops_defs by blast
next
  fix h a al T v
  assume "P,h \<turnstile>jmm a@al : T"
  show "\<exists>h'. jmm_heap_write h a al v h'"
    by(auto intro: jmm_heap_write.intros)
qed

interpretation jmm: heap_progress
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write jmm_hconf
  P
  for P
by(rule jmm_heap_progress)

lemma jmm'_heap_progress:
  "heap_progress addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write jmm'_hconf P"
proof
  fix h a al T
  assume "jmm'_hconf h"
    and al: "P,h \<turnstile>jmm' a@al : T"
  thus "\<exists>v. jmm_heap_read_typed P h a al v \<and> P,h \<turnstile>jmm' v :\<le> T"
    unfolding jmm_heap_read_def jmm.heap_read_typed_def
    by(blast dest: jmm'.addr_loc_type_fun intro: jmm'.defval_conf)+
next
  fix h a al T v
  assume "P,h \<turnstile>jmm' a@al : T"
    and "P,h \<turnstile>jmm' v :\<le> T"
  thus "\<exists>h'. jmm_heap_write h a al v h'"
    by(auto intro: jmm_heap_write.intros)
qed

interpretation jmm': heap_progress
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write jmm'_hconf
  P
  for P
by(rule jmm'_heap_progress)

subsection \<open>Locale \<open>heap_conf_read\<close>\<close>

lemma jmm'_heap_conf_read:
  "heap_conf_read addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) (jmm_heap_read_typed P) jmm_heap_write jmm'_hconf P"
by(rule jmm.heap_conf_read_heap_read_typed)

interpretation jmm': heap_conf_read
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write jmm'_hconf
  P
  for P
by(rule jmm'_heap_conf_read)

interpretation jmm': heap_typesafe
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write jmm'_hconf
  P
  for P
..

subsection \<open>Locale \<open>allocated_heap\<close>\<close>

lemma jmm_allocated_heap:
  "allocated_heap addr2thread_id thread_id2addr jmm_empty jmm_allocate (jmm_typeof_addr P) jmm_heap_write jmm_allocated P"
proof
  show "jmm_allocated jmm_empty = {}" by(simp add: jmm_allocated_def)
next
  fix h' a h hT
  assume "(h', a) \<in> jmm_allocate h hT"
  thus "jmm_allocated h' = insert a (jmm_allocated h) \<and> a \<notin> jmm_allocated h"
    by(auto simp add: jmm_heap_ops_defs split: if_split_asm)
next
  fix h a al v h'
  assume "jmm_heap_write h a al v h'"
  thus "jmm_allocated h' = jmm_allocated h" by cases simp
qed

interpretation jmm: allocated_heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" jmm_heap_read jmm_heap_write
  jmm_allocated
  P
  for P
by(rule jmm_allocated_heap)

lemmas jmm'_allocated_heap = jmm_allocated_heap

interpretation jmm': allocated_heap
  addr2thread_id thread_id2addr
  jmm_spurious_wakeups
  jmm_empty jmm_allocate "jmm_typeof_addr P" "jmm_heap_read_typed P" jmm_heap_write
  jmm_allocated
  P
  for P
by(rule jmm'_allocated_heap)

subsection \<open>Syntax translations\<close>

notation jmm'.external_WT' ("_,_ \<turnstile>jmm'' (_\<bullet>_'(_')) : _" [50,0,0,0,50] 60)

abbreviation jmm'_red_external ::
  "'m prog \<Rightarrow> thread_id \<Rightarrow> JMM_heap \<Rightarrow> addr \<Rightarrow> mname \<Rightarrow> addr val list
  \<Rightarrow> (addr, thread_id, JMM_heap) external_thread_action
  \<Rightarrow> addr extCallRet \<Rightarrow> JMM_heap \<Rightarrow> bool"
where "jmm'_red_external P \<equiv> jmm'.red_external (TYPE('m)) P P"

abbreviation jmm'_red_external_syntax ::
  "'m prog \<Rightarrow> thread_id \<Rightarrow> addr \<Rightarrow> mname \<Rightarrow> addr val list \<Rightarrow> JMM_heap
  \<Rightarrow> (addr, thread_id, JMM_heap) external_thread_action
  \<Rightarrow> addr extCallRet \<Rightarrow> JMM_heap \<Rightarrow> bool"
  ("_,_ \<turnstile>jmm'' (\<langle>(_\<bullet>_'(_')),/_\<rangle>) -_\<rightarrow>ext (\<langle>(_),/(_)\<rangle>)" [50, 0, 0, 0, 0, 0, 0, 0, 0] 51)
where
  "P,t \<turnstile>jmm' \<langle>a\<bullet>M(vs), h\<rangle> -ta\<rightarrow>ext \<langle>va, h'\<rangle> \<equiv> jmm'_red_external P t h a M vs ta va h'"

abbreviation jmm'_red_external_aggr ::
  "'m prog \<Rightarrow> thread_id \<Rightarrow> addr \<Rightarrow> mname \<Rightarrow> addr val list \<Rightarrow> JMM_heap
    \<Rightarrow> ((addr, thread_id, JMM_heap) external_thread_action \<times> addr extCallRet \<times> JMM_heap) set"
where "jmm'_red_external_aggr P \<equiv> jmm'.red_external_aggr TYPE('m) P P"

abbreviation jmm'_heap_copy_loc ::
  "'m prog \<Rightarrow> addr \<Rightarrow> addr \<Rightarrow> addr_loc \<Rightarrow> JMM_heap
  \<Rightarrow> (addr, thread_id) obs_event list \<Rightarrow> JMM_heap \<Rightarrow> bool"
where "jmm'_heap_copy_loc \<equiv> jmm'.heap_copy_loc TYPE('m)"

abbreviation jmm'_heap_copies ::
  "'m prog \<Rightarrow> addr \<Rightarrow> addr \<Rightarrow> addr_loc list \<Rightarrow> JMM_heap
  \<Rightarrow> (addr, thread_id) obs_event list \<Rightarrow> JMM_heap \<Rightarrow> bool"
where "jmm'_heap_copies \<equiv> jmm'.heap_copies TYPE('m)"

abbreviation jmm'_heap_clone ::
  "'m prog \<Rightarrow> JMM_heap \<Rightarrow> addr \<Rightarrow> JMM_heap
  \<Rightarrow> ((addr, thread_id) obs_event list \<times> addr) option \<Rightarrow> bool"
where "jmm'_heap_clone P \<equiv> jmm'.heap_clone TYPE('m) P P"

end


theory BigStepSimple
  imports Analysis_More
begin

subsection \<open>Syntax\<close>

text \<open>Channel names\<close>
type_synonym cname = string

text \<open>Ready information.
  First component is set of channels that are ready to output.
  Second component is set of channels that are ready to input.\<close>
type_synonym rdy_info = "cname set \<times> cname set"

text \<open>Communications\<close>
datatype comm =
  Send cname exp        ("_[!]_" [110,108] 100)
| Receive cname var     ("_[?]_" [110,108] 100)

text \<open>HCSP processes\<close>
datatype proc =
  Cm comm
| Skip
| Assign var exp             ("_ ::= _" [99,95] 94)
| Seq proc proc           ("_; _" [91,90] 90)
| Cond fform proc proc        ("IF _ THEN _ ELSE _ FI" [95,94] 93)
| Wait exp  \<comment> \<open>Waiting for a specified amount of time\<close>
| IChoice proc proc  \<comment> \<open>Nondeterminism\<close>
| EChoice "(comm \<times> proc) list"  \<comment> \<open>External choice\<close>
| Rep proc   \<comment> \<open>Nondeterministic repetition\<close>
| Cont ODE fform  \<comment> \<open>ODE with boundary\<close>
| Interrupt ODE fform "(comm \<times> proc) list"  \<comment> \<open>Interrupt\<close>

text \<open>Parallel of several HCSP processes\<close>
datatype pproc =
  Single proc
| Parallel pproc "cname set" pproc

text \<open>Global states\<close>
datatype gstate =
  State state
| ParState gstate gstate

subsection \<open>Traces\<close>

datatype comm_type = In | Out | IO

datatype trace_block =
  CommBlock comm_type cname real
| WaitBlock ereal "real \<Rightarrow> gstate" rdy_info

abbreviation "InBlock ch v \<equiv> CommBlock In ch v"
abbreviation "OutBlock ch v \<equiv> CommBlock Out ch v"
abbreviation "IOBlock ch v \<equiv> CommBlock IO ch v"

fun WaitBlk :: "ereal \<Rightarrow> (real \<Rightarrow> gstate) \<Rightarrow> rdy_info \<Rightarrow> trace_block" where
  "WaitBlk (ereal d) p rdy = WaitBlock (ereal d) (\<lambda>\<tau>\<in>{0..d}. p \<tau>) rdy"
| "WaitBlk PInfty p rdy = WaitBlock PInfty (\<lambda>\<tau>\<in>{0..}. p \<tau>) rdy"
| "WaitBlk MInfty p rdy = WaitBlock MInfty (\<lambda>_. undefined) rdy"

lemma WaitBlk_simps [simp]:
  "WaitBlk (ereal d) p rdy = WaitBlock (ereal d) (\<lambda>\<tau>\<in>{0..d}. p \<tau>) rdy"
  "WaitBlk \<infinity> p rdy = WaitBlock \<infinity> (\<lambda>\<tau>\<in>{0..}. p \<tau>) rdy"
  "WaitBlk (-\<infinity>) p rdy = WaitBlock (-\<infinity>) (\<lambda>_. undefined) rdy"
  apply auto
  using WaitBlk.simps(2) infinity_ereal_def apply presburger
  using WaitBlk.simps(3) by auto

declare WaitBlk.simps [simp del]

lemma WaitBlk_not_Comm [simp]:
  "WaitBlk d p rdy \<noteq> CommBlock ch_type ch v"
  "CommBlock ch_type ch v \<noteq> WaitBlk d p rdy"
  by (cases d, auto)+

lemma restrict_cong_to_eq:
  fixes x :: real
  shows "restrict p1 {0..t} = restrict p2 {0..t} \<Longrightarrow> 0 \<le> x \<Longrightarrow> x \<le> t \<Longrightarrow> p1 x = p2 x"
  apply (auto simp add: restrict_def) by metis

lemma restrict_cong_to_eq2:
  fixes x :: real
  shows "restrict p1 {0..} = restrict p2 {0..} \<Longrightarrow> 0 \<le> x \<Longrightarrow> p1 x = p2 x"
  apply (auto simp add: restrict_def) by metis

lemma WaitBlk_ext:
  fixes t1 t2 :: ereal
    and hist1 hist2 :: "real \<Rightarrow> gstate"
  shows "t1 = t2 \<Longrightarrow>
   (\<And>\<tau>::real. 0 \<le> \<tau> \<Longrightarrow> \<tau> \<le> t1 \<Longrightarrow> hist1 \<tau> = hist2 \<tau>) \<Longrightarrow> rdy1 = rdy2 \<Longrightarrow>
   WaitBlk t1 hist1 rdy1 = WaitBlk t2 hist2 rdy2"
  apply (cases t1)
  apply (auto simp add: restrict_def)
  apply (rule ext) by auto

lemma WaitBlk_ext_real:
  fixes t1 :: real
    and t2 :: real
  shows "t1 = t2 \<Longrightarrow> (\<And>\<tau>. 0 \<le> \<tau> \<Longrightarrow> \<tau> \<le> t1 \<Longrightarrow> hist1 \<tau> = hist2 \<tau>) \<Longrightarrow> rdy1 = rdy2 \<Longrightarrow>
         WaitBlk (ereal t1) hist1 rdy1 = WaitBlk (ereal t2) hist2 rdy2"
  by (auto simp add: restrict_def)

lemma WaitBlk_cong:
  "WaitBlk t1 hist1 rdy1 = WaitBlk t2 hist2 rdy2 \<Longrightarrow> t1 = t2 \<and> rdy1 = rdy2"
  apply (cases t1) by (cases t2, auto)+

lemma WaitBlk_cong2:
  assumes "WaitBlk t1 hist1 rdy1 = WaitBlk t2 hist2 rdy2"
    and "0 \<le> t" "t \<le> t1"
  shows "hist1 t = hist2 t"
proof -
  have a: "t1 = t2" "rdy1 = rdy2"
    using assms WaitBlk_cong by auto
  show ?thesis
  proof (cases t1)
    case (real r)
    have real2: "t2 = ereal r"
      using real a by auto
    show ?thesis
      using assms(1)[unfolded real real2]
      apply auto using restrict_cong_to_eq assms ereal_less_eq(3) real by blast
  next
    case PInf
    have PInf2: "t2 = \<infinity>"
      using PInf a by auto
    show ?thesis
      using assms(1)[unfolded PInf PInf2] restrict_cong_to_eq2 assms by auto
  next
    case MInf
    show ?thesis
      using assms MInf by auto
  qed
qed

lemma WaitBlk_split1:
  fixes t1 :: real
  assumes "WaitBlk t p1 rdy = WaitBlk t p2 rdy"
    and "0 < t1" "ereal t1 < t"
  shows "WaitBlk (ereal t1) p1 rdy = WaitBlk (ereal t1) p2 rdy"
proof (cases t)
  case (real r)
  show ?thesis
    apply auto apply (rule ext) subgoal for x
      using assms[unfolded real]
      using restrict_cong_to_eq[of p1 r p2 x] by auto
    done
next
  case PInf
  show ?thesis
    apply auto apply (rule ext) subgoal for x
      using assms[unfolded PInf] restrict_cong_to_eq2[of p1 p2 x] by auto
    done
next
  case MInf
  then show ?thesis
    using assms by auto
qed

lemma WaitBlk_split2:
  fixes t1 :: real
  assumes "WaitBlk t p1 rdy = WaitBlk t p2 rdy"
    and "0 < t1" "ereal t1 < t"
  shows "WaitBlk (t - ereal t1) (\<lambda>\<tau>::real. p1 (\<tau> + t1)) rdy =
         WaitBlk (t - ereal t1) (\<lambda>\<tau>::real. p2 (\<tau> + t1)) rdy"
proof (cases t)
  case (real r)
  have a: "t - ereal t1 = ereal (r - t1)"
    unfolding real by auto
  show ?thesis
    unfolding a apply auto apply (rule ext) subgoal for x
      using assms[unfolded real]
      using restrict_cong_to_eq[of p1 r p2 "x + t1"] by auto
    done
next
  case PInf
  have a: "t - ereal t1 = \<infinity>"
    unfolding PInf by auto
  show ?thesis
    unfolding a
    apply auto
    apply (rule ext) subgoal for x
      using assms[unfolded PInf] restrict_cong_to_eq2[of p1 p2 "x + t1"] by auto
    done
next
  case MInf
  then show ?thesis
    using assms by auto
qed

lemmas WaitBlk_split = WaitBlk_split1 WaitBlk_split2
declare WaitBlk_simps [simp del]

type_synonym trace = "trace_block list"

type_synonym tassn = "trace \<Rightarrow> bool"

subsection \<open>Big-step semantics\<close>

text \<open>Compute list of ready communications for an external choice.\<close>
fun rdy_of_echoice :: "(comm \<times> proc) list \<Rightarrow> rdy_info" where
  "rdy_of_echoice [] = ({}, {})"
| "rdy_of_echoice ((ch[!]e, _) # rest) = (
    let rdy = rdy_of_echoice rest in
      (insert ch (fst rdy), snd rdy))"
| "rdy_of_echoice ((ch[?]var, _) # rest) = (
    let rdy = rdy_of_echoice rest in
      (fst rdy, insert ch (snd rdy)))"

text \<open>big_step p s1 tr s2 means executing p starting from state s1 results
in a trace tr and final state s2.\<close>
inductive big_step :: "proc \<Rightarrow> state \<Rightarrow> trace \<Rightarrow> state \<Rightarrow> bool" where
  skipB: "big_step Skip s [] s"
| assignB: "big_step (var ::= e) s [] (s(var := e s))"
| seqB: "big_step p1 s1 tr1 s2 \<Longrightarrow>
         big_step p2 s2 tr2 s3 \<Longrightarrow>
         big_step (p1; p2) s1 (tr1 @ tr2) s3"
| condB1: "b s1 \<Longrightarrow> big_step p1 s1 tr s2 \<Longrightarrow> big_step (IF b THEN p1 ELSE p2 FI) s1 tr s2"
| condB2: "\<not> b s1 \<Longrightarrow> big_step p2 s1 tr s2 \<Longrightarrow> big_step (IF b THEN p1 ELSE p2 FI) s1 tr s2"
| waitB1: "e s > 0 \<Longrightarrow> big_step (Wait e) s [WaitBlk (e s) (\<lambda>_. State s) ({}, {})] s"
| waitB2: "\<not> e s > 0 \<Longrightarrow> big_step (Wait e) s [] s"
| sendB1: "big_step (Cm (ch[!]e)) s [OutBlock ch (e s)] s"
| sendB2: "(d::real) > 0 \<Longrightarrow> big_step (Cm (ch[!]e)) s
            [WaitBlk d (\<lambda>_. State s) ({ch}, {}),
             OutBlock ch (e s)] s"
| sendB3: "big_step (Cm (ch[!]e)) s [WaitBlk \<infinity> (\<lambda>_. State s) ({ch}, {})] s"
| receiveB1: "big_step (Cm (ch[?]var)) s [InBlock ch v] (s(var := v))"
| receiveB2: "(d::real) > 0 \<Longrightarrow> big_step (Cm (ch[?]var)) s
            [WaitBlk d (\<lambda>_. State s) ({}, {ch}),
             InBlock ch v] (s(var := v))"
| receiveB3: "big_step (Cm (ch[?]var)) s [WaitBlk \<infinity> (\<lambda>_. State s) ({}, {ch})] s"
| IChoiceB1: "big_step p1 s1 tr s2 \<Longrightarrow> big_step (IChoice p1 p2) s1 tr s2"
| IChoiceB2: "big_step p2 s1 tr s2 \<Longrightarrow> big_step (IChoice p1 p2) s1 tr s2"
| EChoiceSendB1: "i < length cs \<Longrightarrow> cs ! i = (Send ch e, p2) \<Longrightarrow>
    big_step p2 s1 tr2 s2 \<Longrightarrow>
    big_step (EChoice cs) s1 (OutBlock ch (e s1) # tr2) s2"
| EChoiceSendB2: "(d::real) > 0 \<Longrightarrow> i < length cs \<Longrightarrow> cs ! i = (Send ch e, p2) \<Longrightarrow>
    big_step p2 s1 tr2 s2 \<Longrightarrow>
    big_step (EChoice cs) s1 (WaitBlk d (\<lambda>_. State s1) (rdy_of_echoice cs) #
                              OutBlock ch (e s1) # tr2) s2"
| EChoiceReceiveB1: "i < length cs \<Longrightarrow> cs ! i = (Receive ch var, p2) \<Longrightarrow>
    big_step p2 (s1(var := v)) tr2 s2 \<Longrightarrow>
    big_step (EChoice cs) s1 (InBlock ch v # tr2) s2"
| EChoiceReceiveB2: "(d::real) > 0 \<Longrightarrow> i < length cs \<Longrightarrow> cs ! i = (Receive ch var, p2) \<Longrightarrow>
    big_step p2 (s1(var := v)) tr2 s2 \<Longrightarrow>
    big_step (EChoice cs) s1 (WaitBlk d (\<lambda>_. State s1) (rdy_of_echoice cs) #
                              InBlock ch v # tr2) s2"
| RepetitionB1: "big_step (Rep p) s [] s"
| RepetitionB2: "big_step p s1 tr1 s2 \<Longrightarrow> big_step (Rep p) s2 tr2 s3 \<Longrightarrow>
    tr = tr1 @ tr2 \<Longrightarrow>
    big_step (Rep p) s1 tr s3"
| ContB1: "\<not>b s \<Longrightarrow> big_step (Cont ode b) s [] s"
| ContB2: "d > 0 \<Longrightarrow> ODEsol ode p d \<Longrightarrow>
    (\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)) \<Longrightarrow>
    \<not>b (p d) \<Longrightarrow> p 0 = s1 \<Longrightarrow>
    big_step (Cont ode b) s1 [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) ({}, {})] (p d)"
| InterruptSendB1: "i < length cs \<Longrightarrow> cs ! i = (Send ch e, p2) \<Longrightarrow>
    big_step p2 s tr2 s2 \<Longrightarrow>
    big_step (Interrupt ode b cs) s (OutBlock ch (e s) # tr2) s2"
| InterruptSendB2: "d > 0 \<Longrightarrow> ODEsol ode p d \<Longrightarrow> p 0 = s1 \<Longrightarrow>
    (\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)) \<Longrightarrow>
    i < length cs \<Longrightarrow> cs ! i = (Send ch e, p2) \<Longrightarrow>
    rdy = rdy_of_echoice cs \<Longrightarrow>
    big_step p2 (p d) tr2 s2 \<Longrightarrow>
    big_step (Interrupt ode b cs) s1 (WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) rdy #
                                      OutBlock ch (e (p d)) # tr2) s2"
| InterruptReceiveB1: "i < length cs \<Longrightarrow> cs ! i = (Receive ch var, p2) \<Longrightarrow>
    big_step p2 (s(var := v)) tr2 s2 \<Longrightarrow>
    big_step (Interrupt ode b cs) s (InBlock ch v # tr2) s2"
| InterruptReceiveB2: "d > 0 \<Longrightarrow> ODEsol ode p d \<Longrightarrow> p 0 = s1 \<Longrightarrow>
    (\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)) \<Longrightarrow>
    i < length cs \<Longrightarrow> cs ! i = (Receive ch var, p2) \<Longrightarrow>
    rdy = rdy_of_echoice cs \<Longrightarrow>
    big_step p2 ((p d)(var := v)) tr2 s2 \<Longrightarrow>
    big_step (Interrupt ode b cs) s1 (WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) rdy #
                                      InBlock ch v # tr2) s2"
| InterruptB1: "\<not>b s \<Longrightarrow> big_step (Interrupt ode b cs) s [] s"
| InterruptB2: "d > 0 \<Longrightarrow> ODEsol ode p d \<Longrightarrow>
    (\<forall>t. t \<ge> 0 \<and> t < d \<longrightarrow> b (p t)) \<Longrightarrow>
    \<not>b (p d) \<Longrightarrow> p 0 = s1 \<Longrightarrow> p d = s2 \<Longrightarrow>
    rdy = rdy_of_echoice cs \<Longrightarrow>
    big_step (Interrupt ode b cs) s1 [WaitBlk d (\<lambda>\<tau>. State (p \<tau>)) rdy] s2"

lemma big_step_cong:
  "big_step c s1 tr s2 \<Longrightarrow> tr = tr' \<Longrightarrow> s2 = s2' \<Longrightarrow> big_step c s1 tr' s2'"
  by auto

inductive_cases skipE: "big_step Skip s1 tr s2"
inductive_cases assignE: "big_step (Assign var e) s1 tr s2"
inductive_cases sendE: "big_step (Cm (ch[!]e)) s1 tr s2"
inductive_cases receiveE: "big_step (Cm (ch[?]var)) s1 tr s2"
inductive_cases seqE: "big_step (Seq p1 p2) s1 tr s2"
inductive_cases condE: "big_step (Cond b p1 p2) s1 tr s2"
inductive_cases waitE: "big_step (Wait d) s1 tr s2"
inductive_cases echoiceE: "big_step (EChoice es) s1 tr s2"
inductive_cases ichoiceE: "big_step (IChoice p1 p2) s1 tr s2"
inductive_cases contE: "big_step (Cont ode b) s1 tr s2"
inductive_cases interruptE: "big_step (Interrupt ode b cs) s1 tr s2"

subsection \<open>Validity\<close>

text \<open>Assertion is a predicate on states and traces\<close>

type_synonym assn = "state \<Rightarrow> trace \<Rightarrow> bool"

definition Valid :: "assn \<Rightarrow> proc \<Rightarrow> assn \<Rightarrow> bool" ("\<Turnstile> ({(1_)}/ (_)/ {(1_)})" 50) where
  "\<Turnstile> {P} c {Q} \<longleftrightarrow> (\<forall>s1 tr1 s2 tr2. P s1 tr1 \<longrightarrow> big_step c s1 tr2 s2 \<longrightarrow> Q s2 (tr1 @ tr2))"

definition entails :: "assn \<Rightarrow> assn \<Rightarrow> bool" (infixr "\<Longrightarrow>\<^sub>A" 25) where
  "(P \<Longrightarrow>\<^sub>A Q) \<longleftrightarrow> (\<forall>s tr. P s tr \<longrightarrow> Q s tr)"

lemma entails_refl [simp]:
  "P \<Longrightarrow>\<^sub>A P"
  unfolding entails_def by auto

lemma entails_trans:
  "(P \<Longrightarrow>\<^sub>A Q) \<Longrightarrow> (Q \<Longrightarrow>\<^sub>A R) \<Longrightarrow> (P \<Longrightarrow>\<^sub>A R)"
  unfolding entails_def by auto

lemma Valid_ex_pre:
  "(\<And>v. \<Turnstile> {P v} c {Q}) \<Longrightarrow> \<Turnstile> {\<lambda>s t. \<exists>v. P v s t} c {Q}"
  unfolding Valid_def by auto

lemma Valid_ex_post:
  "\<exists>v. \<Turnstile> {P} c {Q v} \<Longrightarrow> \<Turnstile> {P} c {\<lambda>s t. \<exists>v. Q v s t}"
  unfolding Valid_def by blast

lemma Valid_and_pre:
  "(P1 \<Longrightarrow> \<Turnstile> {P} c {Q}) \<Longrightarrow> \<Turnstile> {\<lambda>s t. P1 \<and> P s t} c {Q}"
  unfolding Valid_def by auto

theorem Valid_weaken_pre:
  "P \<Longrightarrow>\<^sub>A P' \<Longrightarrow> \<Turnstile> {P'} c {Q} \<Longrightarrow> \<Turnstile> {P} c {Q}"
  unfolding Valid_def entails_def by blast

theorem Valid_strengthen_post:
  "Q \<Longrightarrow>\<^sub>A Q' \<Longrightarrow> \<Turnstile> {P} c {Q} \<Longrightarrow> \<Turnstile> {P} c {Q'}"
  unfolding Valid_def entails_def by blast

theorem Valid_skip:
  "\<Turnstile> {P} Skip {P}"
  unfolding Valid_def
  by (auto elim: skipE)

theorem Valid_assign:
  "\<Turnstile> {\<lambda>s. Q (s(var := e s))} var ::= e {Q}"
  unfolding Valid_def
  by (auto elim: assignE)

theorem Valid_send:
  "\<Turnstile> {\<lambda>s tr. Q s (tr @ [OutBlock ch (e s)]) \<and>
              (\<forall>d::real>0. Q s (tr @ [WaitBlk d (\<lambda>_. State s) ({ch}, {}), OutBlock ch (e s)])) \<and>
              Q s (tr @ [WaitBlk \<infinity> (\<lambda>_. State s) ({ch}, {})])}
       Cm (ch[!]e) {Q}"
  unfolding Valid_def
  by (auto elim: sendE)

theorem Valid_receive:
  "\<Turnstile> {\<lambda>s tr. (\<forall>v. Q (s(var := v)) (tr @ [InBlock ch v])) \<and>
              (\<forall>d::real>0. \<forall>v. Q (s(var := v))
                (tr @ [WaitBlk d (\<lambda>_. State s) ({}, {ch}), InBlock ch v])) \<and>
              Q s (tr @ [WaitBlk \<infinity> (\<lambda>_. State s) ({}, {ch})])}
       Cm (ch[?]var) {Q}"
  unfolding Valid_def
  by (auto elim: receiveE)

theorem Valid_seq:
  "\<Turnstile> {P} c1 {Q} \<Longrightarrow> \<Turnstile> {Q} c2 {R} \<Longrightarrow> \<Turnstile> {P} c1; c2 {R}"
  unfolding Valid_def
  apply (auto elim!: seqE) by fastforce

theorem Valid_cond:
  "\<Turnstile> {P1} c1 {Q} \<Longrightarrow> \<Turnstile> {P2} c2 {Q} \<Longrightarrow>
   \<Turnstile> {\<lambda>s. if b s then P1 s else P2 s} IF b THEN c1 ELSE c2 FI {Q}"
  unfolding Valid_def
  by (auto elim: condE)

theorem Valid_wait:
  "\<Turnstile> {\<lambda>s tr. if e s > 0 then
                Q s (tr @ [WaitBlk (e s) (\<lambda>_. State s) ({}, {})])
              else Q s tr} Wait e {Q}"
  unfolding Valid_def
  by (auto elim: waitE)

theorem Valid_rep:
  assumes "\<Turnstile> {P} c {P}"
  shows "\<Turnstile> {P} Rep c {P}"
proof -
  have "big_step p s1 tr2 s2 \<Longrightarrow> p = Rep c \<Longrightarrow> \<forall>tr1. P s1 tr1 \<longrightarrow> P s2 (tr1 @ tr2)" for p s1 s2 tr2
    apply (induct rule: big_step.induct, auto)
    by (metis Valid_def append.assoc assms)
  then show ?thesis
    using assms unfolding Valid_def by auto
qed

theorem Valid_ichoice:
  assumes "\<Turnstile> {P1} c1 {Q}"
    and "\<Turnstile> {P2} c2 {Q}"
  shows "\<Turnstile> {\<lambda>s tr. P1 s tr \<and> P2 s tr} IChoice c1 c2 {Q}"
  using assms unfolding Valid_def by (auto elim: ichoiceE)

theorem Valid_ichoice_sp:
  assumes "\<Turnstile> {P} c1 {Q1}"
    and "\<Turnstile> {P} c2 {Q2}"
  shows "\<Turnstile> {P} IChoice c1 c2 {\<lambda>s tr. Q1 s tr \<or> Q2 s tr}"
  using assms unfolding Valid_def by (auto elim: ichoiceE)

theorem Valid_echoice:
  assumes "\<And>i. i<length es \<Longrightarrow>
    case es ! i of
      (ch[!]e, p2) \<Rightarrow>
        (\<exists>Q. \<Turnstile> {Q} p2 {R} \<and>
             (P \<Longrightarrow>\<^sub>A (\<lambda>s tr. Q s (tr @ [OutBlock ch (e s)]))) \<and>
             (P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>d::real>0. Q s (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), OutBlock ch (e s)]))))
    | (ch[?]var, p2) \<Rightarrow>
        (\<exists>Q. \<Turnstile> {Q} p2 {R} \<and>
             (P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>v. Q (s(var := v)) (tr @ [InBlock ch v]))) \<and>
             (P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>d::real>0. \<forall>v. Q (s(var := v)) (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), InBlock ch v]))))"
  shows "\<Turnstile> {P} EChoice es {R}"
proof -
  have a: "R s2 (tr1 @ (OutBlock ch (e s1) # tr2))"
    if *: "P s1 tr1"
          "i < length es"
          "es ! i = (ch[!]e, p2)"
          "big_step p2 s1 tr2 s2" for s1 tr1 s2 i ch e p2 tr2
  proof -
    from assms obtain Q where 1:
      "\<Turnstile> {Q} p2 {R}"
      "P \<Longrightarrow>\<^sub>A (\<lambda>s tr. Q s (tr @ [OutBlock ch (e s)]))"
      using *(2,3) by fastforce
    have 2: "Q s1 (tr1 @ [OutBlock ch (e s1)])"
      using 1(2) *(1) unfolding entails_def by auto
    then show ?thesis
      using *(4) 1(1) unfolding Valid_def by fastforce
  qed
  have b: "R s2 (tr1 @ (WaitBlk d (\<lambda>_. State s1) (rdy_of_echoice es) # OutBlock ch (e s1) # tr2))"
    if *: "P s1 tr1"
          "0 < (d::real)"
          "i < length es"
          "es ! i = (ch[!]e, p2)"
          "big_step p2 s1 tr2 s2" for s1 tr1 s2 d i ch e p2 tr2
  proof -
    obtain Q where 1:
      "\<Turnstile> {Q} p2 {R}"
      "P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>d::real>0. Q s (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), OutBlock ch (e s)]))"
      using *(3,4) assms by fastforce
    have 2: "Q s1 (tr1 @ [WaitBlk d (\<lambda>_. State s1) (rdy_of_echoice es), OutBlock ch (e s1)])"
      using 1(2) *(1,2) unfolding entails_def by auto
    then show ?thesis
      using *(5) 1(1) unfolding Valid_def by fastforce
  qed
  have c: "R s2 (tr1 @ (InBlock ch v # tr2))"
    if *: "P s1 tr1"
          "i < length es"
          "es ! i = (ch[?]var, p2)"
          "big_step p2 (s1(var := v)) tr2 s2" for s1 tr1 s2 i ch var p2 v tr2
  proof -
    from assms obtain Q where 1:
      "\<Turnstile> {Q} p2 {R}"
      "P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>v. Q (s(var := v)) (tr @ [InBlock ch v]))"
      using *(2,3) by fastforce
    have 2: "Q (s1(var := v)) (tr1 @ [InBlock ch v])"
      using 1(2) *(1) unfolding entails_def by auto
    then show ?thesis
      using *(4) 1(1) unfolding Valid_def by fastforce
  qed
  have d: "R s2 (tr1 @ (WaitBlk d (\<lambda>_. State s1) (rdy_of_echoice es) # InBlock ch v # tr2))"
    if *: "P s1 tr1"
          "0 < (d::real)"
          "i < length es"
          "es ! i = (ch[?]var, p2)"
          "big_step p2 (s1(var := v)) tr2 s2" for s1 tr1 s2 d i ch var p2 v tr2
  proof -
    from assms obtain Q where 1:
      "\<Turnstile> {Q} p2 {R}"
      "P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>d::real>0. \<forall>v. Q (s(var := v)) (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), InBlock ch v]))"
      using *(3,4) by fastforce
    have 2: "Q (s1(var := v)) (tr1 @ [WaitBlk d (\<lambda>_. State s1) (rdy_of_echoice es), InBlock ch v])"
      using 1(2) *(1,2) unfolding entails_def by auto
    then show ?thesis
      using *(5) 1(1) unfolding Valid_def by fastforce
  qed
  show ?thesis
    unfolding Valid_def apply auto
    apply (auto elim!: echoiceE) using a b c d by auto
qed

subsection \<open>Assertions on traces\<close>

definition entails_tassn :: "tassn \<Rightarrow> tassn \<Rightarrow> bool" (infixr "\<Longrightarrow>\<^sub>t" 25) where
  "(P \<Longrightarrow>\<^sub>t Q) \<longleftrightarrow> (\<forall>tr. P tr \<longrightarrow> Q tr)"

lemma entails_tassn_refl [simp]:
  "P \<Longrightarrow>\<^sub>t P"
  unfolding entails_tassn_def by auto

lemma entails_tassn_trans:
  "(P \<Longrightarrow>\<^sub>t Q) \<Longrightarrow> (Q \<Longrightarrow>\<^sub>t R) \<Longrightarrow> (P \<Longrightarrow>\<^sub>t R)"
  unfolding entails_tassn_def by auto

lemma entails_tassn_ex_pre:
  "(\<And>x. P x \<Longrightarrow>\<^sub>t Q) \<Longrightarrow> (\<lambda>tr. (\<exists>x. P x tr)) \<Longrightarrow>\<^sub>t Q"
  by (auto simp add: entails_tassn_def)

lemma entails_tassn_ex_post:
  "(\<exists>x. P \<Longrightarrow>\<^sub>t Q x) \<Longrightarrow> P \<Longrightarrow>\<^sub>t (\<lambda>tr. (\<exists>x. Q x tr))"
  by (auto simp add: entails_tassn_def)

definition emp_assn :: "tassn" ("emp\<^sub>t") where
  "emp\<^sub>t = (\<lambda>tr. tr = [])"

definition join_assn :: "tassn \<Rightarrow> tassn \<Rightarrow> tassn" (infixr "@\<^sub>t" 65) where
  "P @\<^sub>t Q = (\<lambda>tr. \<exists>tr1 tr2. P tr1 \<and> Q tr2 \<and> tr = tr1 @ tr2)"

definition magic_wand_assn :: "tassn \<Rightarrow> tassn \<Rightarrow> tassn" (infixr "@-" 65) where
  "Q @- P = (\<lambda>tr. \<forall>tr1. Q tr1 \<longrightarrow> P (tr @ tr1))"

definition all_assn :: "('a \<Rightarrow> tassn) \<Rightarrow> tassn" (binder "\<forall>\<^sub>t" 10) where
  "(\<forall>\<^sub>tv. P v) = (\<lambda>tr. \<forall>v. P v tr)"

definition ex_assn :: "('a \<Rightarrow> tassn) \<Rightarrow> tassn" (binder "\<exists>\<^sub>t" 10) where
  "(\<exists>\<^sub>tv. P v) = (\<lambda>tr. \<exists>v. P v tr)"

definition conj_assn :: "tassn \<Rightarrow> tassn \<Rightarrow> tassn" (infixr "\<and>\<^sub>t" 35) where
  "(P \<and>\<^sub>t Q) = (\<lambda>tr. P tr \<and> Q tr)"

definition disj_assn :: "tassn \<Rightarrow> tassn \<Rightarrow> tassn" (infixr "\<or>\<^sub>t" 25) where
  "(P \<or>\<^sub>t Q) = (\<lambda>tr. P tr \<or> Q tr)"

definition imp_assn :: "tassn \<Rightarrow> tassn \<Rightarrow> tassn" (infixr "\<longrightarrow>\<^sub>t" 25) where
  "(P \<longrightarrow>\<^sub>t Q) = (\<lambda>tr. P tr \<longrightarrow> Q tr)"

definition pure_assn :: "bool \<Rightarrow> tassn" ("\<up>") where
  "\<up>b = (\<lambda>_. b)"

inductive out_assn :: "gstate \<Rightarrow> cname \<Rightarrow> real \<Rightarrow> tassn" ("Out\<^sub>t") where
  "Out\<^sub>t s ch v [OutBlock ch v]"
| "(d::real) > 0 \<Longrightarrow> Out\<^sub>t s ch v [WaitBlk (ereal d) (\<lambda>_. s) ({ch}, {}), OutBlock ch v]"
| "Out\<^sub>t s ch v [WaitBlk \<infinity> (\<lambda>_. s) ({ch}, {})]"

inductive in_assn :: "gstate \<Rightarrow> cname \<Rightarrow> real \<Rightarrow> tassn" ("In\<^sub>t") where
  "In\<^sub>t s ch v [InBlock ch v]"
| "(d::real) > 0 \<Longrightarrow> In\<^sub>t s ch v [WaitBlk (ereal d) (\<lambda>_. s) ({}, {ch}), InBlock ch v]"
| "In\<^sub>t s ch v [WaitBlk \<infinity> (\<lambda>_. s) ({}, {ch})]"

inductive io_assn :: "cname \<Rightarrow> real \<Rightarrow> tassn" ("IO\<^sub>t") where
  "IO\<^sub>t ch v [IOBlock ch v]"

inductive wait_assn :: "real \<Rightarrow> (real \<Rightarrow> gstate) \<Rightarrow> rdy_info \<Rightarrow> tassn" ("Wait\<^sub>t") where
  "d > 0 \<Longrightarrow> Wait\<^sub>t d p rdy [WaitBlk d (\<lambda>\<tau>. p \<tau>) rdy]"
| "d \<le> 0 \<Longrightarrow> Wait\<^sub>t d p rdy []"

lemma emp_unit_left [simp]:
  "(emp\<^sub>t @\<^sub>t P) = P"
  unfolding join_assn_def emp_assn_def by auto

lemma emp_unit_right [simp]:
  "(P @\<^sub>t emp\<^sub>t) = P"
  unfolding join_assn_def emp_assn_def by auto

lemma emp_unit_right':
  "P = (P @\<^sub>t emp\<^sub>t) "
  unfolding join_assn_def emp_assn_def by auto

lemma join_assoc:
  "(P @\<^sub>t Q) @\<^sub>t R = P @\<^sub>t (Q @\<^sub>t R)"
  unfolding join_assn_def by fastforce

lemma entails_mp_emp:
  "emp\<^sub>t \<Longrightarrow>\<^sub>t P @- P"
  unfolding entails_tassn_def emp_assn_def magic_wand_assn_def by auto

lemma entails_mp:
  "Q \<Longrightarrow>\<^sub>t P @- (Q @\<^sub>t P)"
  unfolding entails_tassn_def magic_wand_assn_def join_assn_def by auto

lemma magic_wand_mono:
  "P \<Longrightarrow>\<^sub>t Q \<Longrightarrow> (R @- P) \<Longrightarrow>\<^sub>t (R @- Q)"
  unfolding entails_tassn_def magic_wand_assn_def by auto

definition false_assn :: "tassn" ("false\<^sub>A") where
  "false_assn tr = False"

lemma false_assn_entails [simp]:
  "false\<^sub>A \<Longrightarrow>\<^sub>t P"
  by (simp add: entails_tassn_def false_assn_def)

lemma pure_assn_entails [simp]:
  "(\<up>b \<and>\<^sub>t P \<Longrightarrow>\<^sub>t Q) = (b \<longrightarrow> P \<Longrightarrow>\<^sub>t Q)"
  unfolding entails_tassn_def conj_assn_def pure_assn_def by auto

lemma entails_tassn_cancel_left:
  "Q \<Longrightarrow>\<^sub>t R \<Longrightarrow> P @\<^sub>t Q \<Longrightarrow>\<^sub>t P @\<^sub>t R"
  by (auto simp add: entails_tassn_def join_assn_def)

lemma entails_tassn_cancel_left_emp:
  "Q \<Longrightarrow>\<^sub>t emp\<^sub>t  \<Longrightarrow> P @\<^sub>t Q \<Longrightarrow>\<^sub>t P "
  by (auto simp add: entails_tassn_def join_assn_def emp_assn_def)

lemma entails_tassn_cancel_right:
  "P \<Longrightarrow>\<^sub>t Q \<Longrightarrow> P @\<^sub>t R \<Longrightarrow>\<^sub>t Q @\<^sub>t R"
  by (auto simp add: entails_tassn_def join_assn_def)

lemma entails_tassn_cancel_both:
  "P \<Longrightarrow>\<^sub>t Q \<Longrightarrow> R \<Longrightarrow>\<^sub>t S \<Longrightarrow> P @\<^sub>t R \<Longrightarrow>\<^sub>t Q @\<^sub>t S"
  by (auto simp add: entails_tassn_def join_assn_def)

lemma entails_tassn_conj:
  "P \<Longrightarrow>\<^sub>t Q \<Longrightarrow> P \<Longrightarrow>\<^sub>t R \<Longrightarrow> P \<Longrightarrow>\<^sub>t (Q \<and>\<^sub>t R)"
  by (auto simp add: entails_tassn_def conj_assn_def)

lemma entails_tassn_exI:
  "P \<Longrightarrow>\<^sub>t Q x \<Longrightarrow> P \<Longrightarrow>\<^sub>t (\<exists>\<^sub>t x. Q x)"
  unfolding ex_assn_def entails_tassn_def by auto

lemma conj_join_distrib [simp]:
  "(\<up>b \<and>\<^sub>t P) @\<^sub>t Q = (\<up>b \<and>\<^sub>t (P @\<^sub>t Q))"
  by (auto simp add: join_assn_def conj_assn_def pure_assn_def)

lemma conj_join_distrib2 [simp]:
  "(\<lambda>tr. b \<and> P tr) @\<^sub>t Q = (\<up>b \<and>\<^sub>t (P @\<^sub>t Q))"
  by (auto simp add: pure_assn_def conj_assn_def join_assn_def)

lemma wait_le_zero [simp]:
  "d \<le> 0 \<Longrightarrow> Wait\<^sub>t d p rdy = emp\<^sub>t"
  apply (rule ext) subgoal for tr
    apply auto
     apply (cases rule: wait_assn.cases)
    apply (auto simp add: emp_assn_def)
    by (auto intro: wait_assn.intros)
  done

text \<open>Simpler forms of weakest precondition\<close>

theorem Valid_send':
  "\<Turnstile> {\<lambda>s. Out\<^sub>t (State s) ch (e s) @- Q s}
       Cm (ch[!]e)
      {Q}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_send)
  unfolding entails_def magic_wand_assn_def
  by (auto intro: out_assn.intros)

theorem Valid_receive':
  "\<Turnstile> {\<lambda>s. \<forall>\<^sub>tv. In\<^sub>t (State s) ch v @- Q (s(var := v))}
       Cm (ch[?]var)
      {Q}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_receive)
  unfolding entails_def magic_wand_assn_def all_assn_def
  by (metis fun_upd_triv in_assn.intros)

theorem Valid_wait':
  "\<Turnstile>
    {\<lambda>s. if e s > 0 then Wait\<^sub>t (e s) (\<lambda>_. State s) ({}, {}) @- Q s else Q s}
      Wait e
    {Q}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_wait)
  unfolding entails_def magic_wand_assn_def
  by (auto intro: wait_assn.intros)

text \<open>Strongest postcondition forms\<close>

theorem Valid_assign_sp:
  "\<Turnstile> {\<lambda>s t. P s t}
       Assign var e
      {\<lambda>s t. \<exists>x. s var = e (s(var := x)) \<and> P (s(var := x)) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_assign)
  apply (auto simp add: entails_def)
  subgoal for s tr
    apply (rule exI[where x="s var"])
    by auto
  done

theorem Valid_send_sp:
  "\<Turnstile> {\<lambda>s t. P s t}
       Cm (ch[!]e)
     {\<lambda>s t. (P s @\<^sub>t Out\<^sub>t (State s) ch (e s)) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_send')
  by (auto simp add: entails_def magic_wand_assn_def join_assn_def)

theorem Valid_receive_sp:
  "\<Turnstile> {\<lambda>s t. P s t}
       Cm (ch[?]var)
      {\<lambda>s t. \<exists>x v. (\<up>(s var = v) \<and>\<^sub>t (P(s(var := x)) @\<^sub>t In\<^sub>t (State (s(var := x))) ch v)) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_receive)
  unfolding entails_def
  apply (auto simp add: join_assn_def)
  subgoal for s tr v
    apply (rule exI[where x="s var"])
    apply (rule exI[where x=v])
    apply (auto simp add: conj_assn_def pure_assn_def)
    apply (rule exI[where x=tr]) by (auto intro: in_assn.intros)
  subgoal for s tr d v
    apply (rule exI[where x="s var"])
    apply (rule exI[where x=v])
    apply (auto simp add: conj_assn_def pure_assn_def)
    apply (rule exI[where x=tr])
    apply auto apply (rule in_assn.intros) by auto
  subgoal for s tr
    apply (rule exI[where x="s var"])
    apply (auto simp add: conj_assn_def pure_assn_def)
    apply (rule exI[where x=tr])
    apply auto by (rule in_assn.intros)
  done

theorem Valid_wait_sp:
  "\<Turnstile> {\<lambda>s t. P s t}
      Wait e
     {\<lambda>s t. (P s @\<^sub>t (if e s > 0 then Wait\<^sub>t (e s) (\<lambda>_. State s) ({}, {}) else emp\<^sub>t)) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_wait')
  by (auto simp add: entails_def join_assn_def magic_wand_assn_def emp_assn_def)

theorem Valid_cond_sp:
  assumes "\<Turnstile> {\<lambda>s t. b s \<and> P s t} c1 {Q1}"
    and "\<Turnstile> {\<lambda>s t. \<not>b s \<and> P s t} c2 {Q2}"
  shows "\<Turnstile> {\<lambda>s t. P s t}
             IF b THEN c1 ELSE c2 FI
            {\<lambda>s t. Q1 s t \<or> Q2 s t}"
  using assms unfolding Valid_def
  by (auto elim!: condE)

theorem Valid_cond_sp2:
  assumes "\<Turnstile> {\<lambda>s t. s = st \<and> P s t} c1 {Q1}"
    and "\<Turnstile> {\<lambda>s t. s = st \<and> P s t} c2 {Q2}"
  shows "\<Turnstile> {\<lambda>s t. s = st \<and> P s t}
             IF b THEN c1 ELSE c2 FI
            {\<lambda>s t. if b st then Q1 s t else Q2 s t}"
  using assms unfolding Valid_def
  by (auto elim!: condE)

theorem Valid_if_split:
  assumes "b \<Longrightarrow> \<Turnstile> {P1} c {Q1}"
    and "\<not>b \<Longrightarrow> \<Turnstile> {P2} c {Q2}"
  shows "\<Turnstile> {\<lambda>s t. if b then P1 s t else P2 s t}
             c
            {\<lambda>s t. if b then Q1 s t else Q2 s t}"
  using assms unfolding Valid_def
  by auto

theorem Valid_assign_sp_st:
  "\<Turnstile> {\<lambda>s t. s = st \<and> P s t}
        x ::= e
      {\<lambda>s t. s = st(x := e st) \<and> P st t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_assign)
  by (auto simp add: entails_def)

theorem Valid_assign_sp_bst:
  "\<Turnstile> {\<lambda>s t. s = st \<and> b s \<and> P s t}
        x ::= e
      {\<lambda>s t. s = st(x := e st) \<and> b st \<and> P st t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_assign)
  by (auto simp add: entails_def)

theorem Valid_send_sp_st:
  "\<Turnstile> {\<lambda>s t. s = st \<and> P s t}
       Cm (ch[!]e)
      {\<lambda>s t. s = st \<and> (P st @\<^sub>t Out\<^sub>t (State st) ch (e st)) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_send')
  by (auto simp add: entails_def magic_wand_assn_def join_assn_def)

theorem Valid_send_sp_bst:
  "\<Turnstile> {\<lambda>s t. s = st \<and> b s \<and> P s t}
       Cm (ch[!]e)
      {\<lambda>s t. s = st \<and> b s \<and> (P st @\<^sub>t Out\<^sub>t (State st) ch (e st)) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_send')
  by (auto simp add: entails_def magic_wand_assn_def join_assn_def)

theorem Valid_receive_sp_st:
  "\<Turnstile> {\<lambda>s t. s = st \<and> P s t}
        Cm (ch[?]var)
      {\<lambda>s t. \<exists>v. s = st(var := v) \<and> (P st @\<^sub>t In\<^sub>t (State st) ch v) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_receive)
  unfolding entails_def
  apply (auto simp add: all_assn_def magic_wand_assn_def emp_assn_def join_assn_def)
  subgoal for tr v
    apply (rule exI[where x=v])
    apply auto apply (rule exI[where x=tr])
    by (simp add: in_assn.intros)
  subgoal for tr d v
    apply (rule exI[where x=v])
    apply auto apply (rule exI[where x=tr])
    using in_assn.intros(2) by auto
  subgoal for tr
    apply (rule exI[where x="st var"])
    apply auto apply (rule exI[where x=tr])
    by (metis in_assn.intros(3) infinity_ereal_def)
  done

theorem Valid_receive_sp_bst:
  "\<Turnstile> {\<lambda>s t. s = st \<and> b s \<and> P s t}
        Cm (ch[?]var)
      {\<lambda>s t. \<exists>v. s = st(var := v) \<and> b st \<and> (P st @\<^sub>t In\<^sub>t (State st) ch v) t}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_receive)
  unfolding entails_def
  apply (auto simp add: all_assn_def magic_wand_assn_def emp_assn_def join_assn_def)
  subgoal for tr v
    apply (rule exI[where x=v])
    apply auto apply (rule exI[where x=tr])
    by (simp add: in_assn.intros)
  subgoal for tr d v
    apply (rule exI[where x=v])
    apply auto apply (rule exI[where x=tr])
    using in_assn.intros(2) by auto
  subgoal for tr
    apply (rule exI[where x="st var"])
    apply auto apply (rule exI[where x=tr])
    by (metis in_assn.intros(3) infinity_ereal_def)
  done

theorem Valid_wait_sp_st:
  "\<Turnstile>
    {\<lambda>s tr. s = st \<and> P s tr}
      Wait e
    {\<lambda>s tr. s = st \<and> (P s @\<^sub>t (if e s > 0 then Wait\<^sub>t (e s) (\<lambda>_. State st) ({}, {}) else emp\<^sub>t)) tr}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_wait')
  by (auto simp add: entails_def join_assn_def magic_wand_assn_def emp_assn_def)

subsection \<open>Rules for internal and external choice\<close>

text \<open>Additional assertions\<close>

inductive inrdy_assn :: "state \<Rightarrow> cname \<Rightarrow> real \<Rightarrow> rdy_info \<Rightarrow> tassn" ("Inrdy\<^sub>t") where
  "Inrdy\<^sub>t s ch v rdy [InBlock ch v]"
| "(d::real) > 0 \<Longrightarrow> Inrdy\<^sub>t s ch v rdy [WaitBlk d (\<lambda>_. State s) rdy, InBlock ch v]"

inductive outrdy_assn :: "state \<Rightarrow> cname \<Rightarrow> real \<Rightarrow> rdy_info \<Rightarrow> tassn" ("Outrdy\<^sub>t") where
  "Outrdy\<^sub>t s ch v rdy [OutBlock ch v]"
| "(d::real) > 0 \<Longrightarrow> Outrdy\<^sub>t s ch v rdy [WaitBlk d (\<lambda>_. State s) rdy, OutBlock ch v]"

text \<open>Simpler form of weakest precondition\<close>

theorem Valid_echoice':
  assumes "\<And>i. i<length es \<Longrightarrow>
    case es ! i of
      (ch[!]e, p2) \<Rightarrow>
        (\<exists>Q. \<Turnstile> {Q} p2 {R} \<and>
            (P \<Longrightarrow>\<^sub>A (\<lambda>s. Outrdy\<^sub>t s ch (e s) (rdy_of_echoice es) @- Q s)))
    | (ch[?]var, p2) \<Rightarrow>
        (\<exists>Q. \<Turnstile> {Q} p2 {R} \<and>
            (P \<Longrightarrow>\<^sub>A (\<lambda>s. \<forall>\<^sub>tv. Inrdy\<^sub>t s ch v (rdy_of_echoice es) @- Q (s(var := v)))))"
  shows "\<Turnstile> {P} EChoice es {R}"
proof -
  have 1: "\<exists>Q. \<Turnstile> {Q} p {R} \<and>
           (P \<Longrightarrow>\<^sub>A (\<lambda>s tr. Q s (tr @ [OutBlock ch (e s)]))) \<and>
           (P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>d::real>0. Q s (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), OutBlock ch (e s)])))"
    if *: "i < length es" "es ! i = (ch[!]e, p)" for i ch e p
  proof -
    from assms obtain Q where
      Q: "\<Turnstile> {Q} p {R} \<and> (P \<Longrightarrow>\<^sub>A (\<lambda>s. Outrdy\<^sub>t s ch (e s) (rdy_of_echoice es) @- Q s))"
      using * by fastforce
    show ?thesis
      apply (rule exI[where x=Q])
      using Q outrdy_assn.intros by (auto simp add: entails_def magic_wand_assn_def)
  qed
  have 2: "\<exists>Q. \<Turnstile> {Q} p {R} \<and>
           (P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>v. Q (s(var := v)) (tr @ [InBlock ch v]))) \<and>
           (P \<Longrightarrow>\<^sub>A (\<lambda>s tr. \<forall>d::real>0. \<forall>v. Q (s(var := v)) (tr @ [WaitBlk d (\<lambda>_. State s) (rdy_of_echoice es), InBlock ch v])))"
    if *: "i < length es" "es ! i = (ch[?]var, p)" for i ch var p
  proof -
    from assms obtain Q where
      Q: "\<Turnstile> {Q} p {R} \<and> (P \<Longrightarrow>\<^sub>A (\<lambda>s. \<forall>\<^sub>tv. Inrdy\<^sub>t s ch v (rdy_of_echoice es) @- Q (s(var := v))))"
      using * by fastforce
    show ?thesis
      apply (rule exI[where x=Q])
      using Q inrdy_assn.intros by (auto simp add: entails_def magic_wand_assn_def all_assn_def)
  qed
  show ?thesis
    apply (rule Valid_echoice)
    subgoal for i apply (cases "es ! i")
      subgoal for ch p apply (cases ch) apply auto
        using 1 2 by auto
      done
    done
qed

text \<open>Strongest postcondition form\<close>

theorem Valid_echoice_sp:
  assumes "\<And>i. i<length es \<Longrightarrow>
    case es ! i of
      (ch[!]e, p2) \<Rightarrow>
        \<Turnstile> {\<lambda>s tr. s = st \<and> (P s @\<^sub>t Outrdy\<^sub>t s ch (e s) (rdy_of_echoice es)) tr} p2 {Q}
    | (ch[?]var, p2) \<Rightarrow>
        \<Turnstile> {\<lambda>s tr. (\<exists>v. s = st(var := v) \<and> (P st @\<^sub>t Inrdy\<^sub>t st ch v (rdy_of_echoice es)) tr)} p2 {Q}"
  shows "\<Turnstile>
    {\<lambda>s tr. s = st \<and> P s tr}
      EChoice es
    {Q}"
  apply (rule Valid_echoice')
  subgoal for i
    apply (cases "es ! i") apply auto
    subgoal for comm p2
      apply (cases comm)
      subgoal for ch e
        apply auto
        apply (rule exI[where x="\<lambda>s tr. s = st \<and> (P s @\<^sub>t Outrdy\<^sub>t s ch (e s) (rdy_of_echoice es)) tr"])
        apply auto
        using assms apply fastforce
        by (auto simp add: entails_def join_assn_def magic_wand_assn_def)
      subgoal for ch var
        apply auto
        apply (rule exI[where x="\<lambda>s tr. (\<exists>v. s = st(var := v) \<and> (P st @\<^sub>t Inrdy\<^sub>t st ch v (rdy_of_echoice es)) tr)"])
        apply auto
        using assms apply fastforce
        by (auto simp add: entails_def magic_wand_assn_def join_assn_def all_assn_def)
      done
    done
  done

text \<open>Some special cases of EChoice\<close>

lemma InIn_lemma:
  assumes "Q ch1 var1 p1"
    and "Q ch2 var2 p2"
    and "i < length [(ch1[?]var1, p1), (ch2[?]var2, p2)]"
  shows "case [(ch1[?]var1, p1), (ch2[?]var2, p2)] ! i of
            (ch[!]e, p1) \<Rightarrow> P ch e p1
          | (ch[?]var, p1) \<Rightarrow> Q ch var p1"
proof -
  have "case comm of ch[!]e \<Rightarrow> P ch e p | ch[?]var \<Rightarrow> Q ch var p"
    if "i < Suc (Suc 0)"
       "[(ch1[?]var1, p1), (ch2[?]var2, p2)] ! i = (comm, p)" for comm p i
  proof -
    have "i = 0 \<or> i = 1"
      using that(1) by auto
    then show ?thesis
      apply (rule disjE)
      using that(2) assms by auto
  qed
  then show ?thesis
    using assms(3) by auto
qed

theorem Valid_echoice_InIn:
  assumes "\<Turnstile> {Q1} p1 {R}"
    and "\<Turnstile> {Q2} p2 {R}"
  shows "\<Turnstile>
    {\<lambda>s tr. (\<forall>v. Q1 (s(var1 := v)) (tr @ [InBlock ch1 v])) \<and>
            (\<forall>d::real>0. \<forall>v. Q1 (s(var1 := v)) (tr @ [WaitBlk d (\<lambda>_. State s) ({}, {ch1, ch2}), InBlock ch1 v])) \<and>
            (\<forall>v. Q2 (s(var2 := v)) (tr @ [InBlock ch2 v])) \<and>
            (\<forall>d::real>0. \<forall>v. Q2 (s(var2 := v)) (tr @ [WaitBlk d (\<lambda>_. State s) ({}, {ch1, ch2}), InBlock ch2 v]))}
      EChoice [(ch1[?]var1, p1), (ch2[?]var2, p2)]
    {R}"
  apply (rule Valid_echoice)
  apply (rule InIn_lemma)
  subgoal apply (rule exI[where x=Q1])
    by (auto simp add: assms entails_def)
  apply (rule exI[where x=Q2])
  by (auto simp add: assms entails_def)

theorem Valid_echoice_InIn':
  assumes "\<Turnstile> {Q1} p1 {R}"
    and "\<Turnstile> {Q2} p2 {R}"
  shows "\<Turnstile>
    {\<lambda>s. (\<forall>\<^sub>tv. ((Inrdy\<^sub>t s ch1 v ({}, {ch1, ch2})) @- Q1 (s(var1 := v)))) \<and>\<^sub>t
         (\<forall>\<^sub>tv. ((Inrdy\<^sub>t s ch2 v ({}, {ch1, ch2})) @- Q2 (s(var2 := v))))}
      EChoice [(ch1[?]var1, p1), (ch2[?]var2, p2)]
    {R}"
  apply (rule Valid_weaken_pre)
   prefer 2 apply (rule Valid_echoice_InIn[OF assms(1-2)])
  apply (auto simp add: entails_def magic_wand_assn_def conj_assn_def all_assn_def)
  by (auto simp add: inrdy_assn.intros)

theorem Valid_echoice_InIn_sp:
  assumes "\<And>v. \<Turnstile> {\<lambda>s tr. s = st(var1 := v) \<and> (P st @\<^sub>t Inrdy\<^sub>t st ch1 v ({}, {ch1, ch2})) tr} p1 {Q1 v}"
    and "\<And>v. \<Turnstile> {\<lambda>s tr. s = st(var2 := v) \<and> (P st @\<^sub>t Inrdy\<^sub>t st ch2 v ({}, {ch1, ch2})) tr} p2 {Q2 v}"
  shows
   "\<Turnstile> {\<lambda>s tr. s = st \<and> P s tr}
        EChoice [(ch1[?]var1, p1), (ch2[?]var2, p2)]
       {\<lambda>s tr. (\<exists>v. Q1 v s tr) \<or> (\<exists>v. Q2 v s tr)}"
  apply (rule Valid_echoice_sp)
  apply (rule InIn_lemma)
  using assms apply (auto simp add: Valid_def) by blast+

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*
 * Accessing nested structs.
 * Testcase for bug VER-321.
 *)
theory nested_struct imports "AutoCorres.AutoCorres" begin

external_file "nested_struct.c"
install_C_file "nested_struct.c"
(* Nested struct translation currently only works for packed_type types. *)
instance s1_C :: array_outer_packed by intro_classes auto
instance s3_C :: array_outer_packed by intro_classes auto
autocorres "nested_struct.c"

context nested_struct begin

thm f'_def test'_def

lemma "\<lbrace> \<lambda>s. is_valid_point1_C s p1 \<and> is_valid_point2_C s p2 \<rbrace>
         test' p1 p2
       \<lbrace> \<lambda>_ s. num_C.n_C (point1_C.x_C (heap_point1_C s p1)) =
                 index (point2_C.n_C (heap_point2_C s p2)) 0 \<rbrace>!"
  unfolding test'_def f'_def
  apply wp
  apply (clarsimp simp: fun_upd_apply)
  done

thm g'_def

lemma "\<lbrace> \<lambda>h. is_valid_s4_C h s \<and>
             s1_C.x_C (index (s2_C.x_C (s3_C.x_C (index (s4_C.x_C (heap_s4_C h s)) 0))) 0) = v \<rbrace>
         g' s
       \<lbrace> \<lambda>_ h. index (s4_C.x_C (heap_s4_C h s)) 0 = index (s4_C.x_C (heap_s4_C h s)) 1 \<and>
               s3_C.x_C (index (s4_C.x_C (heap_s4_C h s)) 0) = s3_C.y_C (index (s4_C.x_C (heap_s4_C h s)) 0) \<and>
               index (s2_C.x_C (s3_C.x_C (index (s4_C.x_C (heap_s4_C h s)) 0))) 0 =
                 index (s2_C.x_C (s3_C.x_C (index (s4_C.x_C (heap_s4_C h s)) 0))) 1 \<and>
               s1_C.x_C (index (s2_C.x_C (s3_C.x_C (index (s4_C.x_C (heap_s4_C h s)) 0))) 0) =
                 s1_C.y_C (index (s2_C.x_C (s3_C.x_C (index (s4_C.x_C (heap_s4_C h s)) 0))) 0) \<and>
               s1_C.x_C (index (s2_C.x_C (s3_C.x_C (index (s4_C.x_C (heap_s4_C h s)) 0))) 0) = v
       \<rbrace>!"
  unfolding g'_def
  apply wp
  apply (clarsimp simp: fun_upd_apply)
  done

end

end


(*  Title:      HOL/Auth/n_german_lemma_inv__10_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_german Protocol Case Study*}

theory n_german_lemma_inv__10_on_rules imports n_german_lemma_on_inv__10
begin
section{*All lemmas on causal relation between inv__10*}
lemma lemma_inv__10_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv2. p__Inv2\<le>N\<and>f=inv__10  p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__0Vsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__1Vsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqEVsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__10) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__10) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end