theory IICF_Array
imports "../Intf/IICF_List"
begin

section \<open>Plain Arrays Implementing List Interface\<close>

subsection \<open>Abstract Replicate-Init Operation\<close>
  definition [simp]: "replicate_init_raw n \<equiv> replicate n init"

  locale replicate_init =
    fixes repl :: "'a \<Rightarrow> nat \<Rightarrow> 'a list"
    assumes repl_def[simp]: "repl i n = replicate n i"
  begin

    context fixes i::'a begin
      sepref_register "repl i"
    end

    lemma replicate_init_param:
      fixes A :: "'a \<Rightarrow> 'c::llvm_rep \<Rightarrow> assn"
      assumes INIT: "GEN_ALGO i (is_init A)"
      shows "(RETURN o replicate_init_raw, RETURN o PR_CONST (repl i)) \<in> nat_rel \<rightarrow>\<^sub>f \<langle>\<langle>the_pure A\<rangle>list_rel\<rangle>nres_rel"
    proof -
      from INIT have [param]: "(init,i) \<in> the_pure A" unfolding is_init_def GEN_ALGO_def by simp
      show ?thesis
        unfolding repl_def replicate_init_raw_def PR_CONST_def
        apply (rule frefI)
        apply (parametricity)
        done

    qed

    lemma fold_replicate_init: "replicate n i = repl i n" by simp
  end

subsection \<open>Abstract grow-init Operation\<close>

  definition [simp]: "op_list_grow_init i ns os xs \<equiv> take os xs @ replicate (ns - os) i"
  context fixes i begin
    sepref_register "op_list_grow_init i"
  end

  definition [simp]: "grow_init_raw ns os xs \<equiv> take os xs @ replicate (ns - os) init"

  lemma grow_init_param:
    fixes A :: "'a \<Rightarrow> 'c::llvm_rep \<Rightarrow> assn"
    assumes INIT: "GEN_ALGO i (is_init A)"
    shows "(uncurry2 (RETURN ooo grow_init_raw), uncurry2 (RETURN ooo PR_CONST (op_list_grow_init i))) \<in> [\<lambda>_. True]\<^sub>f (nat_rel \<times>\<^sub>r nat_rel) \<times>\<^sub>r \<langle>the_pure A\<rangle>list_rel \<rightarrow> \<langle>\<langle>the_pure A\<rangle>list_rel\<rangle>nres_rel"
  proof -
    from INIT have [param]: "(init,i) \<in> the_pure A" unfolding is_init_def GEN_ALGO_def by simp
    have "(grow_init_raw, op_list_grow_init i) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> \<langle>the_pure A\<rangle>list_rel \<rightarrow> \<langle>the_pure A\<rangle>list_rel"
      unfolding op_list_grow_init_def grow_init_raw_def
      by parametricity
    from this[to_fref] show ?thesis unfolding PR_CONST_def
      by (auto intro!: frefI nres_relI dest!: frefD)

  qed

  sepref_decl_op list_free: "\<lambda>_::_ list. ()" :: "\<langle>A\<rangle>list_rel \<rightarrow> unit_rel" .

subsection \<open>Definition of Assertion\<close>

  text \<open>Lists of fixed length are directly implemented with arrays. \<close>

  hide_const (open) LLVM_DS_Array.array_assn

  abbreviation "raw_array_assn \<equiv> \<upharpoonleft>LLVM_DS_NArray.narray_assn"

  definition array_assn where "array_assn A \<equiv> hr_comp raw_array_assn (\<langle>the_pure A\<rangle>list_rel)"
  lemmas [safe_constraint_rules] = CN_FALSEI[of is_pure "array_assn A" for A]

  lemma array_assn_comp: "hr_comp (array_assn id_assn) (\<langle>the_pure A\<rangle>list_rel) = array_assn (A)"
    unfolding array_assn_def by simp

subsection \<open>Interface Implementation\<close>

definition [simp]: "array_replicate_init i n \<equiv> replicate n i"
interpretation array: replicate_init array_replicate_init by unfold_locales simp

context
  notes [fcomp_norm_unfold] = array_assn_def[symmetric] array_assn_comp
  (*notes [simp] = pure_def hn_ctxt_def is_array_def invalid_assn_def*)
begin

  lemma array_get_hnr_aux: "(uncurry array_nth,uncurry (RETURN oo op_list_get))
    \<in> [\<lambda>(l,i). i<length l]\<^sub>a raw_array_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k \<rightarrow> id_assn"
    unfolding snat_rel_def snat.assn_is_rel[symmetric]
    apply sepref_to_hoare
    apply vcg'
    done

  sepref_decl_impl array_get: array_get_hnr_aux .

  lemma array_set_hnr_aux: "(uncurry2 array_upd,uncurry2 (RETURN ooo op_list_set))
    \<in> [\<lambda>((l,i),_). i<length l]\<^sub>a raw_array_assn\<^sup>d *\<^sub>a snat_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow> raw_array_assn"
    unfolding snat_rel_def snat.assn_is_rel[symmetric]
    apply sepref_to_hoare
    apply (clarsimp simp: invalid_assn_def)
    apply (rule htriple_pure_preI, ((determ \<open>drule pure_part_split_conj|erule conjE\<close>)+)?)
    apply vcg
    done

  sepref_decl_impl array_set: array_set_hnr_aux .

  sepref_definition array_swap [llvm_code] is "uncurry2 (mop_list_swap)"
    :: "(array_assn id_assn)\<^sup>d *\<^sub>a (snat_assn)\<^sup>k *\<^sub>a (snat_assn)\<^sup>k \<rightarrow>\<^sub>a array_assn id_assn"
    unfolding gen_mop_list_swap by sepref

  sepref_decl_impl (ismop) array_swap.refine .

  lemma hn_array_repl_init_raw:
    shows "(narray_new TYPE('c::llvm_rep),RETURN o replicate_init_raw) \<in> snat_assn\<^sup>k \<rightarrow>\<^sub>a raw_array_assn"
    unfolding snat_rel_def snat.assn_is_rel[symmetric]
    apply sepref_to_hoare
    apply vcg'
    done

  sepref_decl_impl (no_mop) hn_array_repl_init_raw uses array.replicate_init_param .

  lemma hn_array_grow_init_raw:
    shows "(uncurry2 array_grow, uncurry2 (RETURN ooo grow_init_raw))
      \<in> [\<lambda>((ns,os),xs). os\<le>length xs \<and> os\<le>ns]\<^sub>a snat_assn\<^sup>k *\<^sub>a snat_assn\<^sup>k *\<^sub>a raw_array_assn\<^sup>d \<rightarrow> raw_array_assn"
    unfolding snat_rel_def snat.assn_is_rel[symmetric]
    apply sepref_to_hoare
    by vcg'

  sepref_decl_impl (no_mop) hn_array_grow_init_raw uses grow_init_param .

  sepref_decl_op array_custom_replicate: op_list_replicate :: "nat_rel \<rightarrow> A \<rightarrow> \<langle>A\<rangle>list_rel" .

  lemma hn_array_replicate_new_raw:
    "(uncurry narray_new_init, uncurry (RETURN oo op_array_custom_replicate)) \<in> snat_assn\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a raw_array_assn"
    unfolding snat_rel_def snat.assn_is_rel[symmetric]
    apply sepref_to_hoare
    by vcg

  sepref_decl_impl hn_array_replicate_new_raw .

  lemma array_fold_custom_replicate:
    "replicate = op_array_custom_replicate"
    "op_list_replicate = op_array_custom_replicate"
    "mop_list_replicate = mop_array_custom_replicate"
    by (auto del: ext intro!: ext)

  lemma hn_array_free_raw: "(narray_free,RETURN o op_list_free) \<in> raw_array_assn\<^sup>d \<rightarrow>\<^sub>a unit_assn"
    by sepref_to_hoare vcg

  sepref_decl_impl array_free: hn_array_free_raw .
  lemmas array_mk_free[sepref_frame_free_rules] = hn_MK_FREEI[OF array_free_hnr]

end

section \<open>Arrays with Length\<close>

definition "larray1_rel = br snd (\<lambda>(n,xs). n = length xs)"
abbreviation "larray_impl_assn' TYPE('b::len2) \<equiv> snat_assn' TYPE('b) \<times>\<^sub>a array_assn id_assn"
definition "raw_larray_assn \<equiv> hr_comp (larray_impl_assn' TYPE(_)) larray1_rel"

definition "larray_assn A \<equiv>  hr_comp raw_larray_assn (\<langle>the_pure A\<rangle>list_rel)"

abbreviation larray_assn'
  :: "'b itself \<Rightarrow> ('a \<Rightarrow> 'c \<Rightarrow> llvm_amemory \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'b::len2 word \<times> 'c::llvm_rep ptr \<Rightarrow> llvm_amemory \<Rightarrow> bool"
  where
  "larray_assn' _ == larray_assn"

type_synonym ('x,'l) larray = "'l word \<times> 'x ptr"

lemma larray1_rel_prenorm: "((n, xs), ys) \<in> larray1_rel \<longleftrightarrow> n = length ys \<and> xs=ys"
  by (auto simp: larray1_rel_def in_br_conv)

lemma larray_assn_comp: "hr_comp (larray_assn id_assn) (\<langle>the_pure A\<rangle>list_rel) = larray_assn A"
  unfolding larray_assn_def by simp

definition [simp]: "larray_replicate_init i n \<equiv> replicate n i"
interpretation larray: replicate_init larray_replicate_init by unfold_locales simp

context
  notes [fcomp_norm_unfold] = raw_larray_assn_def[symmetric] larray_assn_def[symmetric] larray_assn_comp
  notes [fcomp_prenorm_simps] = larray1_rel_prenorm
begin

sepref_decl_op larray_custom_replicate: op_list_replicate :: "nat_rel \<rightarrow> A \<rightarrow> \<langle>A\<rangle>list_rel" .

definition "la_replicate1 n i \<equiv> (n, replicate n i)"
lemma la_replicate1_refine: "(la_replicate1,op_larray_custom_replicate) \<in> nat_rel \<rightarrow> Id \<rightarrow> larray1_rel"
  by (auto simp: larray1_rel_def in_br_conv la_replicate1_def)

sepref_definition la_replicate_impl [llvm_inline] is "uncurry (RETURN oo la_replicate1)"
  :: "(snat_assn' TYPE('b::len2))\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow>\<^sub>a larray_impl_assn' TYPE('b::len2)"
  unfolding la_replicate1_def
  apply (rewrite array_fold_custom_replicate)
  apply sepref_dbg_keep
  done

sepref_decl_impl la_replicate_impl.refine[FCOMP la_replicate1_refine] .

lemma larray_fold_custom_replicate:
  "replicate = op_larray_custom_replicate"
  "op_list_replicate = op_larray_custom_replicate"
  "mop_list_replicate = mop_larray_custom_replicate"
  by (auto del: ext intro!: ext)

definition "la_replicate_init1 n \<equiv> (n, array_replicate_init init n)"
lemma la_replicate_init1_refine: "(la_replicate_init1, replicate_init_raw) \<in> nat_rel \<rightarrow> larray1_rel"
  by (auto simp: larray1_rel_def in_br_conv la_replicate_init1_def)

sepref_definition la_replicate_init_impl [llvm_inline] is "(RETURN o la_replicate_init1)"
  :: "(snat_assn' TYPE('b::len2))\<^sup>k \<rightarrow>\<^sub>a larray_impl_assn' TYPE('b::len2)"
  unfolding la_replicate_init1_def
  apply sepref_dbg_keep
  done

sepref_decl_impl (no_mop) la_replicate_init_impl.refine[FCOMP la_replicate_init1_refine] uses larray.replicate_init_param .

definition "la_grow_init1 \<equiv> \<lambda>ns os (n,xs). (ns, op_list_grow_init init ns os xs)"
lemma la_grow_init1_refine: "(uncurry2 la_grow_init1, uncurry2 grow_init_raw)
  \<in> [\<lambda>((ns,os),xs). os\<le>length xs \<and> os\<le>ns]\<^sub>f (nat_rel \<times>\<^sub>r nat_rel) \<times>\<^sub>r larray1_rel \<rightarrow> larray1_rel"
  by (auto simp: larray1_rel_def in_br_conv la_grow_init1_def intro!: frefI)

sepref_definition la_grow_init_impl [llvm_inline] is "(uncurry2 (RETURN ooo la_grow_init1))"
  :: "[\<lambda>((ns,os),(n,xs)). os\<le>length xs \<and> os\<le>ns]\<^sub>a (snat_assn' TYPE('b::len2))\<^sup>k *\<^sub>a (snat_assn' TYPE('b::len2))\<^sup>k *\<^sub>a (larray_impl_assn' TYPE('b::len2))\<^sup>d \<rightarrow> larray_impl_assn' TYPE('b::len2)"
  unfolding la_grow_init1_def
  by sepref

sepref_decl_impl (no_mop) la_grow_init_impl.refine[FCOMP la_grow_init1_refine] uses grow_init_param .

definition [simp]: "op_list_grow_init' i ns xs \<equiv> xs@replicate (ns-length xs) i"

lemma op_list_grow_init'_alt: "op_list_grow_init' i ns xs = op_list_grow_init i ns (length xs) xs" by simp

definition "la_length1 nxs \<equiv> case nxs of (n,_) \<Rightarrow> id n"
lemma la_length1_refine: "(la_length1,op_list_length) \<in> larray1_rel \<rightarrow> nat_rel"
  by (auto simp: larray1_rel_def in_br_conv la_length1_def)

sepref_definition la_length_impl [llvm_inline] is "RETURN o la_length1" :: "(larray_impl_assn' TYPE('b::len2))\<^sup>k \<rightarrow>\<^sub>a snat_assn' TYPE('b)"
  unfolding la_length1_def
  apply sepref_dbg_keep
  done

sepref_decl_impl la_length_impl.refine[FCOMP la_length1_refine] .

definition "la_is_empty1 nxs \<equiv> case nxs of (n,_) \<Rightarrow> n=0"
lemma la_is_empty1_refine: "(la_is_empty1,op_list_is_empty) \<in> larray1_rel \<rightarrow> bool_rel"
  by (auto simp: larray1_rel_def in_br_conv la_is_empty1_def)

sepref_definition la_is_empty_impl [llvm_inline] is "RETURN o la_is_empty1" :: "(larray_impl_assn' TYPE('b::len2))\<^sup>k \<rightarrow>\<^sub>a bool1_assn"
  unfolding la_is_empty1_def
  apply (annot_snat_const "TYPE('b)")
  apply sepref_dbg_keep
  done

sepref_decl_impl la_is_empty_impl.refine[FCOMP la_is_empty1_refine] .

definition "la_get1 nxs i \<equiv> case nxs of (n,xs) \<Rightarrow> xs!i"
lemma la_get1_refine: "(la_get1,op_list_get) \<in> larray1_rel \<rightarrow> nat_rel \<rightarrow> Id"
  by (auto simp: larray1_rel_def in_br_conv la_get1_def)

sepref_definition la_get_impl [llvm_inline] is "uncurry (RETURN oo la_get1)" :: "[\<lambda>(la,i). i<length (snd la)]\<^sub>a (larray_impl_assn' TYPE('b::len2))\<^sup>k *\<^sub>a (snat_assn' TYPE('c::len2))\<^sup>k \<rightarrow> id_assn"
  unfolding la_get1_def la_length1_def
  apply sepref_dbg_keep
  done

sepref_decl_impl la_get_impl.refine[FCOMP la_get1_refine] .

definition "la_set1 nxs i x \<equiv> case nxs of (n,xs) \<Rightarrow> (n,xs[i:=x])"
lemma la_set1_refine: "(la_set1,op_list_set) \<in> larray1_rel \<rightarrow> nat_rel \<rightarrow> Id \<rightarrow> larray1_rel"
  by (auto simp: larray1_rel_def in_br_conv la_set1_def)

sepref_definition la_set_impl [llvm_inline] is "uncurry2 (RETURN ooo la_set1)"
  :: "[\<lambda>((la,i),_). i<length (snd la)]\<^sub>a (larray_impl_assn' TYPE('b::len2))\<^sup>d *\<^sub>a (snat_assn' TYPE('c::len2))\<^sup>k *\<^sub>a id_assn\<^sup>k \<rightarrow> larray_impl_assn' TYPE('b::len2)"
  unfolding la_set1_def
  apply sepref_dbg_keep
  done

sepref_decl_impl la_set_impl.refine[FCOMP la_set1_refine] .

sepref_definition larray_swap is "uncurry2 (mop_list_swap)"
  :: "(larray_assn' TYPE('l::len2) id_assn)\<^sup>d *\<^sub>a (snat_assn)\<^sup>k *\<^sub>a (snat_assn)\<^sup>k \<rightarrow>\<^sub>a larray_assn' TYPE('l::len2) id_assn"
  unfolding gen_mop_list_swap by sepref

sepref_decl_impl (ismop) larray_swap.refine .

definition "la_free1 nxs \<equiv> case nxs of (_,xs) \<Rightarrow> op_list_free xs"
lemma la_free1_refine: "(la_free1,op_list_free) \<in> larray1_rel \<rightarrow> unit_rel" by auto

sepref_definition la_free_impl [llvm_inline] is "RETURN o la_free1" :: "(larray_impl_assn' TYPE(_))\<^sup>d \<rightarrow>\<^sub>a unit_assn"
  unfolding la_free1_def
  by sepref

sepref_decl_impl larray_free: la_free_impl.refine[FCOMP la_free1_refine] .
lemmas larray_mk_free[sepref_frame_free_rules] = hn_MK_FREEI[OF larray_free_hnr]

end

lemma larray_boundD[sepref_bounds_dest]:
  "rdomp (larray_assn' TYPE('a::len2) A) xs \<Longrightarrow> length xs < max_snat LENGTH('a)"
  unfolding larray_assn_def raw_larray_assn_def larray1_rel_def
  apply (auto simp: rdomp_hrcomp_conv in_br_conv snat_rel_def snat.rel_def)
  by (simp add: list_rel_pres_length)

subsection \<open>Ad-Hoc Regression Tests\<close>

sepref_definition example1 [llvm_code] is "\<lambda>n. RETURN (replicate (n+1) (snat_init TYPE(32)))"
  :: "[\<lambda>n. n\<in>{1..<150}]\<^sub>a (snat_assn' TYPE(32))\<^sup>k \<rightarrow> array_assn (snat_assn' TYPE(32))"
  apply (annot_snat_const "TYPE(32)")
  apply (rewrite array.fold_replicate_init)
  apply sepref
  done

sepref_definition example2 [llvm_code] is \<open>\<lambda>n. do {
  ASSERT (n>10);
  let a = replicate n (snat_const TYPE(64) 42);
  let a = a[snat_const TYPE(32) 3:=0];
  ASSERT (a!1=42 \<and> a!2=42);
  RETURN (a!snat_const TYPE(32) 1 + a!snat_const TYPE(32) 2)
}\<close> :: "(snat_assn' TYPE(32))\<^sup>k \<rightarrow>\<^sub>a snat_assn' TYPE(64)"
  apply (annot_snat_const "TYPE(64)")
  apply (rewrite array_fold_custom_replicate)
  apply sepref
  done

sepref_definition example1n [llvm_code] is "\<lambda>n. RETURN (replicate (n+1) (snat_init TYPE(8)))"
  :: "[\<lambda>n. n\<in>{1..<150}]\<^sub>a (snat_assn' TYPE(32))\<^sup>k \<rightarrow> larray_assn' TYPE(32) (snat_assn' TYPE(8))"
  apply (rewrite larray.fold_replicate_init)
  apply (annot_snat_const "TYPE(32)")
  apply sepref
  done

sepref_definition example2n [llvm_code] is \<open>\<lambda>n. do {
  ASSERT (n>10);
  let a = replicate n (snat_const TYPE(64) 42);
  let a = a[snat_const TYPE(32) 3:=0];
  ASSERT (a!1=42 \<and> a!2=42);
  RETURN (a!snat_const TYPE(32) 1 + a!snat_const TYPE(32) 2)
}\<close> :: "(snat_assn' TYPE(32))\<^sup>k \<rightarrow>\<^sub>a snat_assn' TYPE(64)"
  apply (annot_snat_const "TYPE(64)")
  apply (rewrite larray_fold_custom_replicate)
  apply sepref
  done

export_llvm example1 example2 example1n example2n

end


theory PI_Code_Export_Rat
  imports
    PI_Code
begin

code_datatype set RBT_set Complement Collect_set Set_Monad DList_set

lemmas List.subset_code(1)[code] List.in_set_member[code]

lemma finite_set_code[code]: "finite (set xs) = True" by auto

lemma set_fold_cfc_code[code]:"
    set_fold_cfc f b (set (xs :: 'c::ccompare list)) =
    (case ID ccompare of None \<Rightarrow> Code.abort STR ''set_fold_cfc RBT_set: ccompare = None'' (\<lambda>_. set_fold_cfc f b (set xs))
     | Some (x :: 'c \<Rightarrow> 'c \<Rightarrow> order) \<Rightarrow> fold (comp_fun_commute_apply f) (remdups xs) b)"
  unfolding set_fold_cfc.rep_eq
  by (auto split: option.splits simp: comp_fun_commute.comp_fun_commute comp_fun_commute_def'
      intro!: comp_fun_commute_on.fold_set_fold_remdups[of "set xs"] Finite_Set.comp_fun_commute_on.intro)

export_code
  ord_real_inst.less_eq_real quotient_of
  plus_real_inst.plus_real minus_real_inst.minus_real d0 to_valid_MDP MDP RBT_Map.update
  Rat.of_int divide divide_rat_inst.divide_rat divide_real_inst.divide_real nat_map_from_list
  assoc_list_to_MDP nat_pmf_of_list RBT_Set.empty PI_code pmf_of_list nat_of_integer
  Ratreal int_of_integer inverse_divide Tree2.inorder integer_of_nat
  in SML module_name PI_Code_Rat file_prefix PI_Code_Rat

end


(*  Title:      HOL/Auth/n_germanSimp_lemma_on_inv__33.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_germanSimp Protocol Case Study*}

theory n_germanSimp_lemma_on_inv__33 imports n_germanSimp_base
begin
section{*All lemmas on causal relation between inv__33 and some rule r*}
lemma n_RecvReqSVsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqS N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvReqE__part__0Vsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__0 N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqE__part__0 N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvReqE__part__1Vsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE__part__1 N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvReqE__part__1 N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__0Vsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__0  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInv__part__1Vsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInv__part__1  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendInvAckVsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendInvAck  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (eqn (IVar (Ident ''CurCmd'')) (Const Empty)) (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv4) ''Cmd'')) (Const Inv))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvInvAckVsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvInvAck  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntSVsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P3 s"
  apply (cut_tac a1 a2 b1, simp, rule_tac x="(neg (andForm (andForm (andForm (andForm (eqn (IVar (Field (Para (Ident ''Chan2'') p__Inv4) ''Cmd'')) (Const Empty)) (eqn (IVar (Para (Ident ''ShrSet'') p__Inv4)) (Const true))) (eqn (IVar (Field (Para (Ident ''Cache'') p__Inv4) ''State'')) (Const I))) (eqn (IVar (Ident ''CurCmd'')) (Const ReqS))) (eqn (IVar (Ident ''ExGntd'')) (Const false))))" in exI, auto) done
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_SendGntEVsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_SendGntE N i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntSVsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntS  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_RecvGntEVsinv__33:
assumes a1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)" and
a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
shows "invHoldForRule s f r (invariants N)" (is "?P1 s \<or> ?P2 s \<or> ?P3 s")
proof -
from a1 obtain i where a1:"i\<le>N\<and>r=n_RecvGntE  i" apply fastforce done
from a2 obtain p__Inv4 where a2:"p__Inv4\<le>N\<and>f=inv__33  p__Inv4" apply fastforce done
have "(i=p__Inv4)\<or>(i~=p__Inv4)" apply (cut_tac a1 a2, auto) done
moreover {
  assume b1: "(i=p__Inv4)"
  have "?P1 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
moreover {
  assume b1: "(i~=p__Inv4)"
  have "?P2 s"
  proof(cut_tac a1 a2 b1, auto) qed
  then have "invHoldForRule s f r (invariants N)" by auto
}
ultimately show "invHoldForRule s f r (invariants N)" by satx
qed

lemma n_StoreVsinv__33:
  assumes a1: "\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d" and
  a2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__33  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  apply (rule noEffectOnRule, cut_tac a1 a2, auto) done

end


(*  Title:      HOL/Auth/n_mutualExDeadFree_lemma_inv__5_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_mutualExDeadFree Protocol Case Study*}

theory n_mutualExDeadFree_lemma_inv__5_on_rules imports n_mutualExDeadFree_lemma_on_inv__5
begin
section{*All lemmas on causal relation between inv__5*}
lemma lemma_inv__5_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv1. p__Inv0\<le>N\<and>p__Inv1\<le>N\<and>p__Inv0~=p__Inv1\<and>f=inv__5  p__Inv0 p__Inv1)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Try  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_TryVsinv__5) done
    }

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

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

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

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

end


(*
 * Copyright 2016, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the GNU General Public License version 2. Note that NO WARRANTY is provided.
 * See "LICENSE_GPLv2.txt" for details.
 *
 * @TAG(NICTA_GPL)
 *)

theory WordArrayT
imports
  "../adt/BilbyT"
  "../lib/Loops"
begin

consts \<alpha>wa :: "'a WordArray \<Rightarrow> 'a list"
consts make :: "'a list \<Rightarrow> 'a WordArray"

definition
  mapAccumObs :: "nat \<Rightarrow> nat \<Rightarrow> (('a, 'acc, 'obsv) ElemAO \<Rightarrow> ('a \<times> 'acc))
   \<Rightarrow> 'a list \<Rightarrow> 'acc \<Rightarrow> 'obsv \<Rightarrow> 'a list \<times> 'acc"
where
  "mapAccumObs frm to fn xs vacc obs =
   (let (ys, acc) = fold (\<lambda>elem (ys,acc).
           let (elem,acc) = fn (ElemAO.make elem acc obs)
            in  (ys@[elem], acc)) (slice frm to xs) ([],vacc)
     in (take frm xs @ ys @ drop (max frm to) xs, acc))"

lemma length_mapAccum_helper:
  "length (fst $ fold (\<lambda>x (ys,a'). let  (elem, acc) = loopbody x a'
                                  in  (ys@[elem],acc)) (xs) (ys,a)
           )
         = length ys + length xs"
  by (induct xs arbitrary: a ys, auto simp: Let_def slice_def  split: prod.split)

lemma length_mapAccum_slice_helper:
  "length (let (xs', _) = fold (\<lambda>x (ys,a'). let  (elem, acc) = loopbody x a'
                                  in  (ys@[elem],acc)) (slice frm to xs) (ys,a)
           in xs') = length ys + length (slice frm to xs)"
  apply (simp only: Let_def  prod.case_eq_if)
   using length_mapAccum_helper[unfolded fun_app_def prod.case_eq_if Let_def]
   by fastforce

lemma slice_length:
 "length (slice frm to xs) = min (to - frm) (length xs - frm)"
 by (simp add: slice_def)

lemma length_mapAccum_slice_helper':
  "length (take frm xs @ fst (let (xs', acc) = fold (\<lambda>x (ys,a'). let  (elem, acc) = loopbody x a'
                                  in  (ys@[elem],acc)) (slice frm to xs) (ys,a)
           in (xs',acc))  @ drop (max frm to) xs) = length ys + length xs"
  unfolding Let_def  prod.case_eq_if
  using length_mapAccum_slice_helper[unfolded prod.case_eq_if Let_def, where xs=xs and ys=ys and frm=frm and to=to and loopbody=loopbody and a=a]
  by (simp add: slice_length)

lemma length_mapAccum:
  "length (fst (mapAccumObs frm to fn xs a obs)) = length xs"
  unfolding mapAccumObs_def
  using length_mapAccum_slice_helper'[where frm=frm and to=to and xs=xs and a=a and ys="[]"]
  by (auto simp:Let_def prod.case_eq_if)

lemma length_mapAccumI:
  " P (length xs) \<Longrightarrow> P (length (fst (mapAccumObs frm to fn xs a obs)))"
 by (simp add : length_mapAccum)

axiomatization
where
  wordarray_make: "\<And>xs. \<alpha>wa (WordArrayT.make xs) = xs"
 and
  wordarray_make': "\<And>wa. WordArrayT.make (\<alpha>wa wa) = wa"
 and
  wordarray_create_ret:
   "\<And>P.\<lbrakk>  \<And>ex'. (ex', Option\<^sub>1\<^sub>1.None ()) = malloc ex \<Longrightarrow> P (Error ex');
           \<And>ex' v. \<lbrakk> sz > 0 ; (ex', Option\<^sub>1\<^sub>1.Some v) = malloc ex; length (\<alpha>wa v) = unat sz \<rbrakk> \<Longrightarrow>
                 P (Success (ex', v))
        \<rbrakk> \<Longrightarrow>
      P (wordarray_create (ex, sz))"

   and wordarray_length_ret:
   "unat (wordarray_length arr) = length (\<alpha>wa arr)"

  and wordarray_get_ret:
  "\<lbrakk> unat index < length (\<alpha>wa arr) \<rbrakk> \<Longrightarrow>
    wordarray_get (arr, index) = \<alpha>wa arr ! unat index"

  and wordarray_modify_ret:
   "\<And>P. \<lbrakk> unat index < List.length (\<alpha>wa varr);
       let r = modifier (ElemAO.make ((\<alpha>wa varr)!unat index) vacc obs) in
       P (ArrA.make (WordArrayT.make (\<alpha>wa varr[unat index:=ElemA.elem\<^sub>f r])) (ElemA.acc\<^sub>f r)) \<rbrakk> \<Longrightarrow>
        P (wordarray_modify (ArrayUseValueP.make varr index modifier vacc obs))"
(* Alternative that does not use WordArray.make
  and wordarray_modify_ret:
   "\<And>P. \<lbrakk> unat index < List.length (\<alpha>wa varr);
       ElemA.make a acc'' = modifier (ElemAO.make ((\<alpha>wa varr)!unat index) vacc obs);
       \<And>arr'. \<alpha>wa arr' = (\<alpha>wa varr)[unat index:=a] \<Longrightarrow> P (ArrA.make arr' acc'') \<rbrakk> \<Longrightarrow>
        P (wordarray_modify (ArrayUseValueP.make varr index modifier vacc obs))"
*)
   and wordarray_map_no_break_ret:
   "\<And>P. (let (aarr, vacc) = mapAccumObs (unat frm) (unat to) body (\<alpha>wa arr) acc obs
          in P ((WordArrayT.make aarr), vacc))
   \<Longrightarrow> P (wordarray_map_no_break (ArrayMapP.make arr frm to body acc obs))"
  and wordarray_cmp_ret:
  "\<And>P. P(\<alpha>wa a1 = \<alpha>wa a2) \<Longrightarrow> P (wordarray_cmp(a1, a2))"
  and wordarray_set_ret:
  "(offs::U32) \<le> offs + len \<Longrightarrow>
   wordarray_set (wa, offs, len, (v::U8)) =
   WordArrayT.make ((take (unat offs) (\<alpha>wa wa) @
                   replicate (unat len) v @ drop (unat (offs + len)) (\<alpha>wa wa)))"

  and wordarray_copy_ret:
  "\<And>P. \<lbrakk>  length (\<alpha>wa dst) = length (\<alpha>wa src) \<Longrightarrow>
                  offs = src_offs \<Longrightarrow>
                  offs \<le> offs + len \<Longrightarrow>
                  unat (offs + len) \<le> length (\<alpha>wa src) \<Longrightarrow>
         P (WordArrayT.make (take (unat offs) (\<alpha>wa dst) @ slice (unat offs) (unat offs + unat len) (\<alpha>wa src) @ drop (unat (offs+len)) (\<alpha>wa src))) \<rbrakk>
     \<Longrightarrow>
      P (wordarray_copy(dst, src, offs, src_offs, len))"

lemma wordarray_\<alpha>wa_eq:
  "\<And>xs ys. (xs = ys) \<longleftrightarrow> \<alpha>wa xs = \<alpha>wa ys"
  apply (rule iffI)
   apply (erule arg_cong[where f=\<alpha>wa])
   apply (drule_tac x="\<alpha>wa xs" and y="\<alpha>wa ys" in arg_cong[where f=WordArrayT.make])
  apply (simp add: wordarray_make')
done

lemma ElemA_ext_inject_plus:
  "(\<lparr>ElemA.elem\<^sub>f = a, ElemA.acc\<^sub>f = b\<rparr> = v) = (ElemA.elem\<^sub>f v = a \<and> ElemA.acc\<^sub>f v = b)"
  by (case_tac v, auto)

lemma wordarray_modify_length':
  "\<And>index modifier vacc obs wa. unat index < length (\<alpha>wa wa) \<Longrightarrow>
   (length $ \<alpha>wa $ ArrA.arr\<^sub>f $ wordarray_modify (ArrayUseValueP.make wa index modifier vacc obs)) = (length $ \<alpha>wa $ wa)"
  by (fastforce intro: wordarray_modify_ret
                 simp: ArrA.make_def wordarray_make ElemA_ext_inject_plus
                       ElemA.make_def ElemAO.make_def)+

lemma wordarray_modify_length:
  "\<And>index modifier vacc obs wa. unat index < length (\<alpha>wa wa) \<Longrightarrow>
  P (length $ \<alpha>wa $ wa) \<Longrightarrow>
   P(length (\<alpha>wa (ArrA.arr\<^sub>f ( wordarray_modify (ArrayUseValueP.make wa index modifier vacc obs)))))"
   by (fastforce simp: wordarray_modify_length'[simplified])

lemma wordarray_get_ret':
  "\<lbrakk> unat index < length (\<alpha>wa arr); P (\<alpha>wa arr ! unat index) \<rbrakk> \<Longrightarrow>
    P (wordarray_get (arr, index))"
    using wordarray_get_ret by fastforce

lemma wordarray_length_ofnat:
  "unat (wordarray_length wa) = length (\<alpha>wa wa) \<Longrightarrow>
  wordarray_length wa = of_nat (length (\<alpha>wa wa))"
  by (drule sym, simp)

lemmas wordarray_make_rev = wordarray_make'

end