section \<open>Arrays\<close>
theory LLVM_DS_Array
imports LLVM_DS_Arith
begin

text \<open>Implementing Lists by Arrays\<close>

context begin

  interpretation llvm_prim_mem_setup .

  definition "array_assn \<equiv> mk_assn (\<lambda>xs p.
    \<upharpoonleft>(ll_range {0..<int (length xs)}) ((!) xs o nat) p ** ll_malloc_tag (int (length xs)) p
  )"

  lemma array_assn_not_null[simp]: "\<upharpoonleft>array_assn xs null = sep_false"
    by (auto simp: array_assn_def)

  definition [llvm_inline]: "array_new TYPE('a::llvm_rep) n \<equiv> ll_malloc TYPE('a) n"
  definition [llvm_inline]: "array_free a \<equiv> ll_free a"
  definition [llvm_inline]: "array_nth a i \<equiv> doM { p \<leftarrow> ll_ofs_ptr a i; ll_load p }"
  definition [llvm_inline]: "array_upd a i x \<equiv> doM { p \<leftarrow> ll_ofs_ptr a i; ll_store x p; return a }"

  lemma ll_range_cong: "I=I' \<Longrightarrow> (\<And>i. i\<in>I' \<Longrightarrow> f i = f' i) \<Longrightarrow> p=p'
    \<Longrightarrow> \<upharpoonleft>(ll_range I) f p = \<upharpoonleft>(ll_range I') f' p'"
    unfolding ll_range_def
    by simp

  lemma array_assn_cnv_range_malloc:
    "\<upharpoonleft>array_assn (replicate n init) p = (\<upharpoonleft>(ll_range {0..<int n}) (\<lambda>_. init) p ** ll_malloc_tag (int n) p)"
    unfolding array_assn_def
    apply (simp add: sep_algebra_simps)
    apply (rule sep_conj_trivial_strip2)
    apply (rule ll_range_cong)
    by auto

  lemma array_assn_cnv_range_upd:
    "\<upharpoonleft>array_assn (xs[i:=x]) p = (\<upharpoonleft>(ll_range {0..<int (length xs)}) (((!) xs \<circ> nat)(int i := x)) p ** ll_malloc_tag (int (length xs)) p)"
    unfolding array_assn_def
    apply (simp add: sep_algebra_simps)
    apply (rule sep_conj_trivial_strip2)
    apply (rule ll_range_cong)
    by auto

  lemma pos_sint_to_uint: "0 \<le> sint i \<Longrightarrow> sint i = uint i"
    by (smt Suc_n_not_le_n Suc_pred bintrunc_mod2p int_mod_eq' len_gt_0 power_increasing_iff sint_range' uint_sint)

  lemma array_new_rule_sint[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>sint.assn n ni ** \<up>\<^sub>d(n>0))
    (array_new TYPE('a::llvm_rep) ni)
    (\<upharpoonleft>array_assn (replicate (nat n) init))"
    unfolding array_new_def array_assn_cnv_range_malloc sint.assn_def
    supply [simp] = pos_sint_to_uint
    by vcg

  lemma array_new_rule_uint[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>uint.assn n ni ** \<up>\<^sub>d(n>0))
    (array_new TYPE('a::llvm_rep) ni)
    (\<upharpoonleft>array_assn (replicate (nat n) init))"
    unfolding array_new_def array_assn_cnv_range_malloc uint.assn_def
    by vcg

  lemma array_new_rule_unat[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>unat.assn n ni ** \<up>\<^sub>d(n>0))
    (array_new TYPE('a::llvm_rep) ni)
    (\<upharpoonleft>array_assn (replicate n init))"
    unfolding array_new_def array_assn_cnv_range_malloc unat.assn_def
    apply (simp add: )
    by vcg

  lemma array_new_rule_snat[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>snat.assn n ni ** \<up>\<^sub>d(n>0))
    (array_new TYPE('a::llvm_rep) ni)
    (\<upharpoonleft>array_assn (replicate n init))"
    unfolding array_new_def array_assn_cnv_range_malloc snat.assn_def
    supply [simp] = cnv_snat_to_uint and [simp del] = nat_uint_eq
    by vcg

  lemma array_free_rule[vcg_rules]: "llvm_htriple (\<upharpoonleft>array_assn xs p) (array_free p) (\<lambda>_. \<box>)"
    unfolding array_free_def array_assn_def
    by vcg

  lemma array_cast_index:
    assumes "uint (ii::'a::len word) < max_sint LENGTH('a)"
    shows "sint ii = uint ii" "nat (uint ii) < n \<longleftrightarrow> uint ii < int n"
      "unat ii < n \<longleftrightarrow> uint ii < int n"
    using assms
    by (simp_all add: max_sint_def msb_uint_big sint_eq_uint unat_def nat_less_iff del: nat_uint_eq)

  abbreviation (input) "in_range_nat i (ii::'a::len word) xs \<equiv> i<length xs \<and> int i<max_sint LENGTH('a)"
  abbreviation (input) "in_range_uint i (ii::'a::len word) xs \<equiv> i<int (length xs) \<and> i<max_sint LENGTH('a)"

  lemma array_nth_rule_sint[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>array_assn xs p ** \<upharpoonleft>sint.assn i ii ** \<up>\<^sub>d(0\<le>i \<and> i<int (length xs)))
    (array_nth p ii)
    (\<lambda>r. \<up>(r = xs!nat i) ** \<upharpoonleft>array_assn xs p)"
    unfolding array_nth_def array_assn_def sint.assn_def
    by vcg

  lemma array_nth_rule_uint[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>array_assn xs p ** \<upharpoonleft>uint.assn i ii ** \<up>\<^sub>d(in_range_uint i ii xs))
    (array_nth p ii)
    (\<lambda>r. \<up>(r = xs!nat i) ** \<upharpoonleft>array_assn xs p)"
    unfolding array_nth_def array_assn_def uint.assn_def
    supply [simp] = array_cast_index
    by vcg

  lemma array_nth_rule_unat[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>array_assn xs p ** \<upharpoonleft>unat.assn i ii ** \<up>\<^sub>d(in_range_nat i ii xs))
    (array_nth p ii)
    (\<lambda>r. \<up>(r = xs!i) ** \<upharpoonleft>array_assn xs p)"
    unfolding array_nth_def array_assn_def unat.assn_def unat_def
    supply [simp] = array_cast_index
    by vcg

  lemma array_nth_rule_snat[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>array_assn xs p ** \<upharpoonleft>snat.assn i ii ** \<up>\<^sub>d(i<length xs))
    (array_nth p ii)
    (\<lambda>r. \<up>(r = xs!i) ** \<upharpoonleft>array_assn xs p)"
    unfolding array_nth_def array_assn_def snat.assn_def
    supply [simp] = cnv_snat_to_uint and [simp del] = nat_uint_eq
    by vcg

  lemma array_upd_rule_sint[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>array_assn xs p ** \<upharpoonleft>sint.assn i ii ** \<up>\<^sub>d(0\<le>i \<and> i < int (length xs)))
    (array_upd p ii x)
    (\<lambda>r. \<up>(r=p) ** \<upharpoonleft>array_assn (xs[nat i:=x]) p)"
    unfolding array_assn_cnv_range_upd
    unfolding array_upd_def array_assn_def sint.assn_def
    supply [fri_rules] = fri_abs_cong_rl
    by vcg

  lemma array_upd_rule_uint[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>array_assn xs p ** \<upharpoonleft>uint.assn i ii ** \<up>\<^sub>din_range_uint i ii xs)
    (array_upd p ii x)
    (\<lambda>r. \<up>(r=p) ** \<upharpoonleft>array_assn (xs[nat i:=x]) p)"
    unfolding array_assn_cnv_range_upd
    unfolding array_upd_def array_assn_def uint.assn_def
    supply [simp] = array_cast_index
    supply [fri_rules] = fri_abs_cong_rl
    by vcg

  lemma array_upd_rule_nat[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>array_assn xs p ** \<upharpoonleft>unat.assn i ii ** \<up>\<^sub>din_range_nat i ii xs)
    (array_upd p ii x)
    (\<lambda>r. \<up>(r=p) ** \<upharpoonleft>array_assn (xs[i:=x]) p)"
    unfolding array_assn_cnv_range_upd
    unfolding array_upd_def array_assn_def unat.assn_def unat_def
    supply [simp] = array_cast_index
    supply [fri_rules] = fri_abs_cong_rl
    by vcg

  lemma array_upd_rule_snat[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>array_assn xs p ** \<upharpoonleft>snat.assn i ii ** \<up>\<^sub>d(i<length xs))
    (array_upd p ii x)
    (\<lambda>r. \<up>(r=p) ** \<upharpoonleft>array_assn (xs[i:=x]) p)"
    unfolding array_assn_cnv_range_upd
    unfolding array_upd_def array_assn_def snat.assn_def
    supply [simp] = cnv_snat_to_uint and [simp del] = nat_uint_eq
    supply [fri_rules] = fri_abs_cong_rl
    apply vcg
    done

end

subsection \<open>Basic Algorithms\<close>

subsubsection \<open>Array-Copy\<close>
definition "arraycpy dst src (n::'a::len2 word) \<equiv>
  doM {
    llc_while
      (\<lambda>i. ll_icmp_ult i n)
      (\<lambda>i. doM {
        x\<leftarrow>array_nth src i;
        array_upd dst i x;
        i\<leftarrow>ll_add i (signed_nat 1);
        return i
      }) (signed_nat 0);
    return ()
  }"

declare arraycpy_def[llvm_code]

export_llvm "arraycpy :: 8 word ptr \<Rightarrow> _ \<Rightarrow> 64 word \<Rightarrow> _" is "arraycpy"

(* TODO: Move / REMOVE?*)
lemma unat_not_msb_imp_less_max_sint: "x \<in> unat ` {w::'a::len word. \<not> msb w} \<Longrightarrow> int x < max_sint LENGTH('a)"
  by (auto simp: unat_def[abs_def] msb_uint_big max_sint_def simp del: nat_uint_eq)

lemma arraycpy_rule_snat[vcg_rules]:
  "llvm_htriple
    (\<upharpoonleft>array_assn dst dsti ** \<upharpoonleft>array_assn src srci ** \<upharpoonleft>snat.assn n ni ** \<up>\<^sub>d(n\<le>length src \<and> n\<le>length dst))
    (arraycpy dsti srci ni)
    (\<lambda>_. \<upharpoonleft>array_assn (take n src @ drop n dst) dsti ** \<upharpoonleft>array_assn src srci)"
  unfolding arraycpy_def
  apply (rewrite annotate_llc_while[where
    I="\<lambda>ii t. EXS i dst'. \<upharpoonleft>snat.assn i ii ** \<upharpoonleft>array_assn dst' dsti ** \<upharpoonleft>array_assn src srci
      ** \<up>\<^sub>d(0\<le>i \<and> i\<le>n \<and> dst' = take i src @ drop i dst) ** \<up>\<^sub>a(t = n-i)"
    and R = "measure id"
      ])
  apply vcg_monadify
  apply vcg'
  apply (auto simp: list_update_append upd_conv_take_nth_drop take_Suc_conv_app_nth)
  done

subsubsection \<open>Array-Set\<close>

definition arrayset :: "'b::llvm_rep ptr \<Rightarrow> 'b \<Rightarrow> 'a::len2 word \<Rightarrow> unit llM" where
  [llvm_code]: "arrayset dst c n \<equiv> doM {
    llc_while
      (\<lambda>i. ll_cmp (i<n))
      (\<lambda>i. doM {
        array_upd dst i c;
        let i=i+(signed_nat 1);
        return i
      }) (signed_nat 0);
    return ()
  }"

(*declare arrayset_def[llvm_code]*)

export_llvm (debug) "arrayset :: 32 word ptr \<Rightarrow> 32 word \<Rightarrow> 64 word \<Rightarrow> _"

lemma arrayset_rule_snat[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>array_assn dst dsti ** \<upharpoonleft>snat.assn n ni ** \<up>\<^sub>d(n\<le>length dst))
  (arrayset dsti c ni)
  (\<lambda>_. \<upharpoonleft>array_assn (replicate n c @ drop n dst) dsti)"
  unfolding arrayset_def
  apply (rewrite annotate_llc_while[where
    I="\<lambda>ii t. EXS i dst'. \<upharpoonleft>snat.assn i ii ** \<upharpoonleft>array_assn dst' dsti
      ** \<up>\<^sub>d(0\<le>i \<and> i\<le>n \<and> dst' = replicate i c @ drop i dst) ** \<up>\<^sub>a(t = n-i)"
    and R="measure id"
  ])
  apply vcg_monadify
  apply vcg'
  apply (auto simp: nth_append list_update_append replicate_Suc_conv_snoc simp del: replicate_Suc)
  by (metis Cons_nth_drop_Suc less_le_trans list_update_code(2))

text \<open>Array-Set also works for zero-size, and any pointer, including \<open>null\<close>\<close>
lemma arrayset_zerosize_rule: "llvm_htriple (\<upharpoonleft>snat.assn 0 ni) (arrayset p c ni) (\<lambda>_. \<box>)"
  unfolding arrayset_def
  apply (rewrite annotate_llc_while[where I="\<lambda>ii _. EXS i. \<upharpoonleft>snat.assn i ii" and R="{}"])
  apply vcg_monadify
  apply vcg
  done

subsubsection \<open>Array-New-Init\<close>

definition "array_new_init n (c::'a::llvm_rep) \<equiv> doM {
  r \<leftarrow> array_new TYPE('a) n;
  arrayset r c n;
  return r
}"

lemma array_new_init_rule[vcg_rules]: "llvm_htriple
  (\<upharpoonleft>snat.assn n ni ** \<up>\<^sub>d(n>0))
  (array_new_init ni c)
  (\<lambda>r. \<upharpoonleft>array_assn (replicate n c) r)"
  unfolding array_new_init_def
  by vcg

end


section \<open>Two-step Optimized MRU Model\<close>
theory Two_Step_MRU
imports "../MRU_Vote_Opt" "../Two_Steps"
begin

text \<open>To make the coming proofs of concrete algorithms easier, in this model we split
  the @{term opt_mru_round} into two steps\<close>

context mono_quorum
begin

subsection \<open>Model definition\<close>
(******************************************************************************)

definition opt_mru_step0 :: "round \<Rightarrow> process set \<Rightarrow> process set \<Rightarrow> val \<Rightarrow>  (opt_mru_state \<times> opt_mru_state) set" where
  "opt_mru_step0 r Q S v = {(s, s').
     (* guards *)
     r = next_round s \<and> two_step r = 0
     \<and> (S = {} \<or> opt_mru_guard (mru_vote s) Q v)
     \<and> (* actions *)
     s' = s\<lparr>
       mru_vote := mru_vote s ++ const_map (two_phase r, v) S
       , next_round := Suc r
     \<rparr>
  }"

definition r_votes :: "opt_mru_state \<Rightarrow> round \<Rightarrow> (process, val)map" where
  "r_votes s r \<equiv> \<lambda>p. if (\<exists>v. mru_vote s p = Some (two_phase r, v))
        then map_option snd (mru_vote s p)
        else None"

definition opt_mru_step1 :: "round \<Rightarrow> (process, val)map \<Rightarrow> (opt_mru_state \<times> opt_mru_state) set" where
  "opt_mru_step1 r dec_f = {(s, s').
     (* guards *)
     r = next_round s \<and> two_step r = 1
     \<and> d_guard dec_f (r_votes s r)
     \<and> (* actions *)
     s' = s\<lparr>
       next_round := Suc r
       , decisions := decisions s ++ dec_f
     \<rparr>
  }"

lemmas ts_lv_evt_defs = opt_mru_step0_def opt_mru_step1_def opt_mru_guard_def

definition ts_lv_trans :: "(opt_mru_state \<times> opt_mru_state) set" where
  "ts_lv_trans = (\<Union>r Q S v. opt_mru_step0 r Q S v) \<union> (\<Union>r dec_f. opt_mru_step1 r dec_f) \<union> Id"

definition ts_lv_TS :: "opt_mru_state TS" where
  "ts_lv_TS = \<lparr> init = opt_mru_init, trans = ts_lv_trans \<rparr>"

lemmas ts_lv_TS_defs = ts_lv_TS_def opt_mru_init_def ts_lv_trans_def

subsection \<open>Refinement\<close>
(******************************************************************************)

definition basic_rel where
  "basic_rel \<equiv> {(sa, sc).
    decisions sc = decisions sa
    \<and> next_round sa = two_phase (next_round sc)
  }"

definition two_step0_rel :: "(opt_mru_state \<times> opt_mru_state)set" where
  "two_step0_rel \<equiv> basic_rel \<inter> {(sa, sc).
    two_step (next_round sc) = 0
    \<and> mru_vote sc = mru_vote sa
  }"

definition two_step1_rel :: "(opt_mru_state \<times> opt_mru_state)set"  where
  "two_step1_rel \<equiv> basic_rel \<inter> {(sa, sc).
    (\<exists>sc' r Q S v. (sa, sc') \<in> two_step0_rel \<and> (sc', sc) \<in> opt_mru_step0 r Q S v)
  }"

definition ts_ref_rel where
  "ts_ref_rel = {(sa, sc).
    (two_step (next_round sc) = 0 \<longrightarrow> (sa, sc) \<in> two_step0_rel)
    \<and> (two_step (next_round sc) = 1 \<longrightarrow> (sa, sc) \<in> two_step1_rel)
  }"

lemmas ts_ref_rel_defs =
  basic_rel_def
  ts_ref_rel_def
  two_step0_rel_def
  two_step1_rel_def

lemma step0_ref:
  "{ts_ref_rel} Id, opt_mru_step0 r Q S v {> ts_ref_rel}"
  apply(auto simp only: PO_rhoare_defs)
  apply(auto simp add: ts_ref_rel_def opt_mru_step0_def two_step_phase_Suc two_step1_rel_def)
  apply(auto simp add: two_step0_rel_def basic_rel_def two_step_phase_Suc)
  done

lemma step1_ref:
  "{ts_ref_rel \<inter> OMRU_inv1 \<times> UNIV}
    \<Union>r' Q S' v dec_f'. opt_mru_round r' Q S' v dec_f',
    opt_mru_step1 r dec_f {> ts_ref_rel}"
proof(auto simp only: PO_rhoare_defs)
  fix sa sc1 sc2
  assume
    ainv: "sa \<in> OMRU_inv1"
    and R: "(sa, sc1) \<in> ts_ref_rel"
    and step1: "(sc1, sc2) \<in> opt_mru_step1 r dec_f"

  then obtain sc0 r0 S0 Q v where
    R0: "(sa, sc0) \<in> two_step0_rel" and step0: "(sc0, sc1) \<in> opt_mru_step0 r0 Q S0 v"
    by(auto simp add: ts_ref_rel_def two_step1_rel_def opt_mru_step1_def)

  have R1: "(sa, sc1) \<in> two_step1_rel"
    and r1_step: "two_step (next_round sc1) = Suc 0"
    and r2_step: "two_step (next_round sc2) = 0"
    using R step1
    by(auto simp add: ts_ref_rel_def opt_mru_step1_def two_step_phase_Suc)

  have r: "r = Suc r0" and r0: "r0 = next_round sc0" and r0_step: "two_step r0 = 0" and
    r1: "r = next_round sc1"
    using step0 step1
    by(auto simp add: opt_mru_step0_def opt_mru_step1_def)

  have abs_round1: "next_round sa = two_phase r" using R1 r1
    by(auto simp add: two_step1_rel_def basic_rel_def)
  have abs_round0: "next_round sa = two_phase r0" using R0 r0 r
    by(auto simp add: two_step0_rel_def basic_rel_def two_step_phase_Suc)

  have r_votes: "r_votes sc1 r = const_map v S0"
  proof(rule ext)
    fix p
    show "r_votes sc1 r p = const_map v S0 p"
    proof(cases "r_votes sc1 r p")
      case None
      thus ?thesis using step0 abs_round0 abs_round1
        by(auto simp add: r_votes_def opt_mru_step0_def
          const_map_def restrict_map_def map_add_def)
    next
      case (Some w)
      hence in_S0: "mru_vote sc0 p \<noteq> mru_vote sc1 p" using R0 step0 ainv r1_step r abs_round0
        by(auto simp add: r_votes_def ts_ref_rel_defs
          two_step_phase_Suc opt_mru_step0_def dest: OMRU_inv1D[where p=p])
      hence "p \<in> S0"  using step0
        by(auto simp add: opt_mru_step0_def map_add_def const_map_is_Some
          split: option.split_asm)
      moreover have "w=v" using R0 step0 ainv r1_step r abs_round0 Some
        by(auto simp add: r_votes_def ts_ref_rel_defs const_map_is_Some
          two_step_phase_Suc opt_mru_step0_def dest: OMRU_inv1D[where p=p])
      ultimately show ?thesis using Some
        by(auto simp add: const_map_def)
    qed
  qed

  define sa' where "sa' = sa\<lparr>
      mru_vote := mru_vote sa ++ const_map (two_phase r, v) S0
      , next_round := Suc (two_phase r)
      , decisions := decisions sa ++ dec_f
    \<rparr>"

  have "(sa, sa') \<in> opt_mru_round (two_phase r) Q S0 v dec_f \<and> (sa', sc2) \<in> ts_ref_rel"
  proof
    show "(sa', sc2) \<in> ts_ref_rel" using r2_step R0 step0 step1
      by(auto simp add: ts_ref_rel_def two_step0_rel_def basic_rel_def opt_mru_step0_def opt_mru_step1_def
        sa'_def two_step_phase_Suc)
  next
    show "(sa, sa') \<in> opt_mru_round (two_phase r) Q S0 v dec_f"
      using R0 r0_step r1_step step0 step1 r0 r1 r r_votes
      by(auto simp add: ts_ref_rel_defs opt_mru_round_def two_step_phase_Suc
        opt_mru_step0_def opt_mru_step1_def sa'_def)
  qed
  thus "\<exists>y. (sa, y) \<in> (\<Union>r' Q S' v D'. opt_mru_round r' Q S' v D') \<and> (y, sc2) \<in> ts_ref_rel"
    by blast
qed

lemma TwoStep_Coordinated_Refines:
  "PO_refines (ts_ref_rel \<inter> OMRU_inv1 \<times> UNIV)
    lv_TS ts_lv_TS"
proof(rule refine_using_invariants)
  show "init ts_lv_TS \<subseteq> ts_ref_rel `` init lv_TS"
    by(auto simp add: ts_lv_TS_defs lv_TS_def ts_ref_rel_def two_step0_rel_def two_step1_rel_def
      basic_rel_def)
next
  show
    "{ts_ref_rel \<inter> OMRU_inv1 \<times> UNIV} TS.trans lv_TS,
      TS.trans (ts_lv_TS) {> ts_ref_rel}"
    apply(simp add: lv_TS_defs ts_lv_TS_defs)
    apply(auto simp add: ts_lv_trans_def intro!: step0_ref step1_ref)
    done
qed(auto intro!: OMRU_inv1_inductive)

subsection \<open>Invariants\<close>
(******************************************************************************)

definition TS_OMRU_inv1 where
  "TS_OMRU_inv1 \<equiv> {s.
    (two_step (next_round s) = 0 \<longrightarrow>
      (\<forall>p \<Phi> v. mru_vote s p = Some (\<Phi>, v) \<longrightarrow> \<Phi> < two_phase (next_round s)))
    \<and> (two_step (next_round s) = 1 \<longrightarrow>
      (\<forall>p \<Phi> v. mru_vote s p = Some (\<Phi>, v) \<longrightarrow> \<Phi> \<le> two_phase (next_round s)))
  }"

lemma two_step_neqD:
  "two_step x \<noteq> Suc 0 \<Longrightarrow> two_step x = 0"
  "0 < two_step x \<Longrightarrow> two_step x = Suc 0"
  by(auto simp add: two_step_def)

lemma TS_OMRU_inv1_inductive:
  "init ts_lv_TS \<subseteq> TS_OMRU_inv1"
  "{TS_OMRU_inv1} trans ts_lv_TS {> TS_OMRU_inv1}"
  apply(fastforce simp add: PO_hoare_defs ts_lv_TS_def opt_mru_init_def TS_OMRU_inv1_def)[1]
  apply(auto simp add: PO_hoare_defs ts_lv_TS_def ts_lv_trans_def opt_mru_step0_def opt_mru_step1_def)
  apply(auto simp add: TS_OMRU_inv1_def two_step_phase_Suc const_map_is_Some const_map_is_None
    less_Suc_eq_le dest: less_imp_le)
  done

end

end


section \<open>The Static Representation of a Language\<close>

theory Language
  imports Semantics
begin

locale language =
  semantics step final
  for
    step :: "'state \<Rightarrow> 'state \<Rightarrow> bool" and
    final :: "'state \<Rightarrow> bool" +
  fixes
    load :: "'prog \<Rightarrow> 'state \<Rightarrow> bool"

context language begin

text \<open>
The language locale represents the concrete program representation (type variable @{typ 'prog}), which can be transformed into a program state (type variable @{typ 'state}) by the @{term load } function.
The set of initial states of the transition system is implicitly defined by the codomain of @{term load}.
\<close>

subsection \<open>Program behaviour\<close>

definition prog_behaves :: "'prog \<Rightarrow> 'state behaviour \<Rightarrow> bool" (infix "\<Down>" 50) where
  "prog_behaves = load OO state_behaves"

text \<open>If both the @{term load} and @{term step} relations are deterministic, then so is the behaviour of a program.\<close>

lemma right_unique_prog_behaves:
  assumes
    right_unique_load: "right_unique load" and
    right_unique_step: "right_unique step"
  shows "right_unique prog_behaves"
  unfolding prog_behaves_def
  using right_unique_state_behaves[OF right_unique_step] right_unique_load
  by (auto intro: right_unique_OO)

end

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)
 *)

(*
 * Facts about recursive functions with measure parameter.
 * Any recursive functions from AutoCorres are monotonic in the measure,
 * which allows us to use the "measure_call" mechanism for calling them.
 *)
theory MonadMono imports
  NonDetMonadEx "../lib/OptionMonadWP"
begin

(*
 * Call function f by returning all of its possible results.
 * The call succeeds if any measure value succeeds.
 *)
definition "measure_call f \<equiv>
    \<lambda>s. ({(r', s'). \<exists>m. (r', s') \<in> fst (f m s)}, \<forall>m. snd (f m s))"

(*
 * monad_mono gives preconditions for functions so that measure_call will
 * return meaningful results.
 *
 * The preconditions are:
 *
 * - If the measure is increased, the function never returns fewer
 *   results. (Monotonicity condition)
 *
 * - If the function succeeds with some measure, it will not fail with
 *   a larger measure, and will return exactly the same results.
 *
 * The monotonicity condition is technically not needed, but all our
 * functions satisfy it anyway and it makes intermediate proofs easier.
 *)
definition "monad_mono f \<equiv>
     (\<forall>(x :: nat) y s. x < y \<longrightarrow>
         (fst (f x s) \<subseteq> fst (f y s) \<and>
          (\<not> snd (f x s) \<longrightarrow> \<not> snd (f y s) \<and> fst (f x s) = fst (f y s))))"

(* Basic monad_mono lemmas *)
lemma monad_mono_incl: "\<lbrakk> monad_mono f; \<not> snd (f m s) \<rbrakk> \<Longrightarrow> fst (f m' s) \<subseteq> fst (f m s)"
  using less_linear[where x = m and y = m']
  by (auto simp: monad_mono_def)

(* wp rules for function calls *)
lemma call_all_valid [wp]:
    "\<lbrakk> \<forall> m. valid P (x m) Q; monad_mono x \<rbrakk> \<Longrightarrow> valid P (measure_call x) Q"
  apply (clarsimp simp: valid_def measure_call_def monad_mono_def)
  by blast

lemma call_all_validNF [wp]:
    "\<lbrakk>  validNF P (x m) Q; monad_mono x \<rbrakk> \<Longrightarrow> validNF P (measure_call x) Q"
  apply (clarsimp simp: measure_call_def validNF_def valid_def no_fail_def)
  apply (metis in_mono split_conv monad_mono_incl)
  done

(* Alternative definition of monad_mono, suitable for induction *)
definition "monad_mono_step f m \<equiv>
  (\<forall>s. fst (f m s) \<subseteq> fst (f (Suc m) s) \<and>
       (\<not> snd (f m s) \<longrightarrow> \<not> snd (f (Suc m) s) \<and> fst (f m s) = fst (f (Suc m) s)))"

lemma monad_mono_alt_def: "monad_mono f = (\<forall>m. monad_mono_step f m)"
  apply (rule iffI)
   apply (fastforce simp: monad_mono_def monad_mono_step_def)
  apply (unfold monad_mono_def monad_mono_step_def)
  apply clarify
  apply (subst (asm) atomize_all[symmetric])+
  proof -
    fix x y :: nat
    fix s
    assume suc: "\<And>m s. fst (f m s) \<subseteq> fst (f (Suc m) s) \<and>
              (\<not> snd (f m s) \<longrightarrow> \<not> snd (f (Suc m) s) \<and> fst (f m s) = fst (f (Suc m) s))"
       and less: "x < y"
    thus "fst (f x s) \<subseteq> fst (f y s) \<and>
          (\<not> snd (f x s) \<longrightarrow> \<not> snd (f y s) \<and> fst (f x s) = fst (f y s))"
      apply (induct x)
       apply (induct y)
        apply blast
       apply blast
      (* induct bureaucracy... *)
      proof -
        fix x :: nat
        assume less: "Suc x < y"
        thus "fst (f (Suc x) s) \<subseteq> fst (f y s) \<and>
           (\<not> snd (f (Suc x) s) \<longrightarrow> \<not> snd (f y s) \<and> fst (f (Suc x) s) = fst (f y s))"
          apply (induct y)
           apply blast
          apply (case_tac "Suc x < y")
           using suc apply blast
          apply (case_tac "Suc x = y")
           using suc apply blast
          apply simp
          done
       qed
  qed

lemmas monad_mono_step = iffD2[OF monad_mono_alt_def, rule_format]

lemma monad_mono_step_const: "monad_mono_step (\<lambda>_. f) m"
  by (simp add: monad_mono_step_def)

(* nondet_monad rules *)
lemma monad_mono_step_in_monad:
  "\<lbrakk> monad_mono_step f m; (r', s') \<in> fst (f m s) \<rbrakk> \<Longrightarrow> (r', s') \<in> fst (f (Suc m) s)"
  apply (clarsimp simp: monad_mono_step_def)
  apply blast
  done

lemma monad_mono_step_snd_monad:
  "\<lbrakk> monad_mono_step f m; \<not> snd (f m s) \<rbrakk> \<Longrightarrow> \<not> snd (f (Suc m) s)"
  by (clarsimp simp: monad_mono_step_def)

lemma monad_mono_step_bexI:
  "\<lbrakk> monad_mono_step f m; (r', s') \<in> fst (f m s); P r' s' \<rbrakk> \<Longrightarrow> \<exists>(r', s') \<in> fst (f (Suc m) s). P r' s'"
  apply (drule (1) monad_mono_step_in_monad)
  apply force
  done

lemma monad_mono_stepI [intro]:
  "\<lbrakk> \<And>s r' s'. (r', s') \<in> fst (f m s) \<Longrightarrow> (r', s') \<in> fst (f (Suc m) s);
     \<And>s. \<not> snd (f m s) \<Longrightarrow> \<not> snd (f (Suc m) s);
     \<And>s r' s'. \<lbrakk> \<not> snd (f m s); \<not> snd (f (Suc m) s); (r', s') \<in> fst (f (Suc m) s) \<rbrakk>
                \<Longrightarrow> (r', s') \<in> fst (f m s)
   \<rbrakk> \<Longrightarrow> monad_mono_step f m"
  apply (clarsimp simp: monad_mono_step_def)
  apply fast
  done

lemma monad_mono_step_bind:
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. (f m) >>= (g m)) m"
  apply atomize
  apply rule
    apply (monad_eq)
    apply (metis monad_mono_step_in_monad)
   apply (monad_eq simp: Ball_def)
   apply (metis monad_mono_step_def)
  apply (monad_eq simp: Ball_def)
  apply (unfold monad_mono_step_def)
  apply blast
  done

lemma monad_mono_step_bindE:
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. (f m) >>=E (g m)) m"
  apply (unfold bindE_def)
  apply (rule monad_mono_step_bind)
   apply simp
  apply (monad_eq simp: monad_mono_step_def NonDetMonad.lift_def
      split: sum.splits)
  done

lemma monad_mono_step_liftE:
  "monad_mono_step f m \<Longrightarrow> monad_mono_step (\<lambda>m. liftE (f m)) m"
  apply (unfold liftE_def)
  apply (erule monad_mono_step_bind)
  apply (rule monad_mono_step_const)
  done

lemma monad_mono_step_handleE':
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. f m <handle2> g m) m"
  apply atomize
  apply rule
    apply (monad_eq)
    apply (metis monad_mono_step_in_monad)
   apply (monad_eq simp: Ball_def)
   apply (metis monad_mono_step_def)
  apply (monad_eq simp: Ball_def)
  apply (fastforce simp: monad_mono_step_def)
  done

lemma monad_mono_step_handleE:
  "\<lbrakk> monad_mono_step f m; \<And>x. monad_mono_step (\<lambda>m. g m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. f m <handle> g m) m"
  by (simp add: handleE_def monad_mono_step_handleE')

lemma monad_mono_step_condition:
  "\<lbrakk> monad_mono_step f m; monad_mono_step g m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. condition C (f m) (g m)) m"
  apply rule
    apply (monad_eq simp: monad_mono_step_def, blast)+
  done

lemma fst_whileLoop_is_exs_valid:
  "((a, b) \<in> fst (whileLoop C B i s)) = \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B i \<exists>\<lbrace> \<lambda>rv s. rv = a \<and> s = b \<rbrace>"
  by (clarsimp simp: exs_valid_def Bex_def)

lemma not_snd_whileLoop_is_validNF:
  "(\<not> snd (whileLoop C B i s)) = \<lbrace> \<lambda>s'. s' = s \<rbrace> whileLoop C B i \<lbrace> \<lambda>_ _. True \<rbrace>!"
  by (clarsimp simp: validNF_alt_def)

lemma monad_mono_step_whileLoop:
  assumes body_mono: "\<And>x. monad_mono_step (\<lambda>m. B m x) m"
  shows "monad_mono_step (\<lambda>m. whileLoop C (B m) i) m"
proof -
  {
    fix a b s
    have "(a, b) \<in> fst (whileLoop C (B m) i s) \<Longrightarrow>
             (a, b) \<in> fst (whileLoop C (B (Suc m)) i s)"
      apply (clarsimp simp: fst_whileLoop_is_exs_valid)
      apply (subst (asm) exs_valid_whileLoop_complete [symmetric])
      apply (erule exE | erule conjE)+
      apply (rule_tac T=T and R=R in exs_valid_whileLoop)
         apply clarsimp
        apply (cut_tac x=r in body_mono)
        apply (clarsimp simp: monad_mono_step_def exs_valid_def split_def)
        apply blast
       apply simp
      apply blast
      done
  }
  note A = this

  {
    fix a b s
    have "\<lbrakk> \<not> snd (whileLoop C (B m) i s);
                  (a, b) \<in> fst (whileLoop C (B (Suc m)) i s) \<rbrakk>
              \<Longrightarrow> (a, b) \<in> fst (whileLoop C (B m) i s)"
      apply (clarsimp simp: fst_whileLoop_is_exs_valid)
      apply (subst (asm) exs_valid_whileLoop_complete [symmetric])
      apply (subst (asm) not_snd_whileLoop_complete)
      apply (erule exE | erule conjE)+
      apply (rule_tac T="\<lambda>r s. T r s \<and> I r s" and R=Ra in exs_valid_whileLoop)
         apply simp
        apply (cut_tac x=r in body_mono)
        apply (clarsimp simp: monad_mono_step_def exs_valid_def split_def Bex_def)
        apply metis
       apply simp
      apply (clarsimp simp: exs_valid_def Bex_def)
      done
  }
  note B = this

  {
    fix i s
    have "\<lbrakk>\<not> snd (whileLoop C (B m) i s) \<rbrakk> \<Longrightarrow>
                  \<not> snd (whileLoop C (B (Suc m)) i s)"
      apply (subst (asm) not_snd_whileLoop_complete)
      apply (erule exE | erule conjE)+
      apply (rule_tac I="I" and R=R in not_snd_whileLoop)
        apply clarsimp
       apply (cut_tac x=r in body_mono)
       apply (clarsimp simp: monad_mono_step_def validNF_alt_def)
       apply blast
      apply simp
      done
  }
  note C = this

  show ?thesis
    apply (clarsimp simp: monad_mono_step_def)
    apply (metis prod.exhaust subsetI subset_antisym A B C)
    done
qed

lemma monad_mono_step_whileLoopE:
  "\<lbrakk> \<And>x. monad_mono_step (\<lambda>m. B m x) m \<rbrakk>
   \<Longrightarrow> monad_mono_step (\<lambda>m. whileLoopE C (B m) i) m"
  apply (unfold whileLoopE_def)
  apply (subgoal_tac "\<And>x. monad_mono_step (\<lambda>m. lift (B m) x) m")
  apply (erule monad_mono_step_whileLoop)
  apply (unfold lift_def)
  apply rule
    apply (clarsimp split: prod.splits sum.splits)
    apply (fastforce dest: monad_mono_step_in_monad)
   apply (clarsimp split: prod.splits sum.splits simp: monad_mono_step_def)+
  done

(* measure_call for the option monad. *)
definition "measure_ocall f \<equiv> \<lambda>s. f (SOME m. f m s \<noteq> None) s"

definition "option_monad_mono f \<equiv>
  \<forall>(x :: nat) y s. x < y \<longrightarrow>
    (case f y s of None \<Rightarrow> f x s = None
                 | Some r \<Rightarrow> f x s = None \<or> f x s = Some r)"

lemma option_monad_mono_eq:
  "(\<And>m. f m = gets_the (f' m)) \<Longrightarrow> monad_mono f = option_monad_mono f'"
  apply (clarsimp simp: monad_mono_def option_monad_mono_def gets_the_def
    gets_def get_def assert_opt_def return_def fail_def bind_def' split: option.splits)
  apply (rule iff_allI iff_impI)+
  apply (rule_tac t = "\<forall>r. f' x s = Some r \<longrightarrow> (\<exists>r'. f' y s = Some r') \<and> (\<forall>r'. f' y s = Some r' \<longrightarrow> r = r')"
              and s = "\<forall>r. f' x s = Some r \<longrightarrow> f' y s = Some r" in subst)
   apply (force intro: iff_allI iff_impI)
  apply (rule iffI)
   apply (metis (hide_lams, no_types) option.exhaust)
  apply force
  done

lemma measure_ocall_ovalid [wp]:
    "\<lbrakk> \<forall> m. ovalid P (x m) Q; option_monad_mono x \<rbrakk> \<Longrightarrow> ovalid P (measure_ocall x) Q"
  by (clarsimp simp: ovalid_def measure_ocall_def option_monad_mono_def)

lemma measure_ocall_ovalidNF [wp]:
    "\<lbrakk> ovalidNF P (x m) Q; option_monad_mono x \<rbrakk> \<Longrightarrow> ovalidNF P (measure_ocall x) Q"
  apply (clarsimp simp: measure_ocall_def option_monad_mono_def ovalidNF_def)
  apply (rule_tac a = m in someI2)
   apply simp
  apply (metis (lifting, full_types) linorder_neqE_nat option.distinct(1) option.simps(5))
  done

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 Arbitrary_Comm_Monoid
imports Main
begin

text {*
  We define operations "arbitrary_add" and "arbitrary_zero"
  to represent an arbitrary commutative monoid.
*}

definition
  arbitrary_add :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  (infixl "+\<^sub>?" 65)
where
  "arbitrary_add a b \<equiv> fst (SOME (f, z). comm_monoid f z) a b"

definition
  arbitrary_zero :: "'a"
  ("0\<^sub>?")
where
 "arbitrary_zero \<equiv> snd (SOME (f, z). comm_monoid f z)"

text {*
  For every type, there exists some function @{term f} and
  identity @{term e} on that type forming a monoid.
*}
lemma comm_monoid_exists:
      "\<exists>f e. comm_monoid f e"
proof cases
  assume two_elements: "\<exists>(a :: 'a) b. a \<noteq> b"

  obtain x e where diff: "x \<noteq> (e :: 'a)"
    by (atomize_elim, clarsimp simp: two_elements)

  def f \<equiv> "\<lambda>a b. (if a = e then b else (if b = e then a else x))"

  have "\<forall>a b. f a b = f b a"
    by (simp add: f_def)
  moreover have "\<forall>a b c. f (f a b) c = f a (f b c)"
    by (simp add: diff f_def)
  moreover have "\<forall>b. f e b = b"
    by (simp add: diff f_def)
  ultimately show ?thesis
    by (metis comm_monoid_def abel_semigroup_def semigroup_def
          abel_semigroup_axioms_def comm_monoid_axioms_def)
next
  assume single_element: "\<not> (\<exists>(a :: 'a) b. a \<noteq> b)"
  thus ?thesis
    by (metis (full_types) comm_monoid_def abel_semigroup_def
          semigroup_def abel_semigroup_axioms_def comm_monoid_axioms_def)
qed

text {*
  These operations form a commutative monoid.
*}
interpretation comm_monoid arbitrary_add arbitrary_zero
  unfolding arbitrary_add_def [abs_def] arbitrary_zero_def
  by (rule someI2_ex, auto simp: comm_monoid_exists)

end


section {* Executable Type Checker *}

theory Wasm_Checker imports Wasm_Checker_Types begin

fun convert_cond :: "t \<Rightarrow> t \<Rightarrow> sx option \<Rightarrow> bool" where
  "convert_cond t1 t2 sx = ((t1 \<noteq> t2) \<and> (sx = None) = ((is_float_t t1 \<and> is_float_t t2)
                                                        \<or> (is_int_t t1 \<and> is_int_t t2 \<and> (t_length t1 < t_length t2))))"

fun same_lab_h :: "nat list \<Rightarrow> (t list) list \<Rightarrow> t list \<Rightarrow> (t list) option" where
  "same_lab_h [] _ ts = Some ts"
| "same_lab_h (i#is) lab_c ts = (if i \<ge> length lab_c
                                 then None
                                 else (if lab_c!i = ts
                                       then same_lab_h is lab_c (lab_c!i)
                                       else None))"

fun same_lab :: "nat list \<Rightarrow> (t list) list \<Rightarrow> (t list) option" where
  "same_lab [] lab_c = None"
| "same_lab (i#is) lab_c = (if i \<ge> length lab_c
                            then None
                            else same_lab_h is lab_c (lab_c!i))"

lemma same_lab_h_conv_list_all:
  assumes "same_lab_h ils ls ts' = Some ts"
  shows "list_all (\<lambda>i. i < length ls \<and> ls!i = ts) ils \<and> ts' = ts"
  using assms
proof(induction ils)
  case (Cons a ils)
  thus ?case
    apply (simp,safe)
       apply (metis not_less option.distinct(1))+
    done
qed simp

lemma same_lab_conv_list_all:
  assumes "same_lab ils ls = Some ts"
  shows "list_all (\<lambda>i. i < length ls \<and> ls!i = ts) ils"
  using assms
proof (induction rule: same_lab.induct)
case (2 i "is" lab_c)
  thus ?case
    using same_lab_h_conv_list_all
    by (metis (mono_tags, lifting) list_all_simps(1) not_less option.distinct(1) same_lab.simps(2))
qed simp

lemma list_all_conv_same_lab_h:
  assumes "list_all (\<lambda>i. i < length ls \<and> ls!i = ts) ils"
  shows "same_lab_h ils ls ts = Some ts"
  using assms
  by (induction ils, simp_all)

lemma list_all_conv_same_lab:
  assumes "list_all (\<lambda>i. i < length ls \<and>ls!i = ts) (is@[i])"
  shows "same_lab (is@[i]) ls = Some ts"
  using assms
proof (induction "(is@[i])")
  case (Cons a x)
  thus ?case
    using list_all_conv_same_lab_h[OF Cons(3)]
    by (metis option.distinct(1) same_lab.simps(2) same_lab_h.simps(2))
qed auto

fun b_e_type_checker :: "t_context \<Rightarrow>  b_e list \<Rightarrow> tf \<Rightarrow> bool"
and check :: "t_context \<Rightarrow> b_e list \<Rightarrow> checker_type \<Rightarrow> checker_type"
and check_single :: "t_context \<Rightarrow>  b_e \<Rightarrow> checker_type \<Rightarrow> checker_type" where
  "b_e_type_checker \<C> es (tn _> tm) = c_types_agree (check \<C> es (Type tn)) tm"
| "check \<C> es ts = (case es of
                     [] \<Rightarrow> ts
                   | (e#es) \<Rightarrow> (case ts of
                                  Bot \<Rightarrow> Bot
                                | _ \<Rightarrow> check \<C> es (check_single \<C> e ts)))"
(*
foldl (\<lambda> ts e. (case ts of Bot \<Rightarrow> Bot | _ \<Rightarrow> check_single \<C> e ts)) es

primrec foldl :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b" where
foldl_Nil:  "foldl f a [] = a" |
foldl_Cons: "foldl f a (x # xs) = foldl f (f a x) xs"
*)
  (* num ops *)
| "check_single \<C> (C v) ts = type_update ts [] (Type [typeof v])"
| "check_single \<C> (Unop t op) ts = (if unop_t_agree op t
                                       then type_update ts [TSome t] (Type [t])
                                       else Bot)"
| "check_single \<C> (Binop t op) ts = (if binop_t_agree op t
                                       then type_update ts [TSome t, TSome t] (Type [t])
                                       else Bot)"
| "check_single \<C> (Testop t _) ts = (if is_int_t t
                                       then type_update ts [TSome t] (Type [T_i32])
                                       else Bot)"
| "check_single \<C> (Relop t op) ts = (if relop_t_agree op t
                                       then type_update ts [TSome t, TSome t] (Type [T_i32])
                                       else Bot)"
  (* convert *)
| "check_single \<C> (Cvtop t1 Convert t2 sx) ts = (if (convert_cond t1 t2 sx)
                                                   then type_update ts [TSome t2] (Type [t1])
                                                   else Bot)"
  (* reinterpret *)
| "check_single \<C> (Cvtop t1 Reinterpret t2 sx) ts = (if ((t1 \<noteq> t2) \<and> t_length t1 = t_length t2 \<and> sx = None)
                                                         then type_update ts [TSome t2] (Type [t1])
                                                         else Bot)"
  (* unreachable, nop, drop, select *)
| "check_single \<C> (Unreachable) ts = type_update ts [] (TopType [])"
| "check_single \<C> (Nop) ts = ts"
| "check_single \<C> (Drop) ts = type_update ts [TAny] (Type [])"
| "check_single \<C> (Select) ts = type_update_select ts"
  (* block *)
| "check_single \<C> (Block (tn _> tm) es) ts = (if (b_e_type_checker (\<C>\<lparr>label := ([tm] @ (label \<C>))\<rparr>) es (tn _> tm))
                                                then type_update ts (to_ct_list tn) (Type tm)
                                                else Bot)"
  (* loop *)
| "check_single \<C> (Loop (tn _> tm) es) ts = (if (b_e_type_checker (\<C>\<lparr>label := ([tn] @ (label \<C>))\<rparr>) es (tn _> tm))
                                                then type_update ts (to_ct_list tn) (Type tm)
                                                else Bot)"
  (* if *)
| "check_single \<C> (If (tn _> tm) es1 es2) ts = (if (b_e_type_checker (\<C>\<lparr>label := ([tm] @ (label \<C>))\<rparr>) es1 (tn _> tm)
                                                    \<and> b_e_type_checker (\<C>\<lparr>label := ([tm] @ (label \<C>))\<rparr>) es2 (tn _> tm))
                                                then type_update ts (to_ct_list (tn@[T_i32])) (Type tm)
                                                else Bot)"
  (* br *)
| "check_single \<C> (Br i) ts = (if i < length (label \<C>)
                                 then type_update ts (to_ct_list ((label \<C>)!i)) (TopType [])
                                 else Bot)"
  (* br_if *)
| "check_single \<C> (Br_if i) ts = (if i < length (label \<C>)
                                    then type_update ts (to_ct_list ((label \<C>)!i @ [T_i32])) (Type ((label \<C>)!i))
                                    else Bot)"
  (* br_table *)
| "check_single \<C> (Br_table is i) ts = (case (same_lab (is@[i]) (label \<C>)) of
                                        None \<Rightarrow> Bot
                                      | Some tls \<Rightarrow> type_update ts (to_ct_list (tls @ [T_i32])) (TopType []))"
  (* return *)
| "check_single \<C> (Return) ts = (case (return \<C>) of
                                   None \<Rightarrow> Bot
                                 | Some tls \<Rightarrow> type_update ts (to_ct_list tls) (TopType []))"
  (* call *)
| "check_single \<C> (Call i) ts = (if i < length (func_t \<C>)
                                    then (case ((func_t \<C>)!i) of
                                            (tn _> tm) \<Rightarrow> type_update ts (to_ct_list tn) (Type tm))
                                    else Bot)"
  (* call_indirect *)
| "check_single \<C> (Call_indirect i) ts = (if length (table \<C>) \<ge> 1  \<and> i < length (types_t \<C>)
                                            then (case ((types_t \<C>)!i) of
                                                    (tn _> tm) \<Rightarrow> type_update ts (to_ct_list (tn@[T_i32])) (Type tm))
                                            else Bot)"
  (* get_local *)
| "check_single \<C> (Get_local i) ts = (if i < length (local \<C>)
                                        then type_update ts [] (Type [(local \<C>)!i])
                                        else Bot)"
  (* set_local *)
| "check_single \<C> (Set_local i) ts = (if i < length (local \<C>)
                                        then type_update ts [TSome ((local \<C>)!i)] (Type [])
                                        else Bot)"
  (* tee_local *)
| "check_single \<C> (Tee_local i) ts = (if i < length (local \<C>)
                                 then type_update ts [TSome ((local \<C>)!i)] (Type [(local \<C>)!i])
                                 else Bot)"
  (* get_global *)
| "check_single \<C> (Get_global i) ts = (if i < length (global \<C>)
                                         then type_update ts [] (Type [tg_t ((global \<C>)!i)])
                                         else Bot)"
  (* set_global *)
| "check_single \<C> (Set_global i) ts = (if i < length (global \<C>) \<and> is_mut (global \<C> ! i)
                                         then type_update ts [TSome (tg_t ((global \<C>)!i))] (Type [])
                                         else Bot)"
  (* load *)
| "check_single \<C> (Load t tp_sx a off) ts = (if length (memory \<C>) \<ge> 1 \<and> load_store_t_bounds a (option_projl tp_sx) t
                                 then type_update ts [TSome T_i32] (Type [t])
                                 else Bot)"
  (* store *)
| "check_single \<C> (Store t tp a off) ts = (if length (memory \<C>) \<ge> 1 \<and> load_store_t_bounds a tp t
                                             then type_update ts [TSome T_i32,TSome t] (Type [])
                                             else Bot)"
  (* current_memory *)
| "check_single \<C> Current_memory ts = (if length (memory \<C>) \<ge> 1
                                         then type_update ts [] (Type [T_i32])
                                         else Bot)"
  (* grow_memory *)
| "check_single \<C> Grow_memory ts = (if length (memory \<C>) \<ge> 1
                                      then type_update ts [TSome T_i32] (Type [T_i32])
                                      else Bot)"

end


(*  Title:      ZF/Coind/Values.thy
    Author:     Jacob Frost, Cambridge University Computer Laboratory
    Copyright   1995  University of Cambridge
*)

theory Values imports Language Map begin

(* Values, values environments and associated operators *)

consts
  Val  :: i
  ValEnv  :: i
  Val_ValEnv  :: i

codatatype
    "Val" = v_const ("c \<in> Const")
          | v_clos ("x \<in> ExVar","e \<in> Exp","ve \<in> ValEnv")
  and
    "ValEnv" = ve_mk ("m \<in> PMap(ExVar,Val)")
  monos       PMap_mono
  type_intros  A_into_univ mapQU

consts
  ve_owr :: "[i,i,i] \<Rightarrow> i"
  ve_dom :: "i\<Rightarrow>i"
  ve_app :: "[i,i] \<Rightarrow> i"

primrec "ve_owr(ve_mk(m), x, v) = ve_mk(map_owr(m,x,v))"

primrec "ve_dom(ve_mk(m)) = domain(m)"

primrec "ve_app(ve_mk(m), a) = map_app(m,a)"

definition
  ve_emp :: i  where
   "ve_emp \<equiv> ve_mk(map_emp)"

(* Elimination rules *)

lemma ValEnvE:
  "\<lbrakk>ve \<in> ValEnv; \<And>m.\<lbrakk>ve=ve_mk(m); m \<in> PMap(ExVar,Val)\<rbrakk> \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
apply (unfold Part_def Val_def ValEnv_def, clarify)
apply (erule Val_ValEnv.cases)
apply (auto simp add: Val_def Part_def Val_ValEnv.con_defs)
done

lemma ValE:
  "\<lbrakk>v \<in> Val;
      \<And>c. \<lbrakk>v = v_const(c); c \<in> Const\<rbrakk> \<Longrightarrow> Q;
      \<And>e ve x.
        \<lbrakk>v = v_clos(x,e,ve); x \<in> ExVar; e \<in> Exp; ve \<in> ValEnv\<rbrakk> \<Longrightarrow> Q
\<rbrakk> \<Longrightarrow>
   Q"
apply (unfold Part_def Val_def ValEnv_def, clarify)
apply (erule Val_ValEnv.cases)
apply (auto simp add: ValEnv_def Part_def Val_ValEnv.con_defs)
done

(* Nonempty sets *)

lemma v_closNE [simp]: "v_clos(x,e,ve) \<noteq> 0"
by (unfold QPair_def QInl_def QInr_def Val_ValEnv.con_defs, blast)

declare v_closNE [THEN notE, elim!]

lemma v_constNE [simp]: "c \<in> Const \<Longrightarrow> v_const(c) \<noteq> 0"
  unfolding QPair_def QInl_def QInr_def Val_ValEnv.con_defs
apply (drule constNEE, auto)
done

(* Proving that the empty set is not a value *)

lemma ValNEE: "v \<in> Val \<Longrightarrow> v \<noteq> 0"
by (erule ValE, auto)

(* Equalities for value environments *)

lemma ve_dom_owr [simp]:
     "\<lbrakk>ve \<in> ValEnv; v \<noteq>0\<rbrakk> \<Longrightarrow> ve_dom(ve_owr(ve,x,v)) = ve_dom(ve) \<union> {x}"
apply (erule ValEnvE)
apply (auto simp add: map_domain_owr)
done

lemma ve_app_owr [simp]:
     "ve \<in> ValEnv
      \<Longrightarrow> ve_app(ve_owr(ve,y,v),x) = (if x=y then v else ve_app(ve,x))"
by (erule ValEnvE, simp add: map_app_owr)

(* Introduction rules for operators on value environments *)

lemma ve_appI: "\<lbrakk>ve \<in> ValEnv; x \<in> ve_dom(ve)\<rbrakk> \<Longrightarrow> ve_app(ve,x):Val"
by (erule ValEnvE, simp add: pmap_appI)

lemma ve_domI: "\<lbrakk>ve \<in> ValEnv; x \<in> ve_dom(ve)\<rbrakk> \<Longrightarrow> x \<in> ExVar"
apply (erule ValEnvE, simp)
apply (blast dest: pmap_domainD)
done

lemma ve_empI: "ve_emp \<in> ValEnv"
  unfolding ve_emp_def
apply (rule Val_ValEnv.intros)
apply (rule pmap_empI)
done

lemma ve_owrI:
     "\<lbrakk>ve \<in> ValEnv; x \<in> ExVar; v \<in> Val\<rbrakk> \<Longrightarrow> ve_owr(ve,x,v):ValEnv"
apply (erule ValEnvE, simp)
apply (blast intro: pmap_owrI Val_ValEnv.intros)
done

end


theory Stream = Main:

use tactics

method_setup circular_coinduction = "build_tactic (circular_coinduction_fun)" "coinduction,init,repeat(breakup,close_or_step),force_finish"
method_setup coinduction = "build_tactic (coinduction_fun)" "rule_tac R=?Rzero in ga_cogenerated, instantiate_tac Rzero %s1.?R,step"
method_setup init = "build_tactic (init_fun)" "(simp|(solve,blast))?,init2_fun?"
method_setup breakup = "build_tactic (breakup_fun)" "simp,((exE|conjE)+)?,disjE"
method_setup solve= "build_tactic (solve_fun 1)" "((exE|conjE|conjI)+)?,(simp)?,((exE|conjE|conjI)+)?,(simp)?"
method_setup step = "build_tactic (step_fun)" "((disjI2)+)?,inst r (rcs union (trans r))"
method_setup close= "build_tactic (close_fun)" "((disjI1|disjI2)+)?,((exE|conjE)+)?,force_solve|solve,disji1+,blast"
method_setup close_or_step= "build_tactic (close_or_step_fun)" "try to close current subgoal, if this fails, step"
method_setup force_finish = "build_tactic (force_finish_fun)" "force: inst r false,solve1"
(*method_setup first_then = "build_tactic (first_then_fun)" "repeat disji2,exi,exi,conji, then execute force_tac the same number of times"*)

typedecl "Elem"
typedecl "Stream"
consts
"identity" :: "Elem => Elem"
"cons" :: "Elem => Stream => Stream"
"hd" :: "Stream => Elem"
"tl" :: "Stream => Stream"
"first" :: "Stream => Stream"
"second" :: "Stream => Stream"
"third" :: "Stream => Stream"
"zip3" :: "Stream => Stream => Stream => Stream"
"even" :: "Stream => Stream"
"zip" :: "Stream => Stream => Stream"
"Odd" :: "Stream => Stream"
"const" :: "Elem => Stream"
"swap" :: "Elem => Elem => Stream"
"iterate" :: "(Elem => Elem) => Elem => Stream"
"map" :: "(Elem => Elem) => Stream => Stream"
"one" :: "Stream => Stream"
"two" :: "Stream => Stream"
"three" :: "Stream => Stream"
"four" :: "Stream => Stream"
"zip4" :: "Stream => Stream => Stream => Stream => Stream"

consts
  BinRelImage :: "('a => 'b) => ('a => 'a => bool) => ('b => 'b => bool)"
  Trans_Stream :: "('a => 'a => bool) => ('b => 'b => bool)"
  union :: "('a => 'a => bool)  => ('a => 'a => bool) => ('a => 'a => bool)" (infixl 20)
defs
  BinRelImage_def [simp] : "BinRelImage f R == %x y . EX u v . R u v & x = f u & y = f v"
  Trans_Stream_def [simp] : "Trans_Stream R == (BinRelImage tl R)"
  union_def [simp] : "R union S == % x y . R x y | S x y"

axioms

one_hd [simp]: "!! s :: Stream . (hd (one s)) = (hd s)"
one_tl [simp]: "!! s :: Stream . (tl (one s)) = one (tl (tl (tl (tl s))))"
two_hd [simp]: "!! s :: Stream . (hd (two s)) = (hd (tl s))"
two_tl [simp]: "!! s :: Stream . (tl (two s)) = two (tl (tl (tl (tl s))))"
three_hd [simp]: "!! s :: Stream . (hd (three s)) = (hd (tl (tl s)))"
three_tl [simp]: "!! s :: Stream . (tl (three s)) = three (tl (tl (tl (tl s))))"
four_hd [simp]: "!! s :: Stream . (hd (four s)) = (hd (tl (tl (tl s))))"
four_tl [simp]: "!! s :: Stream . (tl (four s)) = four (tl (tl (tl (tl s))))"
zip4_hd [simp]: "!! s1 :: Stream . !! s2 :: Stream . !! s3 :: Stream . !! s4 :: Stream . (hd (zip4 s1 s2 s3 s4)) = (hd s1)"
zip4_tl [simp]: "!! s1 :: Stream . !! s2 :: Stream . !! s3 :: Stream . !! s4 :: Stream . (tl (zip4 s1 s2 s3 s4)) = zip4 s2 s3 s4 (tl s1)"

first_hd [simp]: "!! s :: Stream . (hd (first s)) = (hd s)"
first_tl [simp]: "!! s :: Stream . (tl (first s)) = first (tl (tl (tl s)))"
second_hd [simp]: "!! s :: Stream . (hd (second s)) = (hd (tl s))"
second_tl [simp]: "!! s :: Stream . (tl (second s)) = second (tl (tl (tl s)))"
third_hd [simp]: "!! s :: Stream . (hd (third s)) = (hd (tl (tl s)))"
third_tl [simp]: "!! s :: Stream . (tl (third s)) = third (tl (tl (tl s)))"
zip3_hd [simp]: "!! s1 :: Stream . !! s2 :: Stream . !! s3 :: Stream . (hd (zip3 s1 s2 s3)) = (hd s1)"
zip3_tl [simp]: "!! s1 :: Stream . !! s2 :: Stream . !! s3 :: Stream . (tl (zip3 s1 s2 s3)) = zip3 s2 s3 (tl s1)"

Odd_hd [simp]: "!! s :: Stream . (hd (Odd s)) = (hd s)"
Odd_tl [simp]: "!! s :: Stream . (tl (Odd s)) = Odd (tl (tl s))"
even_hd [simp]: "!! s :: Stream . (hd (even s)) = (hd (tl s))"
even_tl [simp]: "!! s :: Stream . (tl (even s)) = even (tl (tl s))"
zip_hd [simp]: "!! s1 :: Stream . !! s2 :: Stream . (hd (zip s1 s2)) = (hd s1)"
zip_tl [simp]: "!! s1 :: Stream . !! s2 :: Stream . (tl (zip s1 s2)) = zip s2 (tl s1)"

identity_1 [simp]: "!! e :: Elem . (identity e) = (e)"
map_hd [simp]: "!! f :: Elem => Elem . !! s :: Stream . (hd (map f s)) = (f (hd s))"
map_tl [simp]: "!! f :: Elem => Elem . !! s :: Stream . (tl (map f s)) = (map f (tl s))"
iterate_hd [simp] : "!! f :: (Elem => Elem) . !! e :: Elem . (hd (iterate f e)) = e"
iterate_tl [simp] : "!! f :: (Elem => Elem) . !! e :: Elem . (tl (iterate f e)) = (iterate f (f e))"
const_hd [simp] : "!! e :: Elem . (hd (const e)) = e"
const_tl [simp] : "!! e :: Elem . (tl (const e)) = const e"
swap_hd [simp] : "!! e1 :: Elem . !! e :: Elem . (hd (swap e1 e2)) = e1"
swap_tl [simp] : "!! e1 :: Elem . !! e :: Elem . (tl (swap e1 e2)) = (swap e2 e1)"

ga_cogenerated_Stream: "!! R :: Stream => Stream => bool . !! u :: Stream . !! v :: Stream . ! x :: Stream . ! y :: Stream . R x y --> (hd x = hd y & R (tl x) (tl y))  ==> R u v ==> u = v"

theorem Stream_Zip2: "!! s :: Stream . zip (Odd s) (even s) = s"
apply(coinduction)
apply(init)
apply(breakup)
apply(close_or_step)
apply(force_finish)
done

theorem Stream_Zip2a: "!! s :: Stream . zip (Odd s) (even s) = s"
apply(circular_coinduction)
done

theorem Stream_Zip3: "!! s :: Stream . ((zip3 (first s) (second s)) (third s)) = s"
apply(coinduction)
apply(init)
apply(breakup)
apply(close_or_step)
apply(breakup)
apply(close_or_step)
apply(force_finish)
done

theorem Stream_Zip3a: "!! s :: Stream . ((zip3 (first s) (second s)) (third s)) = s"
apply(circular_coinduction)
done

theorem Stream_Zip4: "!! s :: Stream . ((zip4 (one s) (two s)) (three s) (four s)) = s"
apply(circular_coinduction)
(*
apply(coinduction)
apply(init)
apply(breakup)
apply(close_or_step)
apply(breakup)
apply(close_or_step)
apply(breakup)
apply(close_or_step)
apply(breakup)
apply(close_or_step)
apply(force_finish)
*)
done

theorem Stream_Iter_Const: "!! e :: Elem . const e = iterate identity e"
apply(circular_coinduction)
done

theorem Stream_Even_Const: "!! e :: Elem . const e = even (const e)"
apply(circular_coinduction)
done

theorem Stream_Odd_Swap: "!! e :: Elem . !! f :: Elem . const e = Odd (swap e f)"
apply(circular_coinduction)
done

theorem Stream_Swap_Const: "!! e :: Elem . const e = swap e e"
apply(circular_coinduction)
done

theorem Stream_Iter_Const: "!! e :: Elem . const e = map identity (const e)"
apply(circular_coinduction)
done

theorem Stream_Iter_Map: "!! e :: Elem . !! f :: (Elem => Elem) . (iterate f (f e)) = (map f (iterate f e))"
apply(circular_coinduction)
done

theorem Stream_Const_Swap: "!! a :: Elem . !! b :: Elem . (zip (const a) (const b)) = (swap a b)"
apply(circular_coinduction)
done

theorem cogenerated_Odd_even:
"!! R :: Stream => Stream => bool . !! u :: Stream . !! v :: Stream . ! x :: Stream . ! y :: Stream . \
 R x y --> (hd x = hd y & R (Odd x) (Odd y) & R (even x) (even y))  ==> R u v ==> u = v"
(*apply(tactic "compose_tac (true,get_ctxt_thm \"ga_cogenerated_Stream\",1) 1")*)
apply(rule_tac R=R in ga_cogenerated_Stream)
apply(init)
apply(simp)
apply(init)
apply(rule conjI)
apply(simp)
apply(breakup)
end


section \<open>Trace equivalence for resources\<close>

theory Random_System imports Converter_Rewrite begin

fun trace_callee :: "('a, 'b, 's) callee \<Rightarrow> 's spmf \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> 'a \<Rightarrow> 'b spmf" where
  "trace_callee callee p [] x = bind_spmf p (\<lambda>s. map_spmf fst (callee s x))"
| "trace_callee callee p ((a, b) # xs) x =
   trace_callee callee (cond_spmf_fst (bind_spmf p (\<lambda>s. callee s a)) b) xs x"

definition trace_callee_eq :: "('a, 'b, 's1) callee \<Rightarrow> ('a, 'b, 's2) callee \<Rightarrow> 'a set \<Rightarrow> 's1 spmf \<Rightarrow> 's2 spmf \<Rightarrow> bool" where
  "trace_callee_eq callee1 callee2 A p q \<longleftrightarrow>
  (\<forall>xs. set xs \<subseteq> A \<times> UNIV \<longrightarrow> (\<forall>x \<in> A. trace_callee callee1 p xs x = trace_callee callee2 q xs x))"

abbreviation trace_callee_eq' :: "'a set \<Rightarrow> ('a, 'b, 's1) callee \<Rightarrow> 's1 \<Rightarrow> ('a, 'b, 's2) callee \<Rightarrow> 's2 \<Rightarrow> bool"
  ("_ \<turnstile>\<^sub>C/ (_'((_)')) \<approx>/ (_'((_)'))" [90, 0, 0, 0, 0] 91)
  where "trace_callee_eq' A callee1 s1 callee2 s2 \<equiv> trace_callee_eq callee1 callee2 A (return_spmf s1) (return_spmf s2)"

lemma trace_callee_eqI:
  assumes "\<And>xs x. \<lbrakk> set xs \<subseteq> A \<times> UNIV; x \<in> A \<rbrakk>
    \<Longrightarrow> trace_callee callee1 p xs x = trace_callee callee2 q xs x"
  shows "trace_callee_eq callee1 callee2 A p q"
  using assms by(simp add: trace_callee_eq_def)

lemma trace_callee_eqD:
  assumes "trace_callee_eq callee1 callee2 A p q"
    and "set xs \<subseteq> A \<times> UNIV" "x \<in> A"
  shows "trace_callee callee1 p xs x = trace_callee callee2 q xs x"
  using assms by(simp add: trace_callee_eq_def)

lemma cond_spmf_fst_None [simp]: "cond_spmf_fst (return_pmf None) x = return_pmf None"
  by(simp)

lemma trace_callee_None [simp]:
  "trace_callee callee (return_pmf None) xs x = return_pmf None"
  by(induction xs)(auto)

proposition trace'_eqI_sim:
  fixes callee1 :: "('a, 'b, 's1) callee" and callee2 :: "('a, 'b, 's2) callee"
  assumes start: "S p q"
    and step: "\<And>p q a. \<lbrakk> S p q; a \<in> A \<rbrakk> \<Longrightarrow>
      bind_spmf p (\<lambda>s. map_spmf fst (callee1 s a)) = bind_spmf q (\<lambda>s. map_spmf fst (callee2 s a))"
    and sim: "\<And>p q a res b s'. \<lbrakk> S p q; a \<in> A; res \<in> set_spmf q; (b, s') \<in> set_spmf (callee2 res a) \<rbrakk>
      \<Longrightarrow> S (cond_spmf_fst (bind_spmf p (\<lambda>s. callee1 s a)) b)
            (cond_spmf_fst (bind_spmf q (\<lambda>s. callee2 s a)) b)"
  shows "trace_callee_eq callee1 callee2 A p q"
proof(rule trace_callee_eqI)
  fix xs :: "('a \<times> 'b) list" and z
  assume xs: "set xs \<subseteq> A \<times> UNIV" and z: "z \<in> A"

  from start show "trace_callee callee1 p xs z = trace_callee callee2 q xs z" using xs
  proof(induction xs arbitrary: p q)
    case Nil
    then show ?case using z by(simp add: step)
  next
    case (Cons xy xs)
    obtain x y where xy [simp]: "xy = (x, y)" by(cases xy)
    have "trace_callee callee1 p (xy # xs) z =
      trace_callee callee1 (cond_spmf_fst (bind_spmf p (\<lambda>s. callee1 s x)) y) xs z"
      by(simp add: bind_map_spmf split_def o_def)
    also have "\<dots> = trace_callee callee2 (cond_spmf_fst (bind_spmf q (\<lambda>s. callee2 s x)) y) xs z"
    proof(cases "\<exists>s \<in> set_spmf q. \<exists>s'. (y, s') \<in> set_spmf (callee2 s x)")
      case True
      then obtain s s' where "s \<in> set_spmf q" "(y, s') \<in> set_spmf (callee2 s x)" by blast
      from sim[OF \<open>S p q\<close> _ this] show ?thesis using Cons.prems by (auto intro: Cons.IH)
    next
      case False
      then have "cond_spmf_fst (bind_spmf q (\<lambda>s. callee2 s x)) y = return_pmf None"
        by(auto simp add: bind_eq_return_pmf_None)
      moreover from step[OF \<open>S p q\<close>, of x, THEN arg_cong[where f=set_spmf], THEN eq_refl] Cons.prems False
      have "cond_spmf_fst (bind_spmf p (\<lambda>s. callee1 s x)) y = return_pmf None"
        by(clarsimp simp add: bind_eq_return_pmf_None)(rule ccontr; fastforce)
      ultimately show ?thesis by(simp del: cond_spmf_fst_eq_return_None)
    qed
    also have "\<dots> = trace_callee callee2 q (xy # xs) z"
      by(simp add: split_def o_def)
    finally show ?case .
  qed
qed

fun trace_callee_aux :: "('a, 'b, 's) callee \<Rightarrow> 's spmf \<Rightarrow> ('a \<times> 'b) list \<Rightarrow> 's spmf" where
  "trace_callee_aux callee p [] = p"
| "trace_callee_aux callee p ((x, y) # xs) = trace_callee_aux callee (cond_spmf_fst (bind_spmf p (\<lambda>res. callee res x)) y) xs"

lemma trace_callee_conv_trace_callee_aux:
  "trace_callee callee p xs a = bind_spmf (trace_callee_aux callee p xs) (\<lambda>s. map_spmf fst (callee s a))"
  by(induction xs arbitrary: p)(auto simp add: split_def)

lemma trace_callee_aux_append:
  "trace_callee_aux callee p (xs @ ys) = trace_callee_aux callee (trace_callee_aux callee p xs) ys"
  by(induction xs arbitrary: p)(auto simp add: split_def)

inductive trace_callee_closure :: "('a, 'b, 's1) callee \<Rightarrow> ('a, 'b, 's2) callee \<Rightarrow> 'a set \<Rightarrow> 's1 spmf \<Rightarrow> 's2 spmf \<Rightarrow> 's1 spmf \<Rightarrow> 's2 spmf \<Rightarrow> bool"
  for callee1 callee2 A p q where
    "trace_callee_closure callee1 callee2 A p q (trace_callee_aux callee1 p xs) (trace_callee_aux callee2 q xs)" if "set xs \<subseteq> A \<times> UNIV"

lemma trace_callee_closure_start: "trace_callee_closure callee1 callee2 A p q p q"
  by(simp add: trace_callee_closure.simps exI[where x="[]"])

lemma trace_callee_closure_step:
  assumes "trace_callee_eq callee1 callee2 A p q"
    and "trace_callee_closure callee1 callee2 A p q p' q'"
    and "a \<in> A"
  shows "bind_spmf p' (\<lambda>s. map_spmf fst (callee1 s a)) = bind_spmf q' (\<lambda>s. map_spmf fst (callee2 s a))"
proof -
  from assms(2) obtain xs where xs: "set xs \<subseteq> A \<times> UNIV"
    and p: "p' = trace_callee_aux callee1 p xs" and q: "q' = trace_callee_aux callee2 q xs" by(cases)
  from trace_callee_eqD[OF assms(1) xs assms(3)] p q show ?thesis
    by(simp add: trace_callee_conv_trace_callee_aux)
qed

lemma trace_callee_closure_sim:
  assumes "trace_callee_closure callee1 callee2 A p q p' q'"
    and "a \<in> A"
  shows "trace_callee_closure callee1 callee2 A p q
     (cond_spmf_fst (bind_spmf p' (\<lambda>s. callee1 s a)) b)
     (cond_spmf_fst (bind_spmf q' (\<lambda>s. callee2 s a)) b)"
  using assms  proof (cases)
  case (1 xs)
  then show ?thesis by
      (auto simp add:trace_callee_closure.simps assms trace_callee_aux_append split_def map_spmf_conv_bind_spmf intro!: exI[where x="xs @ [(a, b)]"])
qed

proposition trace_callee_eq_complete:
  assumes "trace_callee_eq callee1 callee2 A p q"
  obtains S
  where "S p q"
    and "\<And>p q a. \<lbrakk> S p q; a \<in> A \<rbrakk> \<Longrightarrow>
      bind_spmf p (\<lambda>s. map_spmf fst (callee1 s a)) = bind_spmf q (\<lambda>s. map_spmf fst (callee2 s a))"
    and "\<And>p q a s b s'. \<lbrakk> S p q; a \<in> A; s \<in> set_spmf q; (b, s') \<in> set_spmf (callee2 s a) \<rbrakk>
      \<Longrightarrow> S (cond_spmf_fst (bind_spmf p (\<lambda>s. callee1 s a)) b)
            (cond_spmf_fst (bind_spmf q (\<lambda>s. callee2 s a)) b)"
  by(rule that[where S="trace_callee_closure callee1 callee2 A p q"])
    (auto intro: trace_callee_closure_start trace_callee_closure_step[OF assms] trace_callee_closure_sim)

lemma set_spmf_cond_spmf_fst: "set_spmf (cond_spmf_fst p a) = snd ` (set_spmf p \<inter> {a} \<times> UNIV)"
  by(simp add: cond_spmf_fst_def)

lemma trace_callee_eq_run_gpv:
  fixes callee1 :: "('a, 'b, 's1) callee" and callee2 :: "('a, 'b, 's2) callee"
  assumes trace_eq: "trace_callee_eq callee1 callee2 A p q"
    and inv1: "callee_invariant_on callee1 I1 \<I>"
    and inv1: "callee_invariant_on callee2 I2 \<I>"
    and WT: "\<I> \<turnstile>g gpv \<surd>"
    and out: "outs_gpv \<I> gpv \<subseteq> A"
    and pq: "lossless_spmf p" "lossless_spmf q"
    and I1: "\<forall>x\<in>set_spmf p. I1 x"
    and I2: "\<forall>y\<in>set_spmf q. I2 y"
  shows "bind_spmf p (run_gpv callee1 gpv) = bind_spmf q (run_gpv callee2 gpv)"
proof -
  from trace_eq obtain S where start: "S p q"
    and sim: "\<And>p q a. \<lbrakk> S p q; a \<in> A \<rbrakk> \<Longrightarrow>
      bind_spmf p (\<lambda>s. map_spmf fst (callee1 s a)) = bind_spmf q (\<lambda>s. map_spmf fst (callee2 s a))"
    and S: "\<And>p q a s b s'. \<lbrakk> S p q; a \<in> A; s \<in> set_spmf q; (b, s') \<in> set_spmf (callee2 s a) \<rbrakk>
      \<Longrightarrow> S (cond_spmf_fst (bind_spmf p (\<lambda>s. callee1 s a)) b)
            (cond_spmf_fst (bind_spmf q (\<lambda>s. callee2 s a)) b)"
    by(rule trace_callee_eq_complete) blast

  interpret I1: callee_invariant_on callee1 I1 \<I> by fact
  interpret I2: callee_invariant_on callee2 I2 \<I> by fact

  from \<open>S p q\<close> out pq WT I1 I2 show ?thesis
  proof(induction arbitrary: p q gpv rule: parallel_fixp_induct_2_2[OF partial_function_definitions_spmf partial_function_definitions_spmf exec_gpv.mono exec_gpv.mono exec_gpv_def exec_gpv_def, case_names adm bottom step])
    case (step exec_gpv' g)
    have[simp]: "generat \<in> set_spmf (the_gpv gpv) \<Longrightarrow>
         p \<bind> (\<lambda>xa. map_spmf fst (case generat of
             Pure x \<Rightarrow> return_spmf (x, xa)
           | IO out c \<Rightarrow> callee1 xa out \<bind> (\<lambda>(x, y). exec_gpv' (c x) y))) =
         q \<bind> (\<lambda>xa. map_spmf fst (case generat of
             Pure x \<Rightarrow> return_spmf (x, xa)
           | IO out c \<Rightarrow> callee2 xa out \<bind> (\<lambda>(x, y). g (c x) y)))" for generat
    proof (cases generat, goal_cases)
      case (2 out rpv)
      have [simp]: "IO out rpv \<in> set_spmf (the_gpv gpv) \<Longrightarrow> generat = IO out rpv \<Longrightarrow>
        map_spmf fst (p \<bind> (\<lambda>xa. callee1 xa out)) = map_spmf fst (q \<bind> (\<lambda>xa. callee2 xa out))"
        unfolding map_bind_spmf o_def
        by (rule sim) (use step.prems in \<open>auto intro: outs_gpv.IO\<close>)

      have[simp]: "\<lbrakk>IO out rpv \<in> set_spmf (the_gpv gpv); generat = IO out rpv; x \<in> set_spmf q; (a, b) \<in> set_spmf (callee2 x out)\<rbrakk> \<Longrightarrow>
       cond_spmf_fst (p \<bind> (\<lambda>xa. callee1 xa out)) a \<bind> (\<lambda>x. map_spmf fst (exec_gpv' (rpv a) x)) =
       cond_spmf_fst (q \<bind> (\<lambda>xa. callee2 xa out)) a \<bind> (\<lambda>x. map_spmf fst (g (rpv a) x))" for a b x
      proof (rule step.IH, goal_cases)
        case 1 then show ?case using step.prems by(auto intro!: S intro: outs_gpv.IO)
      next
        case 2
        then show ?case using step.prems by(force intro: outs_gpv.Cont dest: WT_calleeD[OF I2.WT_callee] WT_gpvD[OF step.prems(5)])
      next
        case 3
        then show ?case using sim[OF \<open>S p q\<close>, of out] step.prems(2)
          by(force simp add: bind_UNION image_Union intro: rev_image_eqI intro: outs_gpv.IO dest: arg_cong[where f="set_spmf"])
      next
        case 4
        then show ?case by(auto 4 3 simp add: bind_UNION image_Union intro: rev_image_eqI)
      next
        case 5
        then show ?case using step.prems by(auto 4 3 dest: WT_calleeD[OF I2.WT_callee] intro: WT_gpvD)
      next
        case 6
        then show ?case using step.prems by(auto simp add: bind_UNION image_Union set_spmf_cond_spmf_fst intro: I1.callee_invariant WT_gpvD)
      next
        case 7
        then show ?case using step.prems by(auto simp add: bind_UNION image_Union set_spmf_cond_spmf_fst intro: I2.callee_invariant WT_gpvD)
      qed

      from 2 show ?case
        by(simp add: map_bind_spmf o_def)
          (subst (1 2) bind_spmf_assoc[symmetric]
            , rewrite in "bind_spmf \<hole> _ = _" cond_spmf_fst_inverse[symmetric]
            , rewrite in "_ = bind_spmf \<hole> _" cond_spmf_fst_inverse[symmetric]
            , subst (1 2) bind_spmf_assoc
            , auto simp add: bind_map_spmf o_def intro!: bind_spmf_cong)
    qed (simp add: bind_spmf_const lossless_weight_spmfD step.prems)

    show ?case unfolding map_bind_spmf o_def by(subst (1 2) bind_commute_spmf) (auto intro: bind_spmf_cong[OF refl])
  qed simp_all
qed

lemma trace_callee_eq'_run_gpv:
  fixes callee1 :: "('a, 'b, 's1) callee" and callee2 :: "('a, 'b, 's2) callee"
  assumes trace_eq: "A \<turnstile>\<^sub>C callee1(s1) \<approx> callee2(s2)"
    and inv1: "callee_invariant_on callee1 I1 \<I>"
    and inv1: "callee_invariant_on callee2 I2 \<I>"
    and WT: "\<I> \<turnstile>g gpv \<surd>"
    and out: "outs_gpv \<I> gpv \<subseteq> A"
    and I1: "I1 s1"
    and I2: "I2 s2"
  shows "run_gpv callee1 gpv s1 = run_gpv callee2 gpv s2"
  using trace_callee_eq_run_gpv[OF assms(1-5)] assms(6-) by simp

abbreviation trace_eq :: "'a set \<Rightarrow> ('a, 'b) resource spmf \<Rightarrow> ('a, 'b) resource spmf \<Rightarrow> bool" where
  "trace_eq \<equiv> trace_callee_eq run_resource run_resource"

abbreviation trace_eq' :: "'a set \<Rightarrow> ('a, 'b) resource \<Rightarrow> ('a, 'b) resource \<Rightarrow> bool" ("(_) \<turnstile>\<^sub>R/ (_)/ \<approx> (_)" [90, 90, 90] 91) where
  "A \<turnstile>\<^sub>R res \<approx> res' \<equiv> trace_eq A (return_spmf res) (return_spmf res')"

lemma trace_callee_resource_of_oracle2:
  "trace_callee run_resource (map_spmf (resource_of_oracle callee) p) xs x =
   trace_callee callee p xs x"
proof(induction xs arbitrary: p)
  case (Cons xy xs)
  then show ?case by (cases xy) (simp add: bind_map_spmf o_def Cons.IH[symmetric] cond_spmf_fst_def map_bind_spmf[symmetric, unfolded o_def] spmf.map_comp map_prod_vimage)
qed (simp add: map_bind_spmf bind_map_spmf o_def spmf.map_comp)

lemma trace_callee_resource_of_oracle [simp]:
  "trace_callee run_resource (return_spmf (resource_of_oracle callee s)) xs x =
   trace_callee callee (return_spmf s) xs x"
  using trace_callee_resource_of_oracle2[of callee "return_spmf s" xs x] by simp

lemma trace_eq'_resource_of_oracle [simp]:
  "A \<turnstile>\<^sub>R resource_of_oracle callee1 s1 \<approx> resource_of_oracle callee2 s2 =
   A \<turnstile>\<^sub>C callee1(s1) \<approx> callee2(s2)"
  by(simp add: trace_callee_eq_def)

end